Hallo liebe Gemeinde,
Ich möchte in einer Zeichnung per Makro einen Bezugshinweis mit Führungslinie und Pfeil so einfügen, dass die Pfeilspitze exakt auf dem Einfügepunkt der selektierten Blockinstanz liegt und der Text dann zur freien Platzierung am Gummiband hängt.
Hintergrund-Info: Ich lese mit dem Makro ein Attribut aus der selektierten Blockinstanz aus und möchte den Inhalt individuell platzieren.
Das Makro funktionert soweit, allerdings werden die Pfeile immer nur auf den Punkt gelegt, den ich bei der Block-Auswahl im Zeichenbereich angeklickt habe. Und der liegt meistens weit daneben.
Kann jemand helfen?
Hier der Code:
_________________________________________________________
Sub make_Block_POS()
'Variablendefinition
Dim swDraw As Object
Dim swDocNamePath As String
Dim swDocNameCut As String
Dim swDocName As String
Dim SwSketchMgr As Object
Dim swBlockDef As Object
Dim swBlockInst As Object
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim swAttArr As Variant
Dim swAtt As Object
Dim t As Integer
Dim drwScale As Double
Dim posArrowX As Double
Dim posArrowY As Double
Dim posBaloonX As Double
Dim posBaloonY As Double
Dim myNote As Object
Dim myAnnotation As Object
Dim myPoint As Object
Dim myTextFormat As Object
Dim swBlockInstName As String
Dim myPos As String
Dim params As Variant
Dim FilterOn As Long
Dim firstRun As Boolean
'Initialisierung
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swModel = swApp.ActiveDoc
Set swDraw = swDoc
Set swSelMgr = swDoc.SelectionManager
'Prüfen, ob Soliworks Datei geöffnet
If swDraw Is Nothing Then
MsgBox "No file loaded!", vbOKOnly, "Fehler"
Exit Sub
End If
'Prüfen, ob Datei eine ist Zeichnung
If swDraw.GetType <> 3 Then
MsgBox "No Drawing loaded!", vbOKOnly, "Fehler"
Exit Sub
End If
'Prüfen ob Zeichnung gespeichert wurde
If (swApp.ActiveDoc.GetPathName = "") Then
MsgBox ("Please save your document first!")
Exit Sub
End If
'Dateiname ohne Endung aus Pfad heraustrennen
swDocNamePath = swApp.ActiveDoc.GetPathName
swDocNameCut = Left(swDocNamePath, Len(swDocNamePath) - 7)
swDocName = Mid$(swDocNameCut, InStrRev(swDocNameCut, "\") + 1)
'Start Skizzenmanager
Set SwSketchMgr = swDoc.SketchManager
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
'Nur Wenn Blöcke vorhanden
If Not IsEmpty(vBlockDef) Then
'Flag für ersten Durchlauf
firstRun = True
WaitLoop:
firstRun = True 'Immer True, bis bessere Lösung gefunden wurde
'Aktuelle Auswahlfilter merken und zurücksetzen
FilterOn = swApp.GetApplySelectionFilter
params = swApp.GetSelectionFilters
swApp.SetSelectionFilters params, False
'Block-Filter aktivieren
swApp.SetSelectionFilter 114, True 'swSelSUBSKETCHINST = 114
'+++++++++++++++++++ Warten auf Block-Auswahl +++++++++++++++++++++++++++++++++
If (swSelMgr.GetSelectedObjectCount2(-1) <> 1) Or (swSelMgr.GetSelectedObjectType3(1, -1) <> 114) Then
'Diese MessageBox nur beim ersten Durchgang anzeigen
If firstRun = True Then
nUserCancel = MsgBox("Select BLOCK or CANCEL to exit", vbOKCancel)
If nUserCancel = vbCancel Then
'Set previous selection filters
swApp.SetSelectionFilters (params), True
swApp.SetApplySelectionFilter FilterOn
Exit Sub
End If
End If
swDoc.ClearSelection2 True
While (swSelMgr.GetSelectedObjectCount <> 1) Or (swSelMgr.GetSelectedObjectType3(1, -1) <> 114)
If swSelMgr.GetSelectedObjectCount = 1 And swSelMgr.GetSelectedObjectType3(1, -1) <> 114 Then
'falsche Auswahl
nUserCancel = MsgBox("Select BLOCK or CANCEL to exit", vbOKCancel)
If nUserCancel = vbCancel Then
'Set previous selection filters
swApp.SetSelectionFilters (params), True
swApp.SetApplySelectionFilter FilterOn
Exit Sub
End If
swDoc.ClearSelection2 True
Else
'richtige Auswahl
DoEvents
End If
Wend
End If
'Set previous selection filters
swApp.SetSelectionFilters (params), True
swApp.SetApplySelectionFilter FilterOn
'+++++++++++++++++++ Auswahl ist erfolgt +++++++++++++++++++++++++++++++++
'Name der selektierten Block-Instanz holen
Set swSelMgr = swDoc.SelectionManager
Set swBlockInst = swSelMgr.GetSelectedObject6(1, 0)
swBlockInstName = swBlockInst.Name
Debug.Print "2. Ausgewählte Block-Instanz: " & swBlockInstName
'Position der Block instance
Set insPt = swBlockInst.InstancePosition
vInstPt = insPt.ArrayData
strInsPoint = "InsertPoint: x=" + CStr(vInstPt(0) * 1000) + " , y=" + CStr(vInstPt(1) * 1000) + " , z = " + CStr(vInstPt(2) * 1000)
Debug.Print "6. " & strInsPoint
'Attribut "POS" suchen und auslesen
swAttArr = swBlockInst.GetAttributes
If Not IsEmpty(swAttArr) Then
For t = 0 To UBound(swAttArr)
Set swAtt = swAttArr(t)
If swAtt.TagName = "POS" Then
myPos = swAtt.GetText
Debug.Print " Attribut Name: " & swAtt.TagName
Debug.Print " Attribut Wert: " & swAtt.GetText
End If
Next t
End If
'Einfügekoordinaten festlegen
drwScale = 1
posBaloonX = CStr(vInstPt(0)) / drwScale - 0.01
posBaloonY = CStr(vInstPt(1)) / drwScale + 0.01
posArrowX = CStr(vInstPt(0))
posArrowY = CStr(vInstPt(1))
'+++++++++++++++++++ Note einfügen +++++++++++++++++++++++++++++++++
Set myNote = swModel.InsertNote(myPos)
If Not myNote Is Nothing Then
myNote.LockPosition = False
myNote.Angle = 0
boolstatus = myNote.SetBalloon(1, 0)
Set myAnnotation = myNote.GetAnnotation()
If Not myAnnotation Is Nothing Then
longstatus = myAnnotation.SetLeader3(True, 0, True, False, False, False)
boolstatus = myAnnotation.SetPosition(posBaloonX, posBaloonY, 0)
boolstatus = myAnnotation.SetTextFormat(0, True, myTextFormat)
End If
End If
swModel.ClearSelection2 True
swModel.WindowRedraw
End If
'Routine wiederholen, bis Benutzer-Abbruch
firstRun = False
GoTo WaitLoop
End Sub
------------------
Lieber Gruß vom mechanikuss
[Diese Nachricht wurde von mechanikuss am 20. Okt. 2020 editiert.]
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
