STrim

Merhaba,
Süper Trim kısaca STrim ;)
STrim.bas dosyası yükledikten sonra STrim Macrosu çalıştırdığınız da
Sizden Kesişen çizgilerin ORTASINDA bir NOKTA göstermeniz istenir.

Örnek olarak resmi inceleyiniz

(STrim uygulamadan önceki durum)

STrim Makrosu çalıştırılıp kesişen çizgilerin ortasında ki
bir noktayı Tıkladığınızda (boş kapalı alan: Hatch alanı şeçermiş gibi)
sonucu aşağıda ki resimde inceleyebilirsiniz.

(STrim uygulandıktan sonra ki durum)

Komutan çıkmadan birden fazla kapalı alan seçebilirsiniz.
Esc, Space, Enter veya Fare Sağtıklandıgında STrim sonlandırılır.

Function SecimPoly(Optional kim As String = "yakala")
Dim fType(0) As Integer, fData(0)
Dim PolySS As AcadSelectionSet
Dim Secili As Integer

On Error Resume Next
Set PolySS = ThisDrawing.SelectionSets("PolySS")
If Err Then Set PolySS = ThisDrawing.SelectionSets.Add("PolySS")
PolySS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "LWPOLYLINE"

' Tüm PolyLine ları seç
PolySS.Select acSelectionSetAll, , , fType, fData

' gelen kim değeri yakala ise
If kim = "yakala" Then
' yeni(not: ilginçtir ilk oluyor(0 değeri)) oluşturulan Polyline nın ObjectID ver
SecimPoly = PolySS.Item(0).ObjectID
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
SecimPoly = PolySS.Count
End If

PolySS.Delete
End Function
Private Sub LineCenterTrim()
Dim fType(0) As Integer
Dim fData(0) As Variant
Dim LayerSS As AcadSelectionSet
Dim Secili As Integer
Dim ScaleLine As AcadLine
Dim Sp(0 To 2) As Double
Dim Ep(0 To 2) As Double
Dim Str As ACAD_POINT

On Error Resume Next
Set LayerSS = ThisDrawing.SelectionSets("LayerSS")
If Err Then Set LayerSS = ThisDrawing.SelectionSets.Add("LayerSS")
LayerSS.Clear

fType(0) = 8: fData(0) = "STrimgecici"

' STrimgecici Layerinde ki tüm objeleri seç
LayerSS.Select acSelectionSetAll, , , fType, fData

' Son objeji sil
LayerSS.Item(LayerSS.Count - 1).Delete

' Son obje silindiği için - 2 kadar döngü
For Secili = 0 To LayerSS.Count - 2

' Lineları tek tek yakala
Set ScaleLine = LayerSS.Item(Secili)

' Line ların başlangıç noktası koordinatını öğren
Sp(0) = ScaleLine.StartPoint(0): Sp(1) = ScaleLine.StartPoint(1): Sp(2) = ScaleLine.StartPoint(2)

' Line ları başlangıç noktasından tutarak 0.5 oranında Scale uygula
ScaleLine.ScaleEntity Sp, 0.5

' line ların son nokta koordinatlarını ögren
Ep(0) = ScaleLine.EndPoint(0): Ep(1) = ScaleLine.EndPoint(1): Ep(2) = ScaleLine.EndPoint(2)

' Str olarak hafızaya al
Str = Str & Replace(Ep(0), ",", ".") & "," & Replace(Ep(1), ",", ".") & "," & Replace(Ep(2), ",", ".") & vbCr

' Line ları yok et
LayerSS.Item(Secili).Delete
Next Secili

' Trim uygula tüm objeleri sec sonra Str noktalarını tıkla
ThisDrawing.SendCommand Chr(3) & Chr(3) & "trim" & vbCr & "ALL" & vbCr & vbCr & Str & vbCr
Str = ""

LayerSS.Delete
End Sub
Sub STrim()

' info(at)mentes.com.tr
' ibrahim Yorulmaz - Antalya
' o 532 625 55 66

Dim KacPoly As Integer
Dim KacPoly2 As Integer
Dim oPoly As AcadLWPolyline
Dim oCoords As Variant

On Error Resume Next

Do

' Function SecimPoly le PolyLineları say
KacPoly = SecimPoly("say")

Dim returnPnt As Variant
returnPnt = ThisDrawing.Utility.GetPoint(, "Kesişen çizgilerin ORTASINDA bir NOKTA gösteriniz: ")

If Error = "User input is a keyword" Or Error = "Method 'GetPoint' of object 'IAcadUtility' failed" Then
ThisDrawing.Utility.Prompt "STrim Sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Exit Sub
End If

Pnt0 = Replace(returnPnt(0), ",", ".")
Pnt1 = Replace(returnPnt(1), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary" & vbCr & Pnt0 & "," & Pnt1 & vbCr & vbCr

' Function SecimPoly le PolyLineları say
KacPoly2 = SecimPoly("say")

' eğer cizimde yeni PolyLine yoksa
If KacPoly = KacPoly2 Then
ThisDrawing.Utility.Prompt "Lütfen Kapalı bir alan olduğunu kontrol ediniz. !" & vbCrLf
Else
' yeni oluşturulan Polyline(boundary) ı yakala
' Function SecimPoly("yakala") la yeni oluşturulan Polyline nın ObjectID sini öğren
Set oPoly = ThisDrawing.ObjectIdToObject(SecimPoly("yakala"))

' STrimgecici ismin de yeni Layer oluştur
ThisDrawing.Layers.Add ("STrimgecici")

' Yakalanan PolyLine nın Layerini STrimgecici yap
oPoly.Layer = "STrimgecici"

' Yakalanan PolyLine a Explode uygula (patlat linelar cıksın ortaya)
oPoly.Explode

' Private Sub LineCenterTrim() uygula
' Lineları bul
' ilk noktasından tutarak 0.5 scala yap
' son noktaları bul
' lineları yok et
' Sonnoktalara göre çizime trim uygula
LineCenterTrim

' Oluşturdugumuz STrimgecici Layerini yok et
ThisDrawing.Layers("STrimgecici").Delete

End If

Loop

End Sub

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

Kolay gelsin

BlocksExplode

Merhaba,

BlocksExplode.bas dosyası yükledikten sonra
BlockPatlat Macrosu çalıştırdığınız da
Sizden çiziminiz de patlatmak istediğiniz blocklardan bir tanesini seçmenizi ister
block seçtiğiniz de aynı blokların hepsini patlatır yani Explode uygular
esc, space veya enter tıklanırsa macro sonlanır

Public Sub BlocksExplode(BlockToFind As String)

Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim BlockSS As AcadSelectionSet
Dim secili As Integer

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "INSERT": fType(1) = 2: fData(1) = BlockToFind
BlockSS.Select acSelectionSetAll, , , fType, fData

For secili = 0 To BlockSS.Count - 1
BlockSS.Item(secili).Explode
Next secili

BlockSS.Delete
End Sub
Sub BlockPatlat()
Dim objEnt As AcadObject

On Error Resume Next

Do
Do While Err = 0

ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Patlatmak istediğiniz Blocklara ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz !" & vbCrLf
Err.Clear
Exit Do
End If
End If

If objEnt.ObjectName = "AcDbBlockReference" Then
BlocksExplode (objEnt.Name)
Else
ThisDrawing.Utility.Prompt "Lütfen BLOCK Seçiniz !" & vbCrLf
Err.Clear
Exit Do
End If

Loop
Loop

End Sub

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

Kolay gelsin.

Dwg2Jpg

Merhaba,
DWG dosyasını JPG dosyasına dönüştüren Makro Function'u
yeni oluşturulacak olan jpg dosyası
dwg dosyanızla aynı klasöre kayıt edilecektir.

Function Dwg2Jpg(DwgFullName As String)
Dim NewDwg As AcadDocument
Set NewDwg = Documents.Open(DwgFullName)

Dim JpgName As String
JpgName = Left(DwgFullName, (InStr(DwgFullName, ".dwg")) - 1) & ".jpg"

Dim plotFileName As String
plotFileName = "PublishToWeb JPG.pc3"

Dim corner1(0 To 1) As Double
Dim corner2(0 To 1) As Double
corner1(0) = ThisDrawing.Limits(0): corner1(1) = ThisDrawing.Limits(1)
corner2(0) = ThisDrawing.Limits(2): corner2(1) = ThisDrawing.Limits(3)

ThisDrawing.ActiveLayout.CenterPlot = True
ThisDrawing.ActiveLayout.StandardScale = acScaleToFit
ThisDrawing.ActiveLayout.SetWindowToPlot corner1, corner2
ThisDrawing.ActiveLayout.GetWindowToPlot corner1, corner2
ThisDrawing.ActiveLayout.PlotType = acWindow

Dim result As Boolean
result = ThisDrawing.Plot.PlotToFile(JpgName, plotFileName)

NewDwg.Close

Set NewDwg = Nothing
End Function

Sub TestJpg()
Dwg2Jpg "C:\Documents and Settings\bla bla\My Documents\MyProgram\AutocadVBA\ElkBlock\Evaevienetanj.dwg"
Beep
End Sub

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

Kolay gelsin

Dwg2Bmp

Merhaba,
DWG dosyasını BMP dosyasına dönüştüren Makro Function'u
yeni oluşturulacak olan bmp dosyası
dwg dosyanızla aynı klasöre kayıt edilecektir.

Function Dwg2Bmp(DwgFullName As String)
Dim NewDwg As AcadDocument
Set NewDwg = Documents.Open(DwgFullName)

Dim DwgPath As String
Dim DwgName As String
DwgPath = ThisDrawing.Path
DwgName = Left(ThisDrawing.Name, (InStr(ThisDrawing.Name, ".dwg")) - 1)

Dim exportFile As String
exportFile = DwgPath & "\" & DwgName

Dim mode As Integer
Dim corner1(0 To 2) As Double
Dim corner2(0 To 2) As Double
Dim BlockSS As AcadSelectionSet

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear

mode = acSelectionSetCrossing
corner1(0) = ThisDrawing.Limits(0): corner1(1) = ThisDrawing.Limits(1): corner1(2) = 0
corner2(0) = ThisDrawing.Limits(2): corner2(1) = ThisDrawing.Limits(3): corner2(2) = 0

BlockSS.Select mode, corner1, corner2

ThisDrawing.Export exportFile, "bmp", BlockSS

BlockSS.Delete

NewDwg.Close

Set NewDwg = Nothing

End Function
Sub TestBmp()
Dwg2Bmp "C:\Documents and Settings\bla bla\My Documents\MyProgram\AutocadVBA\ElkBlock\Evaevienetanj.dwg"
Beep
End Sub

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

Kolay gelsin

LayerBack

Merhaba,
çiziminiz de ki bir objeyi seçmeniz istenir ve
seçtiğiniz objeye ait Layer'e ait objelerin hepsini arkaya atar.

AutoCAD diliyle anlatmak gerekir se
Layer e ait tüm objeleri seçer ve DrawOrder Send To Back uygular.

Public Sub SendLayerBack(strLayer As String)
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 8: fData(0) = strLayer

With ThisDrawing.PickfirstSelectionSet
.Clear
.Select acSelectionSetAll, , , fType, fData
If .Count > 0 Then ThisDrawing.SendCommand ("DrawOrder p  Back") & vbCr
End With

End Sub

Sub LayerBack()
Dim objEnt As AcadObject
Dim i As Integer

On Error Resume Next
TEKRARSEC:
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Arkaya göndermek istediğiniz Layer e ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
GoTo TEKRARSEC
End If
End If

SendLayerBack objEnt.Layer

GoTo TEKRARSEC

End Sub

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

Kolay gelsin.

Düzeltme : 06.09.2007

Programcı bir arkadaşım uyarıda bulundu
Kodlar da kullandığım GoTo nun
eskide kaldığı ve artık kullanılmadığını söyledi.

Bizde arkadaşımızı kırmadık
kodları evirdik çevirdik, olmadı yan yatırdık hallettik :)

Buyrun alternatif yeni kodlar :

Sub LayerBack()
Dim objEnt As AcadObject

On Error Resume Next

Do
Do While Err = 0
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Arkaya göndermek istediğiniz Layer e ait bir obje seçiniz: "
If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
Exit Do
End If
End If
SendLayerBack objEnt.Layer
Loop
Loop

End Sub

Kolay gelsin.

LayerOff - LayerOnAll

Merhaba,
çiziminizde ki bir objeyi seçmeniz istenir ve
sectiğiniz objeye ait Layer i kapatır.

eğer AutoCAD'iniz de expresstools yüklü ise
komut satırına layoff yazdıgınız da
oluşan işlemin aynısını gerçekleştirecektir

Sub LayerOff()
Dim objEnt As AcadObject
Dim i As Integer

On Error Resume Next
TEKRARSEC:
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Kapatmak istediğiniz Layer e ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
GoTo TEKRARSEC
End If
End If

If ThisDrawing.ActiveLayer.Name <> objEnt.Layer Then
ThisDrawing.Layers(objEnt.Layer).LayerOn = False
ThisDrawing.Utility.Prompt objEnt.Layer & " Layeri Kapatıldı." & vbCrLf
Else
Dim SoruEH As String
SoruEH = "Evet Hayır"
ThisDrawing.Utility.InitializeUserInput 1, SoruEH
Dim returnString As String
returnString = ThisDrawing.Utility.GetKeyword("Kapatmak istediğiniz (" & objEnt.Layer & ") Layeri Aktif! Yine de kapatmak istiyormusun (Evet/Hayır): ")
If returnString = "Evet" Then
ThisDrawing.Layers(objEnt.Layer).LayerOn = False
ThisDrawing.Utility.Prompt objEnt.Layer &" Layeri Kapatıldı." & vbCrLf
End If
End If

GoTo TEKRARSEC

End Sub

Sub LayerOnAll()
Dim LayerAll As AcadLayers
Dim LayerOne As AcadLayer
Set LayerAll = ThisDrawing.Layers
On Error Resume Next
For Each LayerOne In LayerAll
LayerOne.LayerOn = True
Next LayerOne
End Sub

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

Kolay gelsin.