AutoCAD VBA #27. Çizgiye Nokta-3

Youtube koni açınımları videolarında kullandığım çizgiye nokta VBA makrosunun geliştirmeye devam ediyorum.

Makro çalıştırıldığında bir çizgi seçilerek çizginin uzunluğu alınır. Sonra bir çizgi daha seçilir 2. seçilen çizgiye 1. çizgi uzunluğu mesafesinde nokta konulur.

Bu videoda makro kodları geliştirildi. Komutun 1. aşamasında çizgi ile beraber yay, daire ve polyline çizgilerinin uzunlukları uzunluk değeri olarak alınıyor.

CizgiyeNokta makrosunu komut satırından çalıştırmak için Autocad'de CN komutu oluşturulur. CN komutunu oluşturmak için CN_komutu prosedürünün bir kere çalıştırılması yeterlidir.

Videoda kullanılan kodlar:

Sub CizgiyeNokta()
'Seçilen çizgi uzunluğu mesafesinde sonraki seçili çizgiye nokta ekler
'19/03/2022
'Mesut Akcan
'makcan@gmail.com
'mesutakcan.blogSpot.com
Dim cizgi1 As AcadEntity, cizgi2 As AcadEntity
Dim p As AcadPoint 'nokta nesnesi
Const tdene = " Tekrar deneyin"
Const gecersizNesne = "Geçerli nesne değil!" & tdene
Const nesneSecilmedi = "Nesne seçilmedi!" & tdene
On Error Resume Next 'bir hata olursa sonraki satırdan devam et
Do
	With ThisDrawing.Utility
NESNE_SEC:
		Err.Clear 'hatayı temizle
		.InitializeUserInput 0, "Uzunluk Çıkış"
		'Nesne Seç
		.GetEntity cizgi1, tn, vbLf & "Uzunluğu alınacak çizgiyi seç veya [Uzunluk/Çıkış]: "
		If iptal Then Exit Do 'döngüden çık
		If Err Then 'hata varsa
			'hata açıklamasında keyword geçiyorsa
			If Err.Description Like "*keyword*" Then
				Select Case .GetInput() 'komuttan girilen seçeneği al
					Case "Uzunluk" 'seçenek Uzunluk ise
						.InitializeUserInput 1 + 2 'boş ve 0 değeri girişini engelle
						c1uz = .GetDistance(, vbLf & "Uzunluk:") 'uzunluk değerini gir
					Case "Çıkış" 'seçenek Çıkış ise
						Exit Do 'döngüden çık
				End Select
			Else 'diğer hatalarda
				Call mesaj(nesneSecilmedi)
				GoTo NESNE_SEC 'NESNE_SEC satırına git
			End If
		Else
			c1uz = Uzunluk(cizgi1) '1. çizgi uzunluğu
			If c1uz = Empty Then 'hata varsa
				Call mesaj(gecersizNesne)
				GoTo NESNE_SEC
			End If
			If Err Then Exit Do 'hata varsa
			cizgi1.Highlight True 'çizgiyi vurgulu yap
			vurguVar = True 'vurgu olduğunda
		End If
NESNE_SEC2:
		Err.Clear 'hatayı temizle
		'Nesne seç
		.GetEntity cizgi2, tn, vbLf & "Nokta konulacak çizgi:"
		If iptal Then Exit Do 'ESS tuşuna basılırsa döngüden çık
		If Err.Number = -2147352567 Then 'nesne seçilmediğinde
			Call mesaj(nesneSecilmedi)
			GoTo NESNE_SEC2
		End If
		c2uz = cizgi2.Length '2. çizgi uzunluğu
		If Err Then 'hata varsa
			Call mesaj(gecersizNesne)
			GoTo NESNE_SEC2
		End If
		uzSp = Uzaklik(cizgi2.StartPoint, tn) 'tıklanan noktadan başlangıç noktasına uzaklık
		uzEp = Uzaklik(cizgi2.EndPoint, tn) 'tıklanan noktadan bitiş noktasına uzaklık
		If uzEp < uzSp Then c1uz = c2uz - c1uz 'tıklanan nokta bitiş noktasına yakınsa
		'çizgideki konuma nokta ekle
		Set p = ThisDrawing.ModelSpace.AddPoint(.PolarPoint(cizgi2.StartPoint, cizgi2.Angle, c1uz))
		p.Layer = "Nokta" 'noktanın katmanını değiştir
	End With
Loop
'vurgu varsa çizim nesneleri yeniden çiz
If vurguVar Then ThisDrawing.Regen acAllViewports
End Sub

Sub mesaj(metin As String) 'komut satırına mesaj yaz
	ThisDrawing.Utility.Prompt vbLf & "*" & metin & "*"
End Sub

Function iptal() 'Komut satırındaki son mesajda *Cancel* varsa (ESC tuşu basılmışsa)
	iptal = IIf(ThisDrawing.GetVariable("LASTPROMPT") Like "*Cancel*", True, False)
End Function

Function Uzaklik(p1, p2) As Double 'iki nokta arası mesafe
	Const X = 0, Y = 1
	Uzaklik = Sqr((p2(X) - p1(X)) ^ 2 + (p2(Y) - p1(Y)) ^ 2)
End Function

Function Uzunluk(ent As AcadEntity)
	Select Case ent.ObjectName 'nesne adı
		Case "AcDbLine", "AcDbPolyline", "AcDb2dPolyline" 'çizgi ve polyline ise
			Uzunluk = ent.Length 'nesne uzunluğu
		Case "AcDbArc" 'yay
			Uzunluk = ent.ArcLength 'yay uzunluğu
		Case "AcDbCircle" 'daire
			Uzunluk = ent.Circumference 'daire çevre uzunluğu
		Case Else 'diğer nesnelerde
			Uzunluk = Empty 'boş
	End Select
End Function
Sub CN_komutu() 'AutoCADe CN komutunu ekler
	ThisDrawing.SendCommand "(defun c:CN()(vl-vbarun ""CizgiyeNokta"")(princ))" & vbCr
End Sub

Sub NesneAdiYaz()
	On Error Resume Next 'hata olursa sonraki satırdan devam et
	Do
		Dim obj As AcadEntity
		'Nesne seç
		ThisDrawing.Utility.GetEntity obj, tn, "Nesne Seç:"
		'tıklanan konuma nesne adını yaz
		Set yazi = ThisDrawing.ModelSpace.AddText(obj.ObjectName, tn, 4)
		'Immediate penceresine nesne adını yaz (editörde CTRL+G ile açılır)
		Debug.Print obj.ObjectName
		yazi.color = acMagenta 'yazı rengini değiştir
		If Err Then Exit Do 'hata olursa döngüden çık
	Loop
End Sub