---

Hasan Basri KARA Harita Mühendisi Akıllı Şehircilik ve İnovasyon Dairesi Başkanlığı Akıllı Şehircilik Şube Müdürlüğü İletişim: 0224-444 16 00-1871

Outlook İmza Dosyaları

İmza dosyaları nerede bulunur?

C:\Users\%USERNAME%\AppData\Roaming\Microsoft\Signatures

Otomasyon İzleme

Lütfen Giriş Yapınız...

KESİM 2020

Otomasyon 2020

Lütfen Giriş Yapınız...

KESİM 2020

KESİM

2020

DKTY

Kontrol

Liste

Dijitsu Belgeler

DIJITSU Güncelleme dosyaları (drive)

Look for some code review here. Will entertain suggestions, looking for best practice because in future looking to build J2EE application with REST interfaces that will use JSON and was planning to use Excel VBA as a debugging front end tool. Thanks.

'Tools->References->
'Microsoft Scripting Runtime
'Microsoft Script Control 1.0;  {0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}; C:\Windows\SysWOW64\msscript.ocx
'Microsoft Xml, v6.0

Option Explicit
Option Private Module
Private Const sKEYNAME As String = "Server key 1"
'Public Const sKEY As String = "Your key goes here and uncomment"
Private Const sSEVENOAKS_PLACEID As String = "ChIJwd9bXUyt2EcRYv6GY0JRnCw"   'Place ID: ChIJwd9bXUyt2EcRYv6GY0JRnCw Sevenoaks , Sevenoaks, Kent, UK
Private Const sSEVENOAKS_LATITUDE_LONGITUDE As String = "51.2724,0.1909"    '51.2724° N, 0.1909° E

Private Function GetScriptEngine() As ScriptControl
    Static soScriptEngine As ScriptControl
    If soScriptEngine Is Nothing Then
        Set soScriptEngine = New ScriptControl
        soScriptEngine.Language = "JScript"
        soScriptEngine.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soScriptEngine.AddCode "function getKeyValues(jsonObj) { " & _
                              " var dictionary = new ActiveXObject(""Scripting.Dictionary""); " & _
                              " var keys = new Array(); for (var i in jsonObj) { dictionary.add(i,jsonObj[i]); }; return dictionary; } "
        soScriptEngine.AddCode "function setKeyValue(jsonObj, key, newItem) { jsonObj[key]=newItem; return jsonObj; }"
        soScriptEngine.AddCode "function toVBString(jsonObj) { return JSON.stringify(jsonObj); }"
        soScriptEngine.AddCode "function overrideToString(jsonObj) { jsonObj.toString = function() { return JSON.stringify(this); } }"
    End If
    Set GetScriptEngine = soScriptEngine
End Function

Private Function GetJavaScriptLibrary(ByVal sURL As String) As String
    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibrary = xHTTPRequest.responseText
End Function

Private Function DecodeJsonString(ByVal JsonString As String) As Object
    Dim oScriptEngine As ScriptControl
    Set oScriptEngine = GetScriptEngine

    Set DecodeJsonString = oScriptEngine.Eval("(" + JsonString + ")")

    Call oScriptEngine.Run("overrideToString", DecodeJsonString) '* this gives JSON rendering instead of "[object Object]"

End Function

Private Function GetJSONPrimitive(ByVal obj As Object, ByVal sKey As String, Optional vDefaultValue As Variant) As Variant
    Dim vRet As Variant

    If obj.hasOwnProperty(sKey) Then
        vRet = VBA.CallByName(obj, sKey, VbGet)
    Else
        vRet = vDefaultValue
    End If
    GetJSONPrimitive = vRet
End Function


Private Function GetJSONObject(ByVal obj As Object, ByVal sKey As String) As Object
    Dim objReturn As Object
    If obj.hasOwnProperty(sKey) Then

        Set objReturn = VBA.CallByName(obj, sKey, VbGet)
        Call GetScriptEngine.Run("overrideToString", objReturn) '* this gives JSON rendering instead of "[object Object]"

    End If
    Set GetJSONObject = objReturn
End Function

Private Function TestAll() As Boolean
    Debug.Assert TestPlaceDetails
    Debug.Assert TestNearbySearch
    Debug.Assert TestAutoComplete
    Debug.Assert BigTest
    Debug.Assert EvenBiggerTest
    Debug.Assert TestTextSearch 'biggest of all
    TestAll = True
End Function


Private Function BigTest() As Boolean

    Dim dicPlacesWithPlaceIds As Scripting.Dictionary
    Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")

    ReDim v(1 To dicPlacesWithPlaceIds.Count + 1, 1 To 2)
    v(1, 1) = "Place": v(1, 2) = "Lat, Long"
    Dim lLoop As Long
    For lLoop = 1 To dicPlacesWithPlaceIds.Count

        Dim sPlace As String
        sPlace = dicPlacesWithPlaceIds.Keys()(lLoop - 1)

        Dim sPlaceID As String
        sPlaceID = dicPlacesWithPlaceIds.Items()(lLoop - 1)

        Dim dicPlaceDetails As Scripting.Dictionary
        Set dicPlaceDetails = PlaceDetails(sKey, sPlaceID)

        v(lLoop + 1, 1) = sPlace
        v(lLoop + 1, 2) = dicPlaceDetails.Items()(0)

    Next

    'Stop
    ActiveSheet.Cells(1, 1).CurrentRegion.Clear
    ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicPlacesWithPlaceIds.Count + 1, 2)).Value2 = v
    BigTest = True
End Function



Private Function EvenBiggerTest() As Boolean

    Dim dicPlacesWithPlaceIds As Scripting.Dictionary
    Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Hamburg")

    If dicPlacesWithPlaceIds.Count > 0 Then

        Dim sTopPrediction As String
        sTopPrediction = dicPlacesWithPlaceIds.Keys()(0)

        Dim sTopPredictionPlaceId As String
        sTopPredictionPlaceId = dicPlacesWithPlaceIds.Items()(0)

        Dim dicPlaceDetails As Scripting.Dictionary
        Set dicPlaceDetails = PlaceDetails(sKey, sTopPredictionPlaceId)

        Dim sTopPredictionLocation As String
        sTopPredictionLocation = dicPlaceDetails.Item("Location")

        Dim dicNearbySearchResults As Scripting.Dictionary
        Set dicNearbySearchResults = NearbySearch(sKey, sTopPredictionLocation, 100, "post office")

        ReDim v(1 To dicNearbySearchResults.Count + 1, 1 To 5)
        v(1, 1) = "Name": v(1, 2) = "PlaceId": v(1, 3) = "Address": v(1, 4) = "Vicinity": v(1, 5) = "Type0"

        Dim lLoop As Long
        For lLoop = 1 To dicNearbySearchResults.Count

            Dim sPlaceIdLoop As String
            sPlaceIdLoop = dicNearbySearchResults.Items()(lLoop - 1)

            Set dicPlaceDetails = PlaceDetails(sKey, sPlaceIdLoop)

            v(lLoop + 1, 1) = dicNearbySearchResults.Keys()(lLoop - 1)
            v(lLoop + 1, 2) = sPlaceIdLoop
            v(lLoop + 1, 3) = dicPlaceDetails.Item("Address")
            If dicPlaceDetails.Exists("Vicinity") Then
                v(lLoop + 1, 4) = dicPlaceDetails.Item("Vicinity")
            End If
            If dicPlaceDetails.Exists("Type0") Then
                v(lLoop + 1, 5) = dicPlaceDetails.Item("Type0")
            End If

        Next

        'Stop
        ActiveSheet.Cells(1, 1).CurrentRegion.Clear
        ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicNearbySearchResults.Count + 1, 5)).Value2 = v
    End If
    EvenBiggerTest = True
End Function


Private Function TextSearch(ByVal sAPIKey As String, ByVal sSearchQuery As String, ByRef pdicFieldOrinals As Scripting.Dictionary) As Scripting.Dictionary

    '
    'Tools->References->
    'Microsoft Scripting Runtime
    Dim dicTextSearchResults As Scripting.Dictionary
    Set dicTextSearchResults = New Scripting.Dictionary

    Set pdicFieldOrinals = New Scripting.Dictionary

    Dim psNextPageToken As String: psNextPageToken = ""


    Do
        If psNextPageToken <> "" Then
            Application.Wait (Now() + CDate("00:00:05"))
        End If

        Dim xHTTPRequest As MSXML2.XMLHTTP60
        Set xHTTPRequest = New MSXML2.XMLHTTP60

        Dim sURL As String
        sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?key=" & sAPIKey & "&query=" & sSearchQuery

        If psNextPageToken <> "" Then sURL = sURL & "&pagetoken=" & psNextPageToken


        xHTTPRequest.Open "GET", sURL

        xHTTPRequest.send

        While xHTTPRequest.readyState <> 4
            DoEvents
        Wend

        If Len(xHTTPRequest.responseText) > 0 Then
            'Debug.Print Left$(xHTTPRequest.responseText, 500)

            Dim objJSON As Object
            Set objJSON = DecodeJsonString(xHTTPRequest.responseText)

            ParseTextSearchResponse objJSON, dicTextSearchResults, pdicFieldOrinals, psNextPageToken
        End If
    Loop Until psNextPageToken = ""
    Set TextSearch = dicTextSearchResults

End Function

Private Function TestTextSearch() As Boolean
    ActiveSheet.Cells(1, 1).CurrentRegion.Clear

    Dim pdicFieldOrinals As Scripting.Dictionary

    Dim dicTextSearchResults As Scripting.Dictionary
    Set dicTextSearchResults = TextSearch(sKey, "london+restaurants", pdicFieldOrinals)

    Dim dicDetails As Scripting.Dictionary
    Set dicDetails = dicTextSearchResults.Item(dicTextSearchResults.Keys()(0))


    Dim vGrid As Variant
    vGrid = NestedDictionaryToGrid(dicTextSearchResults, pdicFieldOrinals)

    ActiveSheet.Cells(1, 1).CurrentRegion.Clear
    ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(dicTextSearchResults.Count + 1, pdicFieldOrinals.Count)).Value2 = vGrid
    TestTextSearch = True
End Function


Private Function ParseTextSearchResponse(ByVal objJSON As Object, _
                ByVal dicTextSearchResults As Scripting.Dictionary, ByVal dicFieldOrinals As Scripting.Dictionary, _
                ByRef psPageToken As String)

    If Not objJSON Is Nothing Then

        psPageToken = GetJSONPrimitive(objJSON, "next_page_token", "")

        Dim sStatus As String
        sStatus = GetJSONPrimitive(objJSON, "status")

        If sStatus = "OK" Then

            Dim objResults As Object
            Set objResults = GetJSONObject(objJSON, "results")

            Dim lLength As Long
            lLength = GetJSONPrimitive(objResults, "length", -1)


            Dim lLoop As Long
            For lLoop = 0 To lLength - 1

                Dim objResultLoop As Object
                Set objResultLoop = GetJSONObject(objResults, CStr(lLoop))

                Dim sName As String
                sName = GetJSONPrimitive(objResultLoop, "name")

                Dim dicKeys As Scripting.Dictionary
                Set dicKeys = GetScriptEngine.Run("getKeyValues", objResultLoop)

                Dim dicFlattenedDetails As Scripting.Dictionary
                Set dicFlattenedDetails = New Scripting.Dictionary

                Dim vKeyLoop As Variant
                For Each vKeyLoop In dicKeys.Keys

                    If Not dicFieldOrinals.Exists(vKeyLoop) Then dicFieldOrinals.Add vKeyLoop, dicFieldOrinals.Count

                    Dim vValue As Variant: vValue = Empty

                    Select Case vKeyLoop
                    Case "formatted_address", "icon", "id", "name", "permanently_closed", "place_id", "price_level", "rating", "reference":
                        vValue = VBA.CallByName(objResultLoop, vKeyLoop, VbGet)
                        dicFlattenedDetails.Add vKeyLoop, vValue
                    Case "geometry":
                        dicFlattenedDetails.Add "geometry", ExtractLatitudeAndLongitude(GetJSONObject(objResultLoop, "geometry"))
                    Case "opening_hours":
                        dicFlattenedDetails.Add "opening_hours", ExtractOpeningHours(GetJSONObject(objResultLoop, "opening_hours"))
                    Case "types":
                        dicFlattenedDetails.Add "types", ExtractTypes(GetJSONObject(objResultLoop, "types"))
                    Case "photos":
                        '* NOT YET IMPLEMENTED
                    Case Else
                        Stop
                    End Select

                Next vKeyLoop

                Dim sPlaceID As String
                sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)

                dicTextSearchResults.Add sPlaceID, dicFlattenedDetails

            Next
        End If
    End If



End Function

Private Function ExtractOpeningHours(ByVal objOpeningHours As Object) As String

    Dim vOpenNow As Variant
    vOpenNow = VBA.CallByName(objOpeningHours, "open_now", VbGet)

    Dim bOpenNow As Boolean
    bOpenNow = CBool(vOpenNow)

    Dim objWeekdayText As Object
    Set objWeekdayText = GetJSONObject(objOpeningHours, "weekday_text")

    Dim lLength As Long
    lLength = VBA.CallByName(objWeekdayText, "length", VbGet)

    If lLength > 0 Then

        Dim dicWeekdaysKeys As Scripting.Dictionary
        Set dicWeekdaysKeys = GetScriptEngine.Run("getKeyValues", objWeekdayText)

        Stop
    End If

    ExtractOpeningHours = VBA.IIf(bOpenNow, "open", "closed")

End Function

Private Function ExtractTypes(ByVal objTypes As Object) As String

    Dim lLength As Long
    lLength = VBA.CallByName(objTypes, "length", VbGet)

    Dim dicTypes As Scripting.Dictionary
    Set dicTypes = New Scripting.Dictionary

    Dim lLoop As Long
    For lLoop = 0 To lLength - 1
        Dim sTypeLoop As String
        sTypeLoop = VBA.CallByName(objTypes, CStr(lLoop), VbGet)
        dicTypes.Add sTypeLoop, 0

    Next lLoop

    ExtractTypes = VBA.Join(dicTypes.Keys, "|")

End Function



Private Function TestNearbySearch() As Boolean

    Dim dicNearbySearchResults As Scripting.Dictionary
    Set dicNearbySearchResults = NearbySearch(sKey, sSEVENOAKS_LATITUDE_LONGITUDE, 500, "restaurant")

    Debug.Assert dicNearbySearchResults.Exists("Subway")
    Debug.Assert dicNearbySearchResults.Item("Subway") = "ChIJ_yoN0_tN30cRnjjjqftbnSw"

    TestNearbySearch = True

End Function


Public Function NearbySearch(ByVal sAPIKey As String, ByVal sLocationLatitudeLongitude As String, ByVal lRadius As Long, _
            ByVal sSearchType As String)

    '
    'Tools->References->
    'Microsoft Scripting Runtime
    Dim dicNearbySearchResults As Scripting.Dictionary
    Set dicNearbySearchResults = New Scripting.Dictionary


    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60

    xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/nearbysearch/json?key=" & sAPIKey & "&location=" & sLocationLatitudeLongitude & "&radius=" & lRadius & "&type=" & sSearchType

    xHTTPRequest.send

    While xHTTPRequest.readyState <> 4
        DoEvents
    Wend

    If Len(xHTTPRequest.responseText) > 0 Then

        Dim objJSON As Object
        Set objJSON = DecodeJsonString(xHTTPRequest.responseText)

        If Not objJSON Is Nothing Then

            Dim sStatus As String
            sStatus = GetJSONPrimitive(objJSON, "status")

            If sStatus = "OK" Then

                Dim objResults As Object
                Set objResults = GetJSONObject(objJSON, "results")

                Dim lLength As Long
                lLength = VBA.CallByName(objResults, "length", VbGet)

                Dim lLoop As Long
                For lLoop = 0 To lLength - 1

                    Dim objResultLoop As Object
                    Set objResultLoop = GetJSONObject(objResults, CStr(lLoop))

                    Dim sName As String
                    sName = VBA.CallByName(objResultLoop, "name", VbGet)

                    Dim sPlaceID As String
                    sPlaceID = VBA.CallByName(objResultLoop, "place_id", VbGet)

                    dicNearbySearchResults.Add sName, sPlaceID

                Next
            End If
        End If
    End If
    Set NearbySearch = dicNearbySearchResults

End Function



Private Function ExtractLatitudeAndLongitude(ByVal objGeometry As Object) As String

    Dim objLocation As Object
    Set objLocation = GetJSONObject(objGeometry, "location")

    Dim sLatitude As String
    sLatitude = VBA.CallByName(objLocation, "lat", VbGet)

    Dim sLongitude As String
    sLongitude = VBA.CallByName(objLocation, "lng", VbGet)

    ExtractLatitudeAndLongitude = sLatitude & "," & sLongitude

End Function


Private Function TestPlaceDetails() As Boolean

    Dim dicPlaceDetails As Scripting.Dictionary
    Set dicPlaceDetails = PlaceDetails(sKey, sSEVENOAKS_PLACEID)

    Debug.Assert dicPlaceDetails.Keys()(0) = "Location"
    Debug.Assert dicPlaceDetails.Items()(0) = "51.27241,0.190898"
    TestPlaceDetails = True
End Function


Public Function PlaceDetails(ByVal sAPIKey As String, ByVal sPlaceID As String) As Scripting.Dictionary

    'Tools->References->
    'Microsoft Scripting Runtime
    Dim dicPlaceDetails As Scripting.Dictionary
    Set dicPlaceDetails = New Scripting.Dictionary


    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60


    xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/details/json?key=" & sAPIKey & "&placeid=" & sPlaceID

    xHTTPRequest.send

    While xHTTPRequest.readyState <> 4
        DoEvents
    Wend

    If Len(xHTTPRequest.responseText) > 0 Then

        Dim objJSON As Object
        Set objJSON = DecodeJsonString(xHTTPRequest.responseText)

        If Not objJSON Is Nothing Then


            Dim objResult As Object
            Set objResult = GetJSONObject(objJSON, "result")
            If Not objResult Is Nothing Then
            'If objJSON.hasOwnProperty("result") Then


                Dim objGeometry As Object
                Set objGeometry = GetJSONObject(objResult, "geometry")
                If Not objResult Is Nothing Then

                    Dim objLocation As Object
                    Set objLocation = GetJSONObject(objGeometry, "location")
                    If Not objLocation Is Nothing Then

                        Dim sLatitude As String
                        sLatitude = VBA.CallByName(objLocation, "lat", VbGet)

                        Dim sLongitude As String
                        sLongitude = VBA.CallByName(objLocation, "lng", VbGet)

                        dicPlaceDetails.Add "Location", sLatitude & "," & sLongitude
                    End If

                    dicPlaceDetails.Add "Address", VBA.CallByName(objResult, "formatted_address", VbGet)

                    dicPlaceDetails.Add "Name", VBA.CallByName(objResult, "name", VbGet)

                    If objResult.hasOwnProperty("vicinity") Then
                        dicPlaceDetails.Add "Vicinity", VBA.CallByName(objResult, "vicinity", VbGet)
                    End If

                    Dim objTypes As Object
                    Set objTypes = GetJSONObject(objResult, "types")
                    If Not objTypes Is Nothing Then

                        Dim lTypesLength As Long
                        lTypesLength = VBA.CallByName(objTypes, "length", VbGet)

                        Dim sType0 As String
                        sType0 = VBA.CallByName(objTypes, "0", VbGet)
                        dicPlaceDetails.Add "Type0", sType0
                    End If

                    dicPlaceDetails.Add "PlaceId", sPlaceID

                End If
            End If
        End If
    End If
    Set PlaceDetails = dicPlaceDetails
End Function


Private Function TestAutoComplete() As Boolean

   Dim dicPlacesWithPlaceIds As Scripting.Dictionary
   Set dicPlacesWithPlaceIds = AutoComplete(sKey, "Sevenoaks")

   Debug.Assert dicPlacesWithPlaceIds.Keys()(0) = "Sevenoaks, United Kingdom"
   Debug.Assert dicPlacesWithPlaceIds.Items()(0) = sSEVENOAKS_PLACEID
   TestAutoComplete = True
End Function



Public Function AutoComplete(ByVal sAPIKey As String, ByVal sPlaceText As String) As Scripting.Dictionary

    'Tools->References->
    'Microsoft Scripting Runtime
    Dim dicPlacesWithPlaceIds As Scripting.Dictionary
    Set dicPlacesWithPlaceIds = New Scripting.Dictionary


    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60


    xHTTPRequest.Open "GET", "https://maps.googleapis.com/maps/api/place/autocomplete/json?key=" & sAPIKey & "&input=" & sPlaceText & "&sensor=false", False

    xHTTPRequest.send

    While xHTTPRequest.readyState <> 4
        DoEvents
    Wend

    If Len(xHTTPRequest.responseText) > 0 Then


        Dim objJSON As Object
        Set objJSON = DecodeJsonString(xHTTPRequest.responseText)

        If Not objJSON Is Nothing Then

            Dim objPredictions As Object
            Set objPredictions = GetJSONObject(objJSON, "predictions")
            If Not objPredictions Is Nothing Then

                Dim lLength As Long
                lLength = VBA.CallByName(objPredictions, "length", VbGet)

                Dim lLoop As Long
                For lLoop = 0 To lLength - 1

                    Dim objPredictionLoop As Object
                    Set objPredictionLoop = GetJSONObject(objPredictions, CStr(lLoop))

                    Dim sPlaceDescription As String
                    sPlaceDescription = VBA.CallByName(objPredictionLoop, "description", VbGet)

                    Dim sPlaceID As String
                    sPlaceID = VBA.CallByName(objPredictionLoop, "place_id", VbGet)

                    dicPlacesWithPlaceIds.Add sPlaceDescription, sPlaceID
                    'Stop
                Next
                'Stop
            End If

        End If

        'Stop

    End If
    Set AutoComplete = dicPlacesWithPlaceIds
    'Debug.Print xHTTPRequest.responseText


End Function

Private Function NestedDictionaryToGrid(ByVal dicData As Scripting.Dictionary, ByVal dicFieldOrdinals As Scripting.Dictionary) As Variant

    ReDim vRet(1 To dicData.Count + 1, 1 To dicFieldOrdinals.Count)


    Dim vFieldKeyLoop As Variant
    For Each vFieldKeyLoop In dicFieldOrdinals.Keys
        vRet(1, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = vFieldKeyLoop
    Next

    Dim lRowLoop As Long: lRowLoop = 1

    Dim vDataKeyLoop As Variant
    For Each vDataKeyLoop In dicData.Keys
        lRowLoop = lRowLoop + 1

        Dim dicDetails As Scripting.Dictionary
        Set dicDetails = dicData.Item(vDataKeyLoop)

        For Each vFieldKeyLoop In dicFieldOrdinals.Keys
            vRet(lRowLoop, dicFieldOrdinals.Item(vFieldKeyLoop) + 1) = dicDetails.Item(vFieldKeyLoop)
        Next


    Next vDataKeyLoop


    NestedDictionaryToGrid = vRet

End Function

vba json excel google-maps

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.