Hallo zusammen,
wir verwenden für unsere Konstruktion von Stanz und Umformwerzeugen eine Masterskizze mit der wir unsere Werkzeuge steuern.
Die Masterskizze besteht aus vielen einzelnen Skizzen für Außenmaße, Verschraubungen, Stiftpositionen usw (siehe Bild). Diese einzelnen Skizzen leiten wir dann in die entsprechenden Platten ab und verwenden diese dann für weitere Bearbeitungen. Die Vorgehensweise ist immer die selbe, zuerst werden in der Baugruppe die einzelnen Skizzen in die entsprechenden Platten abgeleitet. Anschließend werden die einzelnen Platten geöffnet, die Abgeleitete Skizze wird umbenannt (da sie ja nur Skizze.. heißt) und bekommt den gleichen Namen wie die Skizze aus der Masterskizze. Zum Schluss wird die Skizze noch verknüpft damit sie nicht mehr verschoben werden kann. Jede einzelne Skizze hat eine Mittellinie (Konstruktionslinie) wo der linke Punkt der Linie mit der Ebene Rechts Deckungsgleich und die Linie selbst mit der Eben Vorne Kollinear verknüpft wird. Ich versuche die letzten beiden Schritte, Skizze umbenennen und Verknüpfen, per Makro zu lösen. Das Umbenennen bekomme ich hin aber das Verknüpfen nicht. Wie kann ich das in dem Makro lösen?
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModDocExt As SldWorks.ModelDocExtension
Dim swSelMgr As SldWorks.SelectionMgr
Dim swFeat As SldWorks.Feature
Dim swComp As SldWorks.Component2
Dim vModelPathName As Variant
Dim vComponentPathName As Variant
Dim vFeature As Variant
Dim vDataType As Variant
Dim vStatus As Variant
Dim vRefEntity As Variant
Dim vFeatComp As Variant
Dim nConfigOpt As Long
Dim sConfigName As String
Dim nRefCount As Long
Dim nSelType As Long
Dim i As Long
Dim boolstatus As Boolean
Dim NeuerName As String
Dim swSketch As SldWorks.Sketch
Dim bValue As Boolean
Dim swSketchMgr As SldWorks.SketchManager
Sub main()
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Es ist kein Einzelteil geöffnet!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
If (swModel.GetType <> swDocPART) Then
swApp.SendMsgToUser2 "Dieses Makro funktioniert nur bei Einzelteilen!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
Set swSelMgr = swModel.SelectionManager
Set swModDocExt = swModel.Extension
nSelType = swSelMgr.GetSelectedObjectType3(1, -1)
Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
If swFeat Is Nothing Then
swApp.SendMsgToUser2 "Bitte erst die Abgeleitete Skizze makieren die umbenannt werden sollen!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
Debug.Print "Model name = " + swModel.GetPathName
nSelType = swSelMgr.GetSelectedObjectType3(1, -1)
nRefCount = swModDocExt.ListExternalFileReferencesCount
swModDocExt.ListExternalFileReferences vModelPathName, vComponentPathName, vFeature, vDataType, vStatus, vRefEntity, vFeatComp, nConfigOpt, sConfigName
Debug.Print " Reference count = " + Str(nRefCount)
'MsgBox nRefCount
If nRefCount = 0 Then
swApp.SendMsgToUser2 "Es kann nichts umbenannt werden da dies keine Abgeleitete Skizze ist!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
If vComponentPathName(i) = "" Then
swApp.SendMsgToUser2 "Die Baugruppe muss im Hintergrund geöffnet sein sonst kann die Abgeleitete Skizze nicht umbenannt werden!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
Select Case nSelType
' Selected component in an assembly document
Case swSelCOMPONENTS
Set swComp = swSelMgr.GetSelectedObjectsComponent3(1, -1)
nRefCount = swComp.ListExternalFileReferencesCount
swComp.ListExternalFileReferences2 vModelPathName, vComponentPathName, vFeature, vDataType, vStatus, vRefEntity, vFeatComp, nConfigOpt, sConfigName
Set swModel = swComp.GetModelDoc2
' Selected feature in a part or assembly document
Case swSelBODYFEATURES, swSelSKETCHES
Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
nRefCount = swFeat.ListExternalFileReferencesCount
swFeat.ListExternalFileReferences2 vModelPathName, vComponentPathName, vFeature, vDataType, vStatus, vRefEntity, vFeatComp, nConfigOpt, sConfigName
' Part document only
Case Else
nRefCount = swModDocExt.ListExternalFileReferencesCount
swModDocExt.ListExternalFileReferences vModelPathName, vComponentPathName, vFeature, vDataType, vStatus, vRefEntity, vFeatComp, nConfigOpt, sConfigName
End Select
If nRefCount = 0 Then
swApp.SendMsgToUser2 "Es kann nichts umbenannt werden da dies keine Abgeleitete Skizze ist!", swMbInformation, swMbOk
ClearObjects
Exit Sub
End If
Debug.Print " Component path + name = " + vComponentPathName(i)
Debug.Print "Model name = " + swModel.GetPathName
Debug.Print " Reference count = " + Str(nRefCount)
Debug.Print ""
'For i = 0 To nRefCount - 1
Debug.Print " Model path + name = " + vModelPathName(i)
Debug.Print " Component path + name = " + vComponentPathName(i)
Debug.Print " Feature = " + vFeature(i)
Debug.Print " Data type = " + vDataType(i)
Debug.Print " Status = " + Str(vStatus(i))
Debug.Print " Reference entity = " + vRefEntity(i)
Debug.Print " Feature component = " + vFeatComp(i)
Debug.Print " Configuration option = " & nConfigOpt
Debug.Print " Configuration name = " & sConfigName
Debug.Print " "
NeuerName = vRefEntity(i)
'MsgBox NeuerName
NeuerName = Left(NeuerName, VBA.InStr(1, NeuerName, "von") - 2)
'MsgBox NeuerName
boolstatus = swModel.Extension.SelectByID2(vFeature(i), "BODYFEATURE", 0, 0, 0, False, 0, Nothing, 0)
boolstatus = swModel.SelectedFeatureProperties(0, 0, 0, 0, 0, 0, 0, 1, 0, NeuerName)
swModel.ClearSelection2 True
Set swSketchMgr = swModel.SketchManager
bValue = swModel.Extension.SelectByID2(NeuerName, "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
swSketchMgr.InsertSketch False
Set swSketch = swModel.GetActiveSketch2
' Skizze Verknüpfen?????
swSketchMgr.InsertSketch True
'Next i
ClearObjects
End Sub
Function ClearObjects()
Set swApp = Nothing
Set swModel = Nothing
Set swSelMgr = Nothing
Set swModDocExt = Nothing
Set swFeat = Nothing
End Function
Vielen Dank
Gruß Stefan
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP