NewSTrim

Merhaba,
İlk Eski STrim de sadece Line ların kesişmesi halinde
çoklu olarak trim yapılabiliyordu.

NStrim de ise Line, Arc, Polyline ve Spline keşişmesi
durumunda dahi çalışmaktadır.

Kodları yazarken kendimi biraz kaptırmışım
detaylı bir şey oldu mazur görün artık :)

New Süper Trim (NSTrim)
NSTrim.bas dosyası yükledikten sonra NSTrim Macrosu çalıştırdığınız da
Sizden Kesişen çizgilerin ORTASINDA bir NOKTA göstermeniz istenir
ve çoklu trim mi gerçekleştir.

Function HataPoly(Optional yoket As String = "sil", Optional silmiktar As Integer)
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) = "POLYLINE"

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

' gelen yoket değeri sil ise
If yoket = "sil" Then
' hatalı oluşturulan silmiktar kadar Polyline ları yok et
For i = 0 To silmiktar - 1
PolySS.Item(i).Delete
Next
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
HataPoly = PolySS.Count
End If

PolySS.Delete
End Function

Function SecimLWPoly(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,REGION"

' 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 veya Region ObjectID ver
SecimLWPoly = PolySS.Item(0).ObjectID
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
SecimLWPoly = PolySS.Count
End If

PolySS.Delete
End Function

Public Sub BlockTrim(BlockToFind As String)
Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim BlockSS As AcadSelectionSet
Dim secili As Integer
Dim InsPoint As Variant
Dim Str As ACAD_POINT

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

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

For secili = 0 To BlockSS.Count - 1

InsPoint = BlockSS.Item(secili).InsertionPoint

' Block koordinatlarını Str olarak hafızaya al
Str = Str & Replace(InsPoint(0), ",", ".") & "," & Replace(InsPoint(1), ",", ".") & "," & Replace(InsPoint(2), ",", ".") & vbCr

' Blockları yok et
BlockSS.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 & vbCr & Str & vbCr
Str = ""

' SelectionSets i yok et
BlockSS.Delete
End Sub

Sub NSTrim()

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

Dim KacLWPoly As Integer
Dim KacLWPoly2 As Integer
Dim KacPoly As Integer
Dim KacPoly2 As Integer

Dim plineObj As AcadLWPolyline
Dim RegionObj As AcadRegion
Dim minPt As Variant
Dim maxPt As Variant
Dim returnPnt As Variant
Dim newBlock As AcadBlock
Dim BlockInsertionPoint(0 To 2) As Double
Dim explodedObjects As Variant
Dim i As Integer
Dim numDivs As Long
numDivs = 2

On Error Resume Next

Do

' Function SecimLWPoly le LWPolyLine ve Region ları say
KacLWPoly = SecimLWPoly("say")
' Function KacPoly le hata durumnda oluşacak PolyLine ları say
KacPoly = HataPoly("say")

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

' Bounary hatalı olmaması için ZoomAll uygula
ThisDrawing.Application.ZoomAll

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

' Function SecimLWPoly le LWPolyLine ve Region ları say
KacLWPoly2 = SecimLWPoly("say")
' Function KacPoly le hata durumnda oluşacak PolyLine ları say
KacPoly2 = HataPoly("say")

' eğer cizimde yeni PolyLine yoksa
If KacLWPoly = KacLWPoly2 Then

' hata oluşma ihtimaline karsılık
' polylineları karsılaştır
' fazla polyline ları sil
If KacPoly <> KacPoly2 Then
HataPoly "sil", (KacPoly2 - KacPoly)
ThisDrawing.Utility.prompt "Üzgünüz AutoCAD alanı kapalı olarak algılamıyor. :( !" & vbCrLf
End If

' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious

ThisDrawing.Utility.prompt "Lütfen Kapalı bir alan olduğunu kontrol ediniz. !" & vbCrLf
Else

' yeni block yap
BlockInsertionPoint(0) = 0: BlockInsertionPoint(1) = 0: BlockInsertionPoint(2) = 0
Set newBlock = ThisDrawing.Blocks.Add(BlockInsertionPoint, "STrimBlockGecici")

' yeni oluşturulan Polyline(boundary) ı yakala
' Function SecimLWPoly("yakala") la yeni oluşturulan Polyline nın ObjectID sini öğren
If ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala")).ObjectName = "AcDbPolyline" Then

Set plineObj = ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala"))

' Trim in hatalı olmaması için ZoomObject uygula
ThisDrawing.SendCommand "._zoom _o (handent """ & plineObj.handle & """) "
ThisDrawing.SendCommand Format$(Chr(10))

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

ElseIf ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala")).ObjectName = "AcDbRegion" Then

Set RegionObj = ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala"))

' Trim in hatalı olmaması için ZoomObject uygula
ThisDrawing.SendCommand "._zoom _o (handent """ & RegionObj.handle & """) "
ThisDrawing.SendCommand Format$(Chr(10))

' Yakalanan Region a Explode uygula (patlat splinelar cıksın ortaya)
explodedObjects = RegionObj.Explode
Else
' düşünemediğin bir şey var pas geç çık
' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious
ThisDrawing.Utility.prompt "Üzgünüz hata oluştu !!!."
ThisDrawing.Utility.prompt "STrim Sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Exit Sub

End If

' explode sonucu ortaya cıkan objeleri yakala
For i = 0 To UBound(explodedObjects)
' Divide ile orta noktaktasına block(STrimBlockGecici) yapıştır
ThisDrawing.SendCommand "._divide (handent """ & explodedObjects(i).handle & """) "
ThisDrawing.SendCommand Format$("BLOCK") & " "
ThisDrawing.SendCommand Format$("STrimBlockGecici") & " "
ThisDrawing.SendCommand Format$(Chr(10))
ThisDrawing.SendCommand Format$("Y")
ThisDrawing.SendCommand Format$(Chr(10))
ThisDrawing.SendCommand Format$(numDivs) & " "
explodedObjects(i).Delete
Next

' Yakalanan PolyLine ı yok et
' Yakalanan Region u yok et
' not: neden patlatınca yok olmuyor anlamadım :s
plineObj.Delete
RegionObj.Delete

BlockTrim ("STrimBlockGecici")

' yeni blocku yok et
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-purge B STrimBlockGecici" & vbCr & "Y" & vbCr & "Y" & vbCr & Chr(3)
' Trim in hatalı olmaması için yapılan ZoomObject i geri al
ThisDrawing.Application.ZoomPrevious
' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious

End If

Loop

End Sub

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

Kolay gelsin.