Block Yerleşimi

Merhaba,
Bir Block u belirlediğimiz bir alan içerisin de eşit mesafeler de yerleştirmemize yarar.
Örnek : Bir Oda içerisine Armatür blocklarımızı düzgün bir şekilde yerleştirmek istediğimiz de oldukca kullanışlı olacaktır.

Ben bunu ilk olarak lisp le çözümünü gördüm ve bunu VBA ya dönüştürmek istedim.
Lispi www.autocadokulu.com un Forum sayfasın da @wolf nickini kullanan bir arkadaş yayınlamıştı.
Dilerseniz Lisp i deneyebilirsiniz. Lisp yükle(arm.fas)

İlk olarak Blockları yerleştirecegimiz alanın Sol Alt noktası,
ardın dan Sağ Üstnoktanın işaretlenmesi istenir,
Bu sayede alanın genişliği ve yüksekliği tespit edilir.

Yatay da ve Dikey de kaç edet Block yerleştirilmek istendiği sorulur.
boş geçilir ise varsıyan değer olarak 1(bir) belirledim.

Hemen ardından bu alanın içine yerleştirmek istediğimiz Block un ismi istenir.
eğer block ismi verilmez veya block bulunamaz sa varsayılan olarak uygun yerlere sadece Nokta(Point) yerleştirmesini sağladım.

Not: Yakın zaman da BioCAD e dahil edeceğim oldukca kullanışlı ;)

Sub armaturdiz()
ThisDrawing.SendCommand Chr(3) & Chr(3)

On Error Resume Next
Dim returnPnt1 As Variant
Dim returnPnt2 As Variant
Dim DikMiktar As Double
Dim YatayMiktar As Double
Dim BlockName As String

returnPnt1 = ThisDrawing.Utility.GetPoint(, "Sol alt noktasini isaretleyin: ")

If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

returnPnt2 = ThisDrawing.Utility.GetPoint(, "Sag ust noktasini isaretleyin: ")

If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

DikMiktar = ThisDrawing.Utility.GetReal("Yatay Block sayısı<1> |||: ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
DikMiktar = 1
Else
' esc tıklamıştır işlemi sonlandır
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If
End If

YatayMiktar = ThisDrawing.Utility.GetReal("Dikey Block sayısı<1> ---: ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
YatayMiktar = 1
Else
' esc tıklamıştır işlemi sonlandır
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If
End If

BlockName = ThisDrawing.Utility.GetString(False, "Yerleştirilecek Block un adını giriniz(Space, Enter veya Block yoksa<Nokta>): ")
If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

On Error GoTo 0

Dim pointObj As AcadPoint
Dim BlockNameVar As Boolean
Dim blockRefObj As AcadBlock
Dim blockRefObj01 As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
Dim blkColl As AcadBlocks
Set blkColl = ThisDrawing.Blocks

For Each blockRefObj In blkColl
If blockRefObj.Name = BlockName Then
BlockNameVar = True
End If
Next

' cizim içinde bir block değilse dwg uzantısı ekle
If BlockNameVar = False Then
BlockName = BlockName & ".dwg"
End If

For i = 1 To (YatayMiktar * 2) Step 2
For k = 1 To (DikMiktar * 2) Step 2

insertionPnt(0) = (returnPnt1(0) + ((returnPnt2(0) - returnPnt1(0)) / (DikMiktar * 2) * k))
insertionPnt(1) = (returnPnt1(1) + ((returnPnt2(1) - returnPnt1(1)) / (YatayMiktar * 2) * i))
insertionPnt(2) = 0

If BlockName <> "" Then

On Error Resume Next
Set blockRefObj01 = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, BlockName, 1#, 1#, 1#, 0)
' Block bilgisayarda yoksa yerine nokta koy
If Err Then
Set pointObj = ThisDrawing.ModelSpace.AddPoint(insertionPnt)
Err.Clear
End If

On Error GoTo 0

Else
' Sadece işaretlemek isterse Nokta koy
Set pointObj = ThisDrawing.ModelSpace.AddPoint(insertionPnt)
End If

Next k
Next i

End Sub 

Ekler:
Dosya: armatur.zip
Dosya içeriği: armatur.bas

Kolay gelsin