Herkese Merhaba;

Sizlerle paylaşmak istediğim bazı bilgileri "Programlama" genel başlığı altına değil de,
"AcadVBA" ya da daha genel; "AutoCAD & ActiveX" genel başlığı altına eklemeyi tercih ederdim.

Konu şu; AutoCAD'in Visual Basic ve Windows ActiveX özelliklerini bilenlere hatırlatma,
bilmeyenlere de "bir de işin bu kısmı var" şeklinde bir yol gösterme maksadıyla, bir takım
başlangıç bilgileri ve üç adet yeni AutoCAD komutu olabilecek makroyu buradan yayımlamak
istiyorum.

Bunlar kısaca;

TOD : çizimdeki tüm text override dimensionları bulur,
dimension textin yanına override edilmiş ölçüsü ile beraber gerçek ölçüsünü de yazar,
yazının rengi maviye döner. Tek seferde UNDO edilebilir.

SAD : çizimdeki tüm dimensionları; hangi layerda oldukları, stylelarının ne olup olmadığına bakmaksızın;
görünmez hale getirir, bir daha kullanıldığında visible özelliği tersine döner.

AX : Daire, yay ya da elips nesnesine eksen yapar, komut içindeyken sağ tuşun görevine dikkat..

Devam edelim;

AutoCAD ActiveX hakkında yeni olanlara açıklamalar;

MAKROLARI NASIL ÇALIŞTIRACAKSINIZ?
Türlü yolları var, fakat en uzun ve kalıcı olan yöntem aşağıdakidir.

Adım 1: AutoCAD'in makro güvenliğini yok edin, nasıl yapıldığını unuttum, siz bulursunuz kolaydı.

Adım 2: Klavyenin size göre solundaki ALT tuşu ve F11 tuşuna birlikte basın, Microsoft Visual Basic arabirimi açılacaktır.
Açılmıyorsa uğraşmayın, başka bir Acad bulun.

Adım 3: Açılan arabirimde Sol tarafta genelde Project Explorer vardır; yoksa Ctrl + R ile açın; daha önceden yüklenmiş bir Project yoksa genelde,
Mevcut Project ismi ACADProject(Global1) dir.
Project Explorer penceresinin üzerinde boş biyerlerde sağ tuş görevi gören tuşa basın,
açılan PopUp menüden Insert Module ile boş bir modül ekleyin.

Adım 4: Fonksiyonları bu modüle kopyalayın, ve Kaydet butonu ile qwerty.dvb benzeri uygun bir isimle lazım olduğunda bulabileceğiniz bir yere kaydedin.

Adım 5: AcadXXXX.lsp dosyanızı Notepad ile açın;
Mesela dosyanız burada olabilir-> C:Program FilesAutoCAD 2004SupportAcad2004.lsp

Aşağıdaki satırları AcadXXXX.lsp dosyanızın altında bi yere ekleyin; kaydet, kapat.


AcadXXXX.lsp dosyanıza EKLEMENİZ GEREKEN SATIRLAR AŞAĞIDAKİLERDİR

(defun C:AX ( )
( (command "-vbarun" "DrawCircleArcEllipseAxis") (princ) ) )

(defun C:SAD ( )
( (command "-vbarun" "SelectAllDimensions") (princ) ) )

(defun C:TOD ( )
( (command "-vbarun" "TextOverrideAllDimensions") (princ) ) )

AcadXXXX.lsp dosyanıza EKLEMENİZ GEREKEN SATIRLAR YUKARIDAKİLERDİR


Adım 6: AutoCAD'i KAPATIP tekrar başlatmak gerekebilir.

Adım 7: Daha bitmedi, AutoCAD açılınca menülerden; Tools > Load Application... > Startup Suite & Contents...
diye bi yerler bulun, kaydettiğiniz dvb dosyanızı Add ile ekleyin.

Adım 8: Yeni komutlarınız AX, SAD ve TOD umarım çalışır.. Çalışırsa bu adımları bir daha tekrar etmenize gerek yok,
yeni komutları her Acad açılışında kullanabileceksiniz.

Son Adım: Yeni komutları yaratın ve buradan paylaşın,
mesela 3D düzlemin, bu düzleme paralel olmayan bir ışını kestiği P(x,y,z) koordinatına bir POINT objesi atan kod yazın,
ödüllüdür duyurulur.

Saygılar, işlerinizde kolay gelsin.
09.2006
Harun KILIÇ
www.ksg.8k.com
destek@ksg.8k.com

Sıkıştırılmış DVB Dosyası ->

Linkleri görebilmek için ÜYE olmalısınız.



ADIM 4'te BAHSİ GEÇEN FONKSİYONLAR AŞAĞIDAKİLERİN TÜMÜDÜR.

'''***************************************************************************
'Option Explicit 'EKLEDİĞİNİZ MODULUN EN ÜSTÜNDE BU İBAREDEN BI TANE OLMASI LAZIM

'
Public Const LT_Dashdot2 = "DASHDOT2"
Public Const LA_DASHDOT2 = "LT.DashDot2"

'
Public Sub CreateLayer(LayerName As String, LayerColor As Integer, LayerLineType As String)
Dim TmpLayer As AcadLayer
Dim i

For i = 0 To ActiveDocument.Layers.Count - 1
If Trim(ActiveDocument.Layers.Item(i).Name) = Trim(LayerName) Then
ActiveDocument.Layers.Item(i).color = LayerColor
ActiveDocument.Layers.Item(i).Linetype = LayerLineType
Exit Sub
End If
Next i

Set TmpLayer = ActiveDocument.Layers.Add(LayerName)
TmpLayer.color = LayerColor
SetObjLineType TmpLayer, LayerLineType
End Sub

'
Public Sub SetObjLineType(AcadObj As AcadObject, LineTypeName As String)
Dim LTEntry As AcadLineType
Dim LTFound As Boolean

LTFound = False
For Each LTEntry In ThisDrawing.Linetypes
If StrComp(LTEntry.Name, LineTypeName, 1) = 0 Then
LTFound = True
Exit For
End If
Next
If Not (LTFound) Then ThisDrawing.Linetypes.Load LineTypeName, "acad.lin"
AcadObj.Linetype = LineTypeName
End Sub

'
Public Sub SetObjLayer(ByRef AcadObj As AcadObject, LayerName As String)
Dim i As Integer
SetObjLayerAGAIN:
For i = 0 To ActiveDocument.Layers.Count - 1
If Trim(ActiveDocument.Layers.Item(i).Name) = Trim(LayerName) Then
AcadObj.Layer = LayerName
Exit Sub
End If
Next i
CreateLayer LayerName, acWhite, "CONTINUOUS"
GoTo SetObjLayerAGAIN
End Sub

'
' Daire, yay ya da elips nesnesine eksen yapar
Public Sub DrawCircleArcEllipseAxis() 'By HK 09.2004 CommandLine: AX
' ActiveDocument.Utility.Prompt (vbLf & "Command AX : axis for arc, circle & ellipse" & vbLf)

Static LastHRadii As Double
Static LastVRadii As Double

Dim returnObj As AcadObject
Dim basePnt As Variant

Dim CentPnt(0 To 2) As Double

Dim CircObj As AcadCircle
Dim ArcObj As AcadArc
Dim ElpObj As AcadEllipse

Dim horDist As Double
Dim verDist As Double
Err.Clear
On Error Resume Next

RETRY:
ActiveDocument.Utility.GetEntity returnObj, basePnt, "Pick circle, arc or ellipse ->"

If Err <> 0 Then
Err.Clear
Exit Sub
Else
If returnObj.EntityName = "AcDbCircle" Then
Set CircObj = returnObj
CentPnt(0) = CircObj.Center(0): CentPnt(1) = CircObj.Center(1): CentPnt(2) = CircObj.Center(2)
horDist = ActiveDocument.Utility.GetDistance(CentPnt, "Set axis length <" & Format(LastHRadii, "#.0#") & "> :")
verDist = horDist
GoTo drwAXIS
ElseIf returnObj.EntityName = "AcDbArc" Then
Set ArcObj = returnObj
CentPnt(0) = ArcObj.Center(0): CentPnt(1) = ArcObj.Center(1): CentPnt(2) = ArcObj.Center(2)
horDist = ActiveDocument.Utility.GetDistance(CentPnt, "Set axis length <" & Format(LastHRadii, "#.0#") & "> :")
verDist = horDist
GoTo drwAXIS
ElseIf returnObj.EntityName = "AcDbEllipse" Then
Set ElpObj = returnObj
CentPnt(0) = ElpObj.Center(0): CentPnt(1) = ElpObj.Center(1): CentPnt(2) = ElpObj.Center(2)
horDist = ActiveDocument.Utility.GetDistance(CentPnt, "Set horizontal axis length <" & Format(LastHRadii, "#.0#") & "> :")
verDist = ActiveDocument.Utility.GetDistance(CentPnt, "Set vertical axis length <" & Format(LastVRadii, "#.0#") & "> :")
GoTo drwAXIS
Else
GoTo RETRY
End If
End If

Exit Sub

drwAXIS:

If horDist = 0# Or verDist = 0# Then
If returnObj.EntityName = "AcDbCircle" Then
If LastHRadii = 0# Then
horDist = CircObj.Radius + 5
Else
horDist = LastHRadii
End If
verDist = horDist
ElseIf returnObj.EntityName = "AcDbArc" Then
If LastHRadii = 0# Then
horDist = ArcObj.Radius + 5
Else
horDist = LastHRadii
End If
verDist = horDist
ElseIf returnObj.EntityName = "AcDbEllipse" Then
If horDist = 0 Then horDist = LastHRadii
If verDist = 0 Then verDist = LastVRadii
If horDist = 0# Or verDist = 0# Then Exit Sub
End If
End If

LastHRadii = horDist
LastVRadii = verDist

Dim AxStart(0 To 2) As Double
Dim AxEnd(0 To 2) As Double

Dim lineObjHor As AcadLine
Dim lineObjVer As AcadLine
'HORIZONTAL
AxStart(0) = CentPnt(0) - horDist: AxStart(1) = CentPnt(1): AxStart(2) = CentPnt(2)

AxEnd(0) = CentPnt(0) + horDist: AxEnd(1) = CentPnt(1): AxEnd(2) = CentPnt(2)

Set lineObjHor = ActiveDocument.ModelSpace.AddLine(AxStart, AxEnd)


'VERTICAL
AxStart(0) = CentPnt(0): AxStart(1) = CentPnt(1) - verDist: AxStart(2) = CentPnt(2)

AxEnd(0) = CentPnt(0): AxEnd(1) = CentPnt(1) + verDist: AxEnd(2) = CentPnt(2)

Set lineObjVer = ActiveDocument.ModelSpace.AddLine(AxStart, AxEnd)

CreateLayer LA_DASHDOT2, acRed, LT_Dashdot2
SetObjLayer lineObjHor, LA_DASHDOT2
SetObjLayer lineObjVer, LA_DASHDOT2

End Sub

'
'Bir defa çalıştırın tüm ölçüler kaybolsun, bidaa çalıştır, geri gelsin..
Public Sub SelectAllDimensions() 'By HK 09.2004 CommandLine: SAD
' ActiveDocument.Utility.Prompt (Command SAD : Hides-UnHides All Dimension Objects" & vbLf)
Dim objName As String
Dim Entry As AcadEntity
For Each Entry In ThisDrawing.ModelSpace
objName = Entry.ObjectName
Select Case objName
Case "AcDbRotatedDimension", _
"AcDbAlignedDimension", _
"AcDbOrdinateDimension", _
"AcDbRadialDimension", _
"AcDbDiametricDimension", _
"AcDb2LineAngularDimension", _
"AcDb3PointAngularDimension", _
"AcDbLeader"
Entry.Visible = Not Entry.Visible
End Select
Next
End Sub

'Belki lazım olur
Public Sub MakeAllDimensionsVisible()
Dim objName As String
Dim Entry As AcadEntity
For Each Entry In ThisDrawing.ModelSpace
objName = Entry.ObjectName
Select Case objName
Case "AcDbRotatedDimension", _
"AcDbAlignedDimension", _
"AcDbOrdinateDimension", _
"AcDbRadialDimension", _
"AcDbDiametricDimension", _
"AcDb2LineAngularDimension", _
"AcDb3PointAngularDimension", _
"AcDbLeader"
Entry.Visible = True
End Select
Next
End Sub


'' Bu herkese lazım, çalıştır, bi göz at, UNDO yap
Public Sub TextOverrideAllDimensions() 'By HK 09.2004 CommandLine: TOD
' ActiveDocument.Utility.Prompt (vbLf & "Command TOD : Indicates Text Override Dimensions in Blue Text Color" & vbLf)

Dim tStr As String
Dim objName As String
Dim Entry As AcadEntity
For Each Entry In ThisDrawing.ModelSpace
objName = Entry.ObjectName
Select Case objName
Case "AcDbRotatedDimension", _
"AcDbAlignedDimension", _
"AcDbOrdinateDimension", _
"AcDbRadialDimension", _
"AcDb3PointAngularDimension", _
"AcDbDiametricDimension", _
"AcDb2LineAngularDimension"
If Entry.TextOverride <> "" And Right(Entry.TextOverride, 2) <> "<>" Then
tStr = Entry.TextOverride
If InStr(1, tStr, "(") = 0 Then
Entry.TextOverride = "<>" & " (" & tStr & ")"
Entry.TextColor = acBlue ''''''''''''MAVI RENK DEGISTIRILEBILIR; mesela vbRed , vbGreen ya da vbYellow olarak degistirebilirsiniz
End If
Else

End If
End Select
Next
End Sub

Yazar: Harun KILIÇ
İçerik: Harun KILIÇ
Tag: AutoCAD VBA Makrolarını kısayol komutlarına dönüştürmek