Code:
Private Sub BlockEinfuegen(DWGName As String) Dim FaktorX, FaktorY, FaktorZ As Double
Dim Einfuegepunkt As Variant
Dim p0 As Variant
Dim p1 As Variant
Dim p2 As Variant
Dim p0ucs As Variant
Dim p1ucs As Variant
Dim p2ucs As Variant
Dim strP0 As String
Dim strP1 As String
Dim strP2 As String
Dim SelSet1 As AcadSelectionSet
Dim SelSet2 As AcadSelectionSet
Dim objBlockRef As AcadBlockReference
Dim objAttRef As AcadAttributeReference
Dim varAttRefs As Variant
Dim EinbrechpunkteVorhanden As Boolean
Dim i1 As Integer
Me.Hide
FaktorX = AktuellerMstab / AktuelleEinheit * AktuelleBlockgroesse
FaktorY = AktuellerMstab / AktuelleEinheit * AktuelleBlockgroesse
Me.Hide
Set SelSet1 = ThisDrawing.SelectionSets.Add(GenID("S1"))
SelSet1.Select acSelectionSetLast
ThisDrawing.SetVariable "MBUttonpan", 0
ThisDrawing.SendCommand ("(defun blockIn(Path)(princ)(Command ""_-Insert"" Path ""X"" """ & FaktorX & """ ""Y"" """ & FaktorY & """ pause pause)(princ))")
ThisDrawing.SendCommand "(blockIn """ & Replace(DWGName, "\", "/") & """)" & vbCr
ThisDrawing.SetVariable "MBUttonpan", 1
Set SelSet2 = ThisDrawing.SelectionSets.Add(GenID("S2"))
SelSet2.Select acSelectionSetLast
'Prüfen, ob Block eingefügt wurde oder abgebrochen wurde
If SelSet1(0).ObjectID = SelSet2(0).ObjectID Then
Exit Sub
End If
Set objBlockRef = SelSet2(0)
'SelectionSets löschen
SelSet1.Delete
SelSet2.Delete
If objBlockRef.HasAttributes Then
varAttRefs = objBlockRef.GetAttributes
EinbrechpunkteVorhanden = False
For i1 = LBound(varAttRefs) To UBound(varAttRefs) 'Alle Attribute durchlaufen
Set objAttRef = varAttRefs(i1) 'AttRef-Zeiger auf aktuelle Attributreferenz
If UCase(objAttRef.TagString) = "P1" Then
p1 = objAttRef.InsertionPoint
p1ucs = ThisDrawing.Utility.TranslateCoordinates(p1, acWorld, acUCS, 0)
EinbrechpunkteVorhanden = True
ElseIf UCase(objAttRef.TagString) = "P2" Then
p2 = objAttRef.InsertionPoint
p2ucs = ThisDrawing.Utility.TranslateCoordinates(p2, acWorld, acUCS, 0)
End If
Next i1
End If
If EinbrechpunkteVorhanden Then
'Prüfen, ob Block auf Linie platziert wurde
Set SelSet1 = ThisDrawing.SelectionSets.Add(GenID("S1"))
Dim FilterType() As Integer
Dim FilterData As Variant
ReDim FilterType(3): ReDim FilterData(3)
FilterType(0) = -4: FilterData(0) = "<OR"
FilterType(1) = 0: FilterData(1) = "LINE"
FilterType(2) = 0: FilterData(2) = "LWPOLYLINE"
FilterType(3) = -4: FilterData(3) = "OR>"
SelSet1.Select acSelectionSetCrossing, p1ucs, p2ucs, FilterType, FilterData
If SelSet1.Count = 1 Then
objBlockRef.Visible = False
objBlockRef.Layer = SelSet1(0).Layer
p0ucs = ThisDrawing.Utility.TranslateCoordinates(objBlockRef.InsertionPoint, acWorld, acUCS, 0)
strP0 = Replace(p0ucs(0), ",", ".") & "," & Replace(p0ucs(1), ",", ".")
strP1 = Replace(p1ucs(0), ",", ".") & "," & Replace(p1ucs(1), ",", ".")
strP2 = Replace(p2ucs(0), ",", ".") & "," & Replace(p2ucs(1), ",", ".")
ThisDrawing.SendCommand ("_Break " & strP0 & " _f " & strP1 & vbCr & strP2 & vbCr)
objBlockRef.Visible = True
End If
SelSet1.Delete
'Anpassen der Darstellung
Dim sSymbolfarbe As String
Dim sLinienbreite As String
Select Case ObjektGewerk(objBlockRef)
Case "Heizung"
sSymbolfarbe = GetTGA2006Var("SYMCOLH")
sLinienbreite = GetTGA2006Var("SYMWIDH")
Case "Lüftung"
sSymbolfarbe = GetTGA2006Var("SYMCOLL")
sLinienbreite = GetTGA2006Var("SYMWIDL")
Case "Sanitär"
sSymbolfarbe = GetTGA2006Var("SYMCOLS")
sLinienbreite = GetTGA2006Var("SYMWIDS")
Case "Brandschutz"
sSymbolfarbe = GetTGA2006Var("SYMCOLB")
sLinienbreite = GetTGA2006Var("SYMWIDB")
Case "Elektro"
sSymbolfarbe = GetTGA2006Var("SYMCOLE")
sLinienbreite = GetTGA2006Var("SYMWIDE")
Case "MSR"
sSymbolfarbe = GetTGA2006Var("SYMCOLM")
sLinienbreite = GetTGA2006Var("SYMWIDM")
Case "Architektur"
sSymbolfarbe = GetTGA2006Var("SYMCOLA")
sLinienbreite = GetTGA2006Var("SYMWIDA")
Case "Divers"
sSymbolfarbe = GetTGA2006Var("SYMCOLD")
sLinienbreite = GetTGA2006Var("SYMWIDD")
Case Else
sSymbolfarbe = acByLayer
End Select
If sSymbolfarbe = "" Then sSymbolfarbe = acByLayer
If sLinienbreite = "" Then sLinienbreite = "Vorgabe"
sLinienbreite = GetTGA2006Var("SYMWID")
With objBlockRef
.color = sSymbolfarbe
.LineWeight = sLinienbreite
End With
End If
End Sub
Foren auf CAD.de
| 
- 
