8 Haziran 2009 Pazartesi

AutoCAD'de (VBA projesi) Makro Oluşturmak...

Bu sayfada, mühendislik çalışmalarınızda sizlere büyük kolaylık sağlayacak AutoCAD makroları oluşturma ve bunları yönetmeyle ilgili bilgiler vereceğim. Her zaman için teorik bilgi vermektense, uygulamalı olarak anlatmanın çok daha önemli olduğunu düşündüğümden ilk önce sizlere yazdığım kısa bir makroyu tanıtacağım ve daha sonra bu makroyu AutoCAD içine nasıl yükleneceğini ve otomatik olarak her açılışta nasıl yükleneceğini anlatacağım. Her AutoCAD verisiyonu için aynı olan bu işlemleri AutoCAD 2008 platrformunu kullanarak anlatacağım.

Yazdığım Makro AutoCAD ortamında çarpma, toplama ve çık
arma işlemlerini text seçerek otomatik hale gietiriyor. AutoCAD ortamında Makrolara ulaşamak için ya da makro yaratmak için öncellikle, AutoCAD'in Visual Basic Editörüne ulaşmamız gerekiyor. Öncesinde ise uzantısı dvb AutoCAD VBA dosyası oluşturmamız gerekiyor. Boş bir AutoCAD dosyası açıp kaydettikten sonra sırasıyla Tools --> Macro --> VBA Manager seçimlerini yapıyoruz.


Açılan pencerede New düğmesine tıkladıktan sonra yeni makro projemiz oluşturulmuştur.
Daha sonra aynı ekranda sol alt köşede görülen Visual Basic Editör düğmesine tıklanır. Açılan pencerede artık Visual Basic dilini ve birçok özelliğini kullanrak makro projeleri oluşturabilirsiniz. Bu örnekte, bir module içine basit bir makro yerleştireceğiz. Aşağıdaki resimde gördüğünüz visual basic editöründe az önce oluşturduğumuz Global7 adındaki dosyayı bulabilirsiniz. Bunu seçili hale getirdikten sonra aynı ekrandaki kaydet düğmesiyle projenizi bilgisayarınızda herhangi bir yere kaydetmelisiniz.
Proje dosyasının adını mat.dvb olarak belirledim. Daha sonra Projeyi seçtikten sonra üzerinde sağa tıklayıp, Insert, Module seçeneklerini tamamlayıp, makrolarımıza ait VB kodlarını yazacağımız Module1'i eklemiş oluyoruz. Sağda açılan ekrana aşağıdaki kodları eklediğimizde artık programımız çalıştırmaya hazır demektir

Çarpma programı için makro

Sub carp()

On Error Resume Next
Dim text1 As AcadObject
Dim text2 As AcadObject
Dim basePnt As Variant
Dim textObj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
Dim returnPnt As Variant
Dim returnString As String


ThisDrawing.Utility.GetEntity text1, basePnt, "Çarpılacak 1. Sayıyı Seçiniz"

ThisDrawing.Utility.GetEntity text2, basePnt, "Çarpılacak 2. Sayıyı Seçiniz"

Dim a
a = Format(Val(text2.textString) * Val(text1.textString), "0.00")
textString = a

returnPnt = ThisDrawing.Utility.GetPoint(, "Noktayı Seçiniz ")

Set textObj = ThisDrawing.ModelSpace.AddText(textString, returnPnt, 0.25)

End Sub


Toplama için makro

Sub top()


Dim text1 As AcadObject
Dim text2 As AcadObject
Dim basePnt As Variant
Dim textObj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
Dim returnPnt As Variant
Dim top As Double
Dim returnString As String

Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET7")



Dim corner1 As Variant
Dim corner2 As Variant


corner1 = ThisDrawing.Utility.GetPoint(, "Noktayı Seçiniz ")


corner2 = ThisDrawing.Utility.GetCorner(corner1, "Noktayı Seçiniz ")

ssetObj.Select acSelectionSetCrossing, corner1, corner2

Dim newObjs() As AcadEntity
Dim count As Integer
count = ssetObj.count

ReDim newObjs(count) As AcadEntity
Dim index As Integer
top = 0
For index = 0 To count - 1

Set newObjs(index) = ssetObj.Item(index)


If newObjs(index).ObjectName = "AcDbText" Then
top = top + Val(newObjs(index).textString)

End If

Next

ThisDrawing.Utility.GetEntity text1, basePnt, "Değişecek Text'i seçiniz"
top = Round(top, 2)
Dim a
a = Format(top, "0.00")


text1.textString = a


Dim layerObj As AcadLayer
Set layerObj = ThisDrawing.Layers.Item("0")


ssetObj.Clear
ssetObj.Delete

End Sub


Çıkarma için Makro

Sub cikar()

On Error Resume Next
Dim text1 As AcadObject
Dim text2 As AcadObject
Dim basePnt As Variant
Dim textObj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
Dim returnPnt As Variant
Dim top As Double
Dim returnString As String
Dim returnString2 As String


Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSET6")


Dim corner1 As Variant
Dim corner2 As Variant
Dim a

returnString = ThisDrawing.Utility.GetString(False, "Çıkarılacak sayıyı giriniz: ")
returnString2 = ThisDrawing.Utility.GetString(False, "Noktadan sonra kaç basamak olsun(En fazla 6): ")
corner1 = ThisDrawing.Utility.GetPoint(, "Noktayı Seçiniz ")


corner2 = ThisDrawing.Utility.GetCorner(corner1, "Noktayı Seçiniz ")

ssetObj.Select acSelectionSetCrossing, corner1, corner2

Dim newObjs() As AcadEntity
Dim count As Integer
count = ssetObj.count

ReDim newObjs(count) As AcadEntity
Dim index As Integer

For index = 0 To count - 1

Set newObjs(index) = ssetObj.Item(index)


If newObjs(index).ObjectName = "AcDbText" Then
top = Val(newObjs(index).textString)
top = top - Val(returnString)
If returnString2 = 0 Then
a = Format(top, "0")
newObjs(index).textString = a
ElseIf returnString2 = 1 Then
a = Format(top, "0.0")
newObjs(index).textString = a
ElseIf returnString2 = 2 Then
a = Format(top, "0.00")
newObjs(index).textString = a
ElseIf returnString2 = 3 Then
a = Format(top, "0.000")
newObjs(index).textString = a
ElseIf returnString2 = 4 Then
a = Format(top, "0.0000")
newObjs(index).textString = a
ElseIf returnString2 = 5 Then
a = Format(top, "0.00000")
newObjs(index).textString = a
ElseIf returnString2 = 6 Then
a = Format(top, "0.000000")
newObjs(index).textString = a
End If
End If
Next


Dim layerObj As AcadLayer
Set layerObj = ThisDrawing.Layers.Item("0")


ssetObj.Clear
ssetObj.Delete

End Sub


Devamında oluşturduğumuz karo için nasıl komut oluşturacağımız ve otomatik yükleyeceğimizi anlatcağım.

Hiç yorum yok:

Yorum Gönder