Microstation Mvba TextBorder

Type txtBorder
  gg As Long
  lineWeight As Integer
  color As Long
  level As String
End Type


Public tBorder As txtBorder

' ===============================================================================
Sub textBorder()
  Dim sScanEnumerator As ElementEnumerator
  Dim sElement As element
  Dim gg As Long
  Dim sFence As Fence
  tBorder.lineWeight = 4
  tBorder.color = 16
  tBorder.level = "Border"
  Set sFence = ActiveDesignFile.Fence
  If ActiveModelReference.AnyElementsSelected Or sFence.IsDefined Then
     If ActiveModelReference.AnyElementsSelected Then
        Set sScanEnumerator = ActiveModelReference.GetSelectedElements
     Else
        Set sScanEnumerator = sFence.GetContents
     End If
     ActiveModelReference.UnselectAllElements
     Do While sScanEnumerator.MoveNext
        Set sElement = sScanEnumerator.Current
        If sElement.Type = msdElementTypeText Or sElement.Type = msdElementTypeTextNode Then
           besuTextBorder sElement, tBorder
        End If
     Loop
  Else
     CommandState.StartLocate New classTextBorder
  End If
End Sub

Function besuTextBorder(sElement As element, tBorder As txtBorder)
   gg = UpdateGraphicGroupNumber 'CurrentGraphicGroup
   tBorder.gg = gg
    If sElement.Type = msdElementTypeTextNode Then
       dropElemTN sElement, tBorder
    End If
    If sElement.Type = msdElementTypeText Then
       dropElemT sElement, tBorder
    End If
    sElement.GraphicGroup = tBorder.gg
    sElement.Rewrite
End Function

' ===============================================================================
Function dropElemTN(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            If oEE.Current.Type = msdElementTypeText Then
               dropElemT oEE.Current, tBorder.gg
            End If
        Loop
    End If
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function dropElemT(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oNew As element
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            Set oNew = oEE.Current
            ActiveModelReference.AddElement oNew
            oNew.lineWeight = tBorder.lineWeight
            oNew.color = tBorder.color
            oNew.GraphicGroup = tBorder.gg
            oNew.level = besuLevel(tBorder.level & "_" & oEle.level.Name)
            oNew.Rewrite
            If oNew.IsClosedElement Then
               oNew.AsClosedElement.FillMode = msdFillModeNotFilled
               oNew.Rewrite
            End If
            If oNew.IsCellElement Then
               CellElem oNew.AsCellElement
            End If
        Loop
    End If

    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function CellElem(cEle As CellElement)
  Dim cComponents As ElementEnumerator
  On Error GoTo NoElement
  Set cComponents = cEle.GetSubElements
  Do While cComponents.MoveNext
    Dim cComponent As element
    Set cComponent = cComponents.Current
    If cComponent.IsClosedElement Then
       cComponent.AsClosedElement.FillMode = msdFillModeNotFilled
       cComponent.Rewrite
    End If
  Loop
  'cEle.Rewrite
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function






' ===============================================================================
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
   Set besuLevel = ActiveDesignFile.Levels.Find(levname)
End Function

class modülüne de alttaki kodlar yazılır. class modülünün ismi önemli

classTextBorder

Option Explicit
Implements ILocateCommandEvents

' ===============================================================================
' DATAPOINT HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Accept(ByVal element As element, point As Point3d, ByVal View As View)
    besuTextBorder element, tBorder
'    CommandState.StartPrimitive New classDrawValve
End Sub

' ===============================================================================
' CLEANUP HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Cleanup()

End Sub

' ===============================================================================
' DYNAMICS HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Dynamics(point As Point3d, _
    ByVal View As View, ByVal DrawMode As MsdDrawingMode)
End Sub

' ===============================================================================
' LOCATE FAILED HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFailed()
    CommandState.StartLocate New classTextBorder
End Sub

' ===============================================================================
' LOCATE FILTER - lines only
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
    point As Point3d, Accepted As Boolean)
    Accepted = False
    If (element.IsTextElement) Or (element.IsTextNodeElement) Then
            Accepted = True
    End If
End Sub

' ===============================================================================
' RESET HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateReset()
    CommandState.StartLocate New classTextBorder
'    CommandState.StartDefaultCommand
End Sub

' ===============================================================================
' LOCATE INITIALIZATION
' ===============================================================================
Private Sub ILocateCommandEvents_Start()
    Dim lc As LocateCriteria
    Set lc = CommandState.CreateLocateCriteria(False)
    CommandState.SetLocateCriteria lc
    CommandState.EnableAccuSnap
    ShowCommand "Place Component"
    ShowPrompt "Select Text or TextNode"
End Sub

kodları kod projemize ekledikten sonra
 vba run textBorder 

ile programı çalıştırıyoruz.

Microstation Vba Seçili elementleri cell oluşturma

Option Explicit

Function xy(x As Double, y As Double) As Point3d
    xy = Point3dFromXY(x, y)
End Function

Sub CreateOrphanCell()
    Dim eleCell As CellElement
    Dim vertices(0 To 3) As Point3d
    Dim ele(0 To 2) As Element
   
    Set ele(0) = CreateLineElement2(Nothing, xy(0, 5), xy(10, 5))
   
    vertices(0) = xy(0, 0)
    vertices(1) = xy(0, 7)
    vertices(2) = xy(10, 7)
    vertices(3) = xy(10, 0)
    Set ele(1) = CreateShapeElement1(Nothing, vertices, msdFillModeUseActive)
   
    Set ele(2) = CreateTextElement1(Nothing, "My Orphan Cell", xy(5, 6), Matrix3dIdentity)
   
    Set eleCell = CreateCellElement1(vbNullString, ele, xy(0, 0), False)
    eleCell.name = "OrphanCell"
    ActiveModelReference.AddElement eleCell
       
    eleCell.Redraw
End Sub

Sub secilileriCellYap()
  Dim ele() As Element
  Dim gElement As Element
  Dim eleCell As CellElement
  Dim oScanCriteria As ElementScanCriteria
  Dim oScanEnumerator As ElementEnumerator
  Dim eSay As Integer
  Dim aTags() As TagElement
  Dim tagIndex As Long
  If ActiveModelReference.AnyElementsSelected Then
     Set oScanEnumerator = ActiveModelReference.GetSelectedElements
  Else
     Dim sFence As Fence
     Set sFence = ActiveDesignFile.Fence
     If sFence.IsDefined Then Set oScanEnumerator = sFence.GetContents
  End If
  '     Set tElement = gElement.AsTextElement
  '     ActiveModelReference.AddElement tElement
  eSay = -1
  Do While oScanEnumerator.MoveNext
     Set gElement = oScanEnumerator.Current
     If gElement.IsGraphical Then
        eSay = eSay + 1
        ReDim Preserve ele(eSay)
        Set ele(eSay) = gElement
        aTags = gElement.GetTags
        For tagIndex = LBound(aTags) To UBound(aTags)
           Dim sourceTag As TagElement
           eSay = eSay + 1
           ReDim Preserve ele(eSay)
           Set sourceTag = aTags(tagIndex)
           Set ele(eSay) = sourceTag
           'ActiveDesignFile.Models(att).CopyElement sourceTag, oCC
        Next tagIndex
     End If
'     ActiveModelReference.RemoveElement gElement
   
  Loop
  Set eleCell = CreateCellElement1(vbNullString, ele, xy(0, 0), False)
  eleCell.name = "OrphanCell"
  ActiveModelReference.AddElement eleCell

End Sub

Microstation VBA Element ekleme

Sub YaziYaz()
Dim ele As Element
Dim nokta As Point3d
nokta.x = 0
nokta.y = 0
Set ele = besuYazi("Deneme", "sil", nokta, 0, 3, 2, 2, 8, True)
Set ele = besuNokta(nokta, "nokta", 3, 1, True)
End Sub

Function besuYazi(yazi As String, lev As String, origin As Point3d, aci As Double, renk As Integer, yuk As Double, gen As Double, jst As Integer, ekle As Boolean) As Element
    Dim tAci As Matrix3d
    tAci = Matrix3dFromAxisAndRotationAngle(2, aci)
    Dim j As Integer
    Set besuYazi = CreateTextElement1(Nothing, yazi, origin, tAci)
    besuYazi.level = besuLevel(lev)
    besuYazi.AsTextElement.TextStyle.Height = yuk
    besuYazi.AsTextElement.TextStyle.Width = gen
    besuYazi.Color = renk
    besuYazi.LineStyle = ByLevelLineStyle
    besuYazi.LineWeight = ByLevelLineWeight
   
    Set oFont = ActiveDesignFile.Fonts.Find(msdFontTypeWindowsTrueType, "Arial")
    Set besuYazi.AsTextElement.TextStyle.Font = oFont
   
    ' oNewElement.Color = 5
    besuYazi.AsTextElement.TextStyle.Justification = jst
    If ekle Then
       ActiveModelReference.AddElement besuYazi
    End If
    besuYazi.Redraw
End Function

Function besuNokta(origin As Point3d, lev As String, renk As Integer, kln As Integer, ekle As Boolean) As Element

    Set besuNokta = CreateLineElement2(Nothing, origin, origin)

    besuNokta.level = besuLevel(lev)

    besuNokta.Color = renk

    besuNokta.LineWeight = kln

    If ekle Then

       ActiveModelReference.AddElement besuNokta

    End If

    besuNokta.Redraw

End Function

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

Microstation Vba Form ile Data Blok kullanımı verilerin Excele yazdırılması

FormDBlock kodları

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

Data_Block.mvba

Parsellerin Excele yazdırılması

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.