Ölçü aralıklarını eşitleyen AutoCAD VBA kodu

 AutoCAD çizimlerinde ölçülendirme yapılırken ölçü çizgisi ile ana çizgisi arasındaki mesafe eşit olmadığında hoş olmayan bir ölçülendirme çizimi ortaya çıkar. Resimde görüldüğü gibi soldaki gibi düzensiz yapılan ölçülendirme sağdaki gibi olması gerekir.

AutoCAD ayarlarında ya da komutlarında bu mesafeyi eşit yapacak bir seçenek yok. O yüzden benim de ihtiyacım olan bu özelliği sağlamak için AutoCAD VBA kodu yazdım.

1. kod çalıştığında ölçü aralığı belirtiliyor ve ölçü nesneleri tek tek seçilerek ölçü aralıkları verilen ölçü aralığı ile eşitleniyor. LINEAR ve ALIGNED ölçüler kabul ediliyor.

' Mesut Akcan
' makcan@gmail.com
' https://mesutakcan.blogspot.com
' https://www.youtube.com/mesutakcan
' 30/12/2021

Option Explicit
Const X = 0, Y = 1, Z = 2

Sub olcuAralikEsitle_1()
' 30/12/2021
Dim olcu As AcadEntity
Dim yk As Variant, yeniYK As Variant 'yazı konumu
Dim n1 As Variant, n2 As Variant, p2 As Variant
Dim bn As Variant 'baz nokta
Dim aralik As Double, fark As Double

On Error Resume Next
aralik = ThisDrawing.Utility.GetDistance(, "Ölçü çizgisi aralığı:")
If Err Then Exit Sub
Do
    ThisDrawing.Utility.GetEntity olcu, bn, "Ölçü seçiniz:"
    If Err Then Exit Do
    If TypeOf olcu Is AcadDimAligned Or TypeOf olcu Is AcadDimRotated Then
        p2 = DxfDegerAl(olcu, 10) 'ölçü noktası
        n1 = DxfDegerAl(olcu, 13) 'çizgi 1. nokta
        n2 = DxfDegerAl(olcu, 14) 'çizgi 2. nokta
        yk = olcu.TextPosition 'ölçü yazı konumu
        
        '---- YATAY ÖLÇÜ ----
        If p2(X) = n2(X) Then
            If n2(Y) > p2(Y) Then ' -- ALT --
                If n1(Y) <= n2(Y) Then n2(Y) = n1(Y) Else n1(Y) = n2(Y)
            Else                  ' -- ÜST --
                If n1(Y) >= n2(Y) Then n2(Y) = n1(Y) Else n1(Y) = n2(Y)
            End If
            fark = n1(Y) - yk(Y) 'Y farkı
            yeniYK = n1 'yeni yazı konumu
            yeniYK(Y) = n1(Y) - Sgn(fark) * aralik
            yeniYK(X) = yk(X)
            olcu.TextPosition = yeniYK
        
        '---- DİKEY ÖLÇÜ ----
        Else
            If n2(X) > p2(X) Then ' -- SOL --
                If n1(X) <= n2(X) Then n2(X) = n1(X) Else n1(X) = n2(X)
            Else                  ' -- SAĞ --
                If n1(X) >= n2(X) Then n2(X) = n1(X) Else n1(X) = n2(X)
            End If
            fark = n1(X) - yk(X) 'X farkı
            yeniYK = n1 'yeni yazı konumu
            yeniYK(X) = n1(X) - Sgn(fark) * aralik
            yeniYK(Y) = yk(Y)
            olcu.TextPosition = yeniYK
        End If
    End If
Loop
End Sub

Public Function DxfDegerAl(pAcadObj, pDXFCode As Integer) As Variant
Dim VLisp As Object, VLispFunc As Object
Dim nesne As Object, strHnd As String
Dim dxfKonum As Variant, konum(2) As Double
Dim b1 As Byte, b2 As Byte 'boşluk konumu

On Error GoTo hataDxfDegerAl
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Set VLispFunc = VLisp.ActiveDocument.Functions
strHnd = pAcadObj.Handle
    
With VLispFunc
    Set nesne = .Item("read").Funcall("pDXF")
    dxfKonum = .Item("set").Funcall(nesne, pDXFCode)
    Set nesne = .Item("read").Funcall("pHandle")
    dxfKonum = .Item("set").Funcall(nesne, strHnd)
    Set nesne = .Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
    dxfKonum = .Item("eval").Funcall(nesne)
    
    b1 = InStr(2, dxfKonum, " ", vbTextCompare) '1. boşluk konumu
    b2 = InStr(b1 + 1, dxfKonum, " ", vbTextCompare) '2. boşluk konumu
    konum(X) = Val(Mid(dxfKonum, 2, b1 - 1)) 'X değeri
    konum(Y) = Val(Mid(dxfKonum, b1 + 1, b2 - (b1 + 1))) 'Y değeri
    konum(Z) = Val(Mid(dxfKonum, b2 + 1, Len(dxfKonum) - (b2 + 1))) 'Z değeri
    
    DxfDegerAl = konum
    
    Set nesne = .Item("read").Funcall("(setq pDXF nil)")
    dxfKonum = .Item("eval").Funcall(nesne)
    Set nesne = .Item("read").Funcall("(setq pHandle nil)")
    dxfKonum = .Item("eval").Funcall(nesne)
End With

hataDxfDegerAl:
Set nesne = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
End Function

2. kod çalıştığında ise ölçü aralığı belirtiliyor ve çizim nesneleri seçiliyor. Seçilen nesnelerden LINEAR veya ALIGNED olan ölçülerin ölçü aralıkları verilen mesafe ile eşitleniyor. Seçili diğer nesneler dikkate alınmıyor.

' Mesut Akcan
' makcan@gmail.com
' https://mesutakcan.blogspot.com
' https://www.youtube.com/mesutakcan
' 30/12/2021

Option Explicit
Const X = 0, Y = 1, Z = 2

Sub olcuAralikEsitle_2()
Dim olcu As AcadEntity
Dim yk As Variant, yeniYK As Variant 'yazı konumu
Dim n1 As Variant, n2 As Variant, p2 As Variant
Dim bn As Variant 'baz nokta
Dim aralik As Double, fark As Double
Dim sSet As AcadSelectionSet 'seçim seti

On Error Resume Next
With ThisDrawing
    aralik = .Utility.GetDistance(, "Ölçü çizgisi aralığı:")
    If Err Then GoTo hata
    .SelectionSets.Item("SS1").Delete 'SS1 varsa sil
    Set sSet = .SelectionSets.Add("SS1")
End With
Err.Clear
sSet.SelectOnScreen
If Err Then GoTo hata

For Each olcu In sSet
If olcu.ObjectName = "AcDbAlignedDimension" Or olcu.ObjectName = "AcDbRotatedDimension" Then
    p2 = DxfDegerAl(olcu, 10) 'ölçü noktası
    n1 = DxfDegerAl(olcu, 13) 'çizgi 1. nokta
    n2 = DxfDegerAl(olcu, 14) 'çizgi 2. nokta
    yk = olcu.TextPosition 'ölçü yazı konumu
    
    '---- YATAY ÖLÇÜ ----
    If p2(X) = n2(X) Then
        If n2(Y) > p2(Y) Then ' -- ALT --
            If n1(Y) <= n2(Y) Then n2(Y) = n1(Y) Else n1(Y) = n2(Y)
        Else                  ' -- ÜST --
            If n1(Y) >= n2(Y) Then n2(Y) = n1(Y) Else n1(Y) = n2(Y)
        End If
        fark = n1(Y) - yk(Y) 'Y farkı
        yeniYK = n1 'yeni yazı konumu
        yeniYK(Y) = n1(Y) - Sgn(fark) * aralik
        yeniYK(X) = yk(X)
        olcu.TextPosition = yeniYK
    
    '---- DİKEY ÖLÇÜ ----
    Else
        If n2(X) > p2(X) Then ' -- SOL --
            If n1(X) <= n2(X) Then n2(X) = n1(X) Else n1(X) = n2(X)
        Else                  ' -- SAĞ --
            If n1(X) >= n2(X) Then n2(X) = n1(X) Else n1(X) = n2(X)
        End If
        fark = n1(X) - yk(X) 'X farkı
        yeniYK = n1 'yeni yazı konumu
        yeniYK(X) = n1(X) - Sgn(fark) * aralik
        yeniYK(Y) = yk(Y)
        olcu.TextPosition = yeniYK
    End If
End If
Next
hata:
ThisDrawing.SelectionSets.Item("SS1").Delete
Set sSet = Nothing
End Sub

Public Function DxfDegerAl(pAcadObj, pDXFCode As Integer) As Variant
Dim VLisp As Object, VLispFunc As Object
Dim nesne As Object, strHnd As String
Dim dxfKonum As Variant, konum(2) As Double
Dim b1 As Byte, b2 As Byte 'boşluk konumu

On Error GoTo hataDxfDegerAl
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Set VLispFunc = VLisp.ActiveDocument.Functions
strHnd = pAcadObj.Handle
    
With VLispFunc
    Set nesne = .Item("read").Funcall("pDXF")
    dxfKonum = .Item("set").Funcall(nesne, pDXFCode)
    Set nesne = .Item("read").Funcall("pHandle")
    dxfKonum = .Item("set").Funcall(nesne, strHnd)
    Set nesne = .Item("read").Funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
    dxfKonum = .Item("eval").Funcall(nesne)
    
    b1 = InStr(2, dxfKonum, " ", vbTextCompare) '1. boşluk konumu
    b2 = InStr(b1 + 1, dxfKonum, " ", vbTextCompare) '2. boşluk konumu
    konum(X) = Val(Mid(dxfKonum, 2, b1 - 1)) 'X değeri
    konum(Y) = Val(Mid(dxfKonum, b1 + 1, b2 - (b1 + 1))) 'Y değeri
    konum(Z) = Val(Mid(dxfKonum, b2 + 1, Len(dxfKonum) - (b2 + 1))) 'Z değeri
    
    DxfDegerAl = konum
    
    Set nesne = .Item("read").Funcall("(setq pDXF nil)")
    dxfKonum = .Item("eval").Funcall(nesne)
    Set nesne = .Item("read").Funcall("(setq pHandle nil)")
    dxfKonum = .Item("eval").Funcall(nesne)
End With

hataDxfDegerAl:
Set nesne = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
End Function