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
Hiç yorum yok:
Yorum Gönder