Dim parsel As DBParsel
Private Sub CAl_Click()
Call BilgiOku
End Sub
Private Sub CVer_Click()
Call BilgiEkle
End Sub
Private Sub UserForm_Initialize()
Call BilgiOku
End Sub
Function ParselBilgi(dblk As DataBlock, parsel As DBParsel, copyToDataBlock As Boolean)
dblk.CopyLong parsel.id, copyToDataBlock
dblk.CopyString parsel.Mah, copyToDataBlock
dblk.CopyLong parsel.Ada, copyToDataBlock
dblk.CopyLong parsel.parsel, copyToDataBlock
dblk.CopyDouble parsel.Yuzolcumu, copyToDataBlock
dblk.CopyString parsel.Sahibi, copyToDataBlock
dblk.CopyString parsel.Aciklama, copyToDataBlock
End Function
Function BilgiEkle()
Dim ele As Element
Dim dblk As New DataBlock
Dim dblke() As DataBlock
If seciliElement(ele) Then
parsel.id = Val(TId.Text)
parsel.Mah = TMah.Text
parsel.Ada = Val(TAda.Text)
parsel.parsel = Val(TParsel.Text)
parsel.Yuzolcumu = Val(TYuzolcumu)
parsel.Sahibi = TSahibi
parsel.Aciklama = TAciklama
dblke = ele.GetUserAttributeData(parselId)
ReDim Preserve dblke(0)
If Not dblke(0) Is Nothing Then
ele.DeleteUserAttributeData parselId, 0
ele.Rewrite
End If
Call ParselBilgi(dblk, parsel, True)
ele.AddUserAttributeData parselId, dblk
ele.Rewrite
End If
End Function
Function BilgiOku()
Dim ele As Element
Dim dblke() As DataBlock
Dim parsel As DBParsel
Dim value As Long, name As String
If seciliElement(ele) Then
dblke = ele.GetUserAttributeData(parselId)
ReDim Preserve dblke(0)
If Not dblke(0) Is Nothing Then
ParselBilgi dblke(0), parsel, False
TId.Text = Str(parsel.id)
TMah.Text = parsel.Mah
TAda.Text = Str(parsel.Ada)
TParsel.Text = Str(parsel.parsel)
TYuzolcumu = parsel.Yuzolcumu
TSahibi = parsel.Sahibi
TAciklama = parsel.Aciklama
End If
End If
End Function
Function seciliElement(ByRef sElement As Element) As Boolean
Dim oScanEnumerator As ElementEnumerator
If ActiveModelReference.AnyElementsSelected Then
Set oScanEnumerator = ActiveModelReference.GetSelectedElements
oScanEnumerator.MoveNext
Set sElement = oScanEnumerator.Current
seciliElement = True
Else
seciliElement = False
MsgBox ("Secili Element yok")
End If
End Function
Modul DBlock kodları
Public Type DBParsel
id As Long
Mah As String
Ada As Long
parsel As Long
Yuzolcumu As Double
Sahibi As String
Aciklama As String
End Type
Public Const parselId As Long = 1453
Sub ParselBilgisi()
FormDBlock.Show
End Sub
Parsellerin kapalı alan olması gerekmektedir.
Bilgi verdiğimiz parselleri seçerek excele yazdıralım.
Excelin açık olamsı lazım. Aktif Excel sayfasına veriler yazılacaktır.
Formumuza 2 tane buton ekleyelim
CExcele ve CExcelden isimleri verelim
Projeye Fonksiyonlar diye bir modül ekleyelim. İçine alttaki fonksiyonları yazalım
Declare Function mdlElmdscr_isGroupedHole Lib "stdmdlbltin.dll" (ByVal groupEdP As Long) As Long
Public Function IsGroupedHole(ByVal oElement As Element) As Boolean
IsGroupedHole = 0 <> mdlElmdscr_isGroupedHole(oElement.MdlElementDescrP)
End Function
Public Function HoleArea(ByVal oGroupedHole As CellElement) As Double
HoleArea = 0#
On Error GoTo err_ComputeGroupedHoleArea
If (IsGroupedHole(oGroupedHole)) Then
Dim area As Double
Dim oEnumerator As ElementEnumerator
Set oEnumerator = oGroupedHole.GetSubElements
' Get enclosing element
oEnumerator.MoveNext
If (oEnumerator.Current.IsClosedElement) Then
area = oEnumerator.Current.AsClosedElement.area
End If
Do While oEnumerator.MoveNext
' Get each hole element
If (oEnumerator.Current.IsClosedElement) Then
area = area - oEnumerator.Current.AsClosedElement.area
End If
Loop
If (0# < area) Then
HoleArea = area
End If
End If
Exit Function
err_ComputeGroupedHoleArea:
MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description, vbOKOnly Or vbCritical, "Error in ComputeGroupedHoleArea"
End Function
Function GetOrigin(ele As Element) As Point3d
If ele.IsClosedElement Then GetOrigin = ele.AsClosedElement.Centroid
If ele.IsCellElement Then GetOrigin = ele.AsCellElement.Origin
' If ele.IsApplicationElement Then GetOrigin = ele.AsApplicationElement.Range
End Function
Sub ElementScanComplex(oElement As ComplexElement)
Dim oEnumerator As ElementEnumerator
Dim oSubElement As Element
Set oEnumerator = oElement.GetSubElements
Do While oEnumerator.MoveNext
Set oSubElement = oEnumerator.Current
If oSubElement.IsTextElement = True Then
TextGetAttributes oSubElement
Else
ShowError "Sub unit found is not a text element!"
Exit Sub
End If
If oSubElement.IsComplexElement Then
ElementScanComplex oSubElement
End If
Loop
End Sub
Function besuLevel(levname As String) As Level
Set besuLevel = ActiveDesignFile.Levels.Find(levname)
If besuLevel Is Nothing Then
CadInputQueue.SendKeyin "level create " & Chr(34) & levname & Chr(34)
Set besuLevel = ActiveDesignFile.Levels.Find(levname)
End If
End Function
formun kod alananına 2 fonksiyon ilave edelim
Function ParselBilgiOku(ele As Element) As DBParsel
Dim dblke() As DataBlock
dblke = ele.GetUserAttributeData(parselId)
ReDim Preserve dblke(0)
If Not dblke(0) Is Nothing Then
ParselBilgi dblke(0), ParselBilgiOku, False
End If
End Function
Function ParselBilgiYaz(ele As Element, parsel As DBParsel)
Dim dblk As New DataBlock
Dim dblke() As DataBlock
dblke = ele.GetUserAttributeData(parselId)
ReDim Preserve dblke(0)
If Not dblke(0) Is Nothing Then
ele.DeleteUserAttributeData parselId, 0
ele.Rewrite
End If
Call ParselBilgi(dblk, parsel, True)
ele.AddUserAttributeData parselId, dblk
ele.Rewrite
End Function
CExcele butonuna kod ekleyelelim
Private Sub CExcele_Click()
Dim Counter As Long
Dim oScanCriteria As ElementScanCriteria
Dim oScanEnumerator As ElementEnumerator
Dim oElement As Element
Dim satir As Integer
Dim Elementno As Long
Dim sElement As Element
Dim cElement As Element
Dim vw As View
Dim ci As CursorInformation
Dim yazien As Double, yaziboy As Double
Dim chElement As CellElement
Dim ec As ElementCache
Dim alan As Double
Dim parsel As DBParsel
Dim oDE As DroppableElement
Dim oEE As ElementEnumerator
Set oXL = GetObject(, "Excel.Application")
Set oSheet = oXL.activeWorkbook.activesheet
Counter = 1
oSheet.Cells(Counter, 1).value = "Sıra"
oSheet.Cells(Counter, 2) = "Level"
oSheet.Cells(Counter, 3) = "Renk Çizgi"
oSheet.Cells(Counter, 4) = "Renk Dolgu" '-1 boş
oSheet.Cells(Counter, 5) = "origin.x"
oSheet.Cells(Counter, 6) = "origin.y"
oSheet.Cells(Counter, 7) = "Transparency"
oSheet.Cells(Counter, 8) = "Priority"
oSheet.Cells(Counter, 9) = "ID.Low"
oSheet.Cells(Counter, 10) = "ID.High"
oSheet.Cells(Counter, 11) = "Hesap Alanı"
oSheet.Cells(Counter, 15) = "ID"
oSheet.Cells(Counter, 16) = "Mahalle"
oSheet.Cells(Counter, 17) = "Ada"
oSheet.Cells(Counter, 18) = "Parsel"
oSheet.Cells(Counter, 19) = "Yüzölçümü"
oSheet.Cells(Counter, 20) = "Sahibi"
oSheet.Cells(Counter, 21) = "Açıklama"
oSheet.Cells(1, 36).FormulaR1C1 = "=COUNT(C[-31],1)"
Counter = oSheet.Cells(1, 36) + 1
Set oScanEnumerator = ActiveModelReference.GetSelectedElements
Dim shapeel As Element
Do While oScanEnumerator.MoveNext
Set oElement = oScanEnumerator.Current
'If oElement.IsShapeElement Or oElement.IsComplexShapeElement Then
With oElement
If IsGroupedHole(oElement) Or oElement.IsClosedElement Then
If IsGroupedHole(oElement) Then
alan = HoleArea(oElement.AsCellElement)
Set oDE = oElement
Set oEE = oDE.Drop
Set chElement = oElement
Do While oEE.MoveNext
With oEE.Current
If .IsClosedElement Then
If Not .AsClosedElement.IsHole Then
oSheet.Cells(Counter, 2) = .Level.name
Origin = GetOrigin(oEE.Current)
oSheet.Cells(Counter, 3) = .Color
oSheet.Cells(Counter, 4) = .AsClosedElement.FillColor
oSheet.Cells(Counter, 11) = alan
End If
End If
End With
Loop
End If
If .IsClosedElement Then
oSheet.Cells(Counter, 2) = oElement.Level.name
Origin = GetOrigin(oElement)
oSheet.Cells(Counter, 3) = .Color
oSheet.Cells(Counter, 4) = .AsClosedElement.FillColor
oSheet.Cells(Counter, 11) = Format(.AsClosedElement.area, "0.0000")
End If
parsel = ParselBilgiOku(oElement)
oSheet.Cells(Counter, 5) = Format(Origin.X, "0.00")
oSheet.Cells(Counter, 6) = Format(Origin.Y, "0.00")
oSheet.Cells(Counter, 7) = .Transparency
oSheet.Cells(Counter, 8) = .DisplayPriority
oSheet.Cells(Counter, 9) = .id.Low
oSheet.Cells(Counter, 10) = .id.High
oSheet.Cells(Counter, 15) = parsel.id
oSheet.Cells(Counter, 16) = parsel.mah
oSheet.Cells(Counter, 17) = parsel.Ada
oSheet.Cells(Counter, 18) = parsel.parsel
oSheet.Cells(Counter, 19) = parsel.Yuzolcumu
oSheet.Cells(Counter, 20) = parsel.Sahibi
oSheet.Cells(Counter, 21) = parsel.Aciklama
Counter = Counter + 1
oSheet.Cells(Counter, 1).Select
End If
End With
Loop
GoTo gec
hatavar:
Resume Next
gec:
End Sub
CExcelden butonuna kod ekleyelim
Private Sub CExcelden_Click()
Dim id As DLong
Dim i As Integer, lvlCount As Long
Dim elem As Element
Dim satir As Integer
Dim lev As Level
Dim satsay As Integer
Dim URLTextTitle, URLText As String
Dim ggroup As Long
Dim parsel As DBParsel
Counter = 0
Set oXL = GetObject(, "Excel.Application")
Set oSheet = oXL.activeWorkbook.activesheet
Counter = 2
Do While oSheet.Cells(Counter, 2) <> ""
oSheet.Cells(Counter, 2).Select
id.Low = oSheet.Cells(Counter, 9)
id.High = oSheet.Cells(Counter, 10)
Set elem = ActiveModelReference.GetElementByID(id)
elem.Level = besuLevel(oSheet.Cells(Counter, 2))
If elem.IsClosedElement Then
elem.AsClosedElement.FillMode = msdFillModeOutlined
elem.Color = oSheet.Cells(Counter, 3)
elem.AsClosedElement.FillColor = oSheet.Cells(Counter, 4)
If oSheet.Cells(Counter, 4) < 0 Then
elem.AsClosedElement.FillColor = 0
elem.AsClosedElement.FillMode = msdFillModeNotFilled
End If
End If
elem.Transparency = oSheet.Cells(Counter, 7) / 100
elem.DisplayPriority = oSheet.Cells(Counter, 8)
parsel.id = oSheet.Cells(Counter, 15)
parsel.mah = oSheet.Cells(Counter, 16)
parsel.Ada = oSheet.Cells(Counter, 17)
parsel.parsel = oSheet.Cells(Counter, 18)
parsel.Yuzolcumu = oSheet.Cells(Counter, 19)
parsel.Sahibi = oSheet.Cells(Counter, 20)
parsel.Aciklama = oSheet.Cells(Counter, 21)
Call ParselBilgiYaz(elem, parsel)
elem.Rewrite
Counter = Counter + 1
Loop
End Sub
Yeşil sütunlar excelde değiştirilip geüncelleme yapılabilir.
