Liebes Forum,
Ich habe mir vor einigen Tagen ein Makro abgeändert, welches ich hier im Forum gefunden habe (danke an Andreoid https://ww3.cad.de/foren/ubb/Forum2/HTML/033979.shtml)
Ziel war es, ein Makro zu schaffen, welches mir auf Knopfdruck den Eigenschaftsnamen "Bauteil ID Lieferant" gegen den Namen "Bauteilnummer" ersetzt (Werteinträge müssen erhalten bleiben!), und das in jeder Konfiguration (also konfigurationsspezifische Eigenschaft) und wenn nicht vorhanden dann als leeren Wert anlegt.
Hat bis gestern auch funktioniert, aber heute will das Ding nicht mehr funktionieren und bleibt in der Zeile "For i = 0 To UBound(varCustomPropNames)" 'hängen'. Habe keine Ahnung warum???
Habe dazu ein Testteil gemacht, an dem ich es testen kann (Screenshot von beiden Teilen im Anhang).
Habe es gerade probeweise an einem Teil versucht, bei dem es bereits funktioniert hat - und - oh Wunder, es geht. Bei dem Testteil aber nicht. Beide Teile haben verschiedene Konfigurationen und auch Unterkonfigurationen. Keine Ahnung wie und warum sich die beiden Teile unterscheiden, bzw. was da faul ist .....
Ich möchte das Makro dann soweit ausbauen, dass ich den zu ersetzenden Namen und den neuen Namen über eine Textbox eingeben kann, aber das ist noch etwas weit entfernt......
Ich wäre dankbar für einen Erklärversuch. Muss dazusagen, dass ich mich in VB eigentlich nicht auskenne und das meiste über codeschnipsel & try&error zusammenbastle.....
Code Anfang ##############################
'###################################################################################################
'### Dieses Makro soll den Eigenschaftswert Bauteilnummer in allen Konfigurationen nachtragen
'###################################################################################################
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swModelDocExt As ModelDocExtension
Dim swCustPropMgr As CustomPropertyManager
Dim Part As Object
Dim InfoCount As Long
Dim InfoNames As Variant
Dim InfoValue As Variant
Dim DelName As String
Dim Conf As Object
Dim ConfName As String
Dim ConfEinlesen As Long
Dim FirstConfName As String
Dim test As String
Dim test_1 As String
Dim Value As String
Dim Value_var As String
Dim K As Integer
Dim varKonfigNames As Variant
Dim varCustomPropNames As Variant
Dim varCustomPropTypes As Variant
Dim varCustomPropValues As Variant
Dim varCustomPropResolved As Variant
Dim varCustomPropLinked As Variant
Dim strCustomPropValue As String
Dim strCustomPropResValue As String
Dim strCustomPropNewName As String
Dim boolstatus As Boolean
Dim lWarnings As Long
Dim i As Integer
Dim j As Integer
Dim iCounter As Integer
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim fileext As Integer
Dim p_data(4, 2) As Variant
' Dim p_data(1, 2) As Variant
' Hier werden die Solidworkssystem Variablen bestimmt
p_data(1, 1) = "Bauteilnummer"
p_data(1, 2) = "Bauteil ID Lieferant"
' p_data(2, 1) = "NEU_Gewicht"
' p_data(2, 2) = "SW-Mass"
' p_data(3, 1) = "NEU_Volumen"
' p_data(3, 2) = "SW-Volume"
' p_data(4, 1) = "NEU_Dichte"
' p_data(4, 2) = "SW-Density"
' If MsgBox("Sind alle Komponenten ausgecheckt?", vbYesNo, "Hinweis") = vbNo Then
If MsgBox("Wirklich die Eigenschaften von #Bauteil ID Lieferant# in #Bauteilnummer# ändern?", vbYesNo, "Hinweis") = vbNo Then
Exit Sub
Else
If Part Is Nothing Then
MsgBox "Keine Datei vorhanden", vbCritical, "Makro - Dateieigenschaften löschen"
Else
'Dateiendung ermitteln
fileext = Extension2Type(Part.GetPathName)
If fileext = 0 Then
MsgBox "Die SOLIDWOKS-Datei ist noch nicht gespeichert", vbExclamation, "Makro - Dateieigenschaften löschen"
Else
suchen_und_ersetzen
' deleteprozess swApp, Part, p_data ' löscht die Eigenschaftsparameter
AddCustPrps swApp, Part, p_data
Debug.Print "Assembly, Part and Drawing"
End If
End If
End If
' MsgBox "Alle Bauteil ID Lieferant_ Eigenschaften sind geändert" & vbCrLf & "" & vbCrLf & "NEU_Dichte" & vbCrLf & "NEU_Gewicht" & vbCrLf & "NEU_Werkstoff" & vbCrLf & "NEU_Volumen sind nachgetragen"
MsgBox "Alle Bauteil ID Lieferant_ Eigenschaften sind korrigiert"
End Sub
Sub suchen_und_ersetzen()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swModelDocExt = swModel.Extension
varKonfigNames = swModel.GetConfigurationNames
ReDim Preserve varKonfigNames(UBound(varKonfigNames) + 1)
For j = 0 To UBound(varKonfigNames)
Set swCustPropMgr = swModelDocExt.CustomPropertyManager(varKonfigNames(j))
lWarnings = swCustPropMgr.GetAll3(varCustomPropNames, varCustomPropTypes, varCustomPropValues, varCustomPropResolved, varCustomPropLinked)
For i = 0 To UBound(varCustomPropNames)
boolstatus = swCustPropMgr.Get3(varCustomPropNames(i), True, strCustomPropValue, strCustomPropResValue)
' If InStr(1, varCustomPropNames(i), "ALT_", vbTextCompare) > 0 Then
If InStr(1, varCustomPropNames(i), "Bauteil ID Lieferant", vbTextCompare) > 0 Then ' schauen, wie oft der Suchstring vorhanden ist
' strCustomPropNewName = Replace(varCustomPropNames(i), "ALT_", "NEU_")
strCustomPropNewName = Replace(varCustomPropNames(i), "Bauteil ID Lieferant", "Bauteilnummer") ' Suchstring gegen neuen Text ersetzen
lWarnings = swCustPropMgr.Add3(strCustomPropNewName, varCustomPropTypes(i), strCustomPropValue, swCustomPropertyOnlyIfNew)
lWarnings = swCustPropMgr.Delete2(varCustomPropNames(i))
End If
Next i
Next j
swModel.SetSaveFlag
End Sub
'entfernt ALLE NICHT mit "NEU_" beginnenden Benutzereigenschaften --> deaktiviert spary
'Sub deleteprozess(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, p_data As Variant)
'Set swApp = GetObject(, "SldWorks.Application")
'Set Part = swApp.ActiveDoc
'If Not Part Is Nothing Then
' InfoCount = Part.GetCustomInfoCount2("") ' wieviele Benutzerdef. Eigenschaften im akt. Teil?
' InfoNames = Part.GetCustomInfoNames2("") ' Alle Namen der Benutzerdef. Eigenschaften in ein Variant einlesen
' For K = 0 To InfoCount - 1 ' Schleife durch alle Benutzerdef. Eigenschaften
' If Left(InfoNames(K), 4) <> "NEU_" Then ' Or Left(InfoNames(K),1) = "NEU_" Then
' Retval = Part.DeleteCustomInfo2("", InfoNames(K)) ' Löschen aller Eigenschaften
' End If
' Next K
' numConfigs = Part.GetConfigurationCount()
' Names = Part.GetConfigurationNames()
' For i = 0 To numConfigs - 1 ' Schleife Durch alle Konfigurationen
' Konfigurationsspezifischen fieldNames auslesen
' InfoCount = Part.GetCustomInfoCount2(Names(i)) ' wieviele konf. Eigenschaften in der akt. Konfiguration?
' InfoNames = Part.GetCustomInfoNames2(Names(i)) ' Alle Namen der Konf. Eigenschaften in ein Variant einlesen
' For K = 0 To InfoCount - 1 ' Schleife durch alle konf. Eigenschaften
' If Left(InfoNames(K), 4) <> "NEU_" Then
' Retval = Part.DeleteCustomInfo2(Names(i), InfoNames(K)) ' Löschen aller Eigenschaften
' End If
' Next K
' Next i
'End If
'Set Part = Nothing
'Set swApp = Nothing
'End Sub
'Setze Dateieigenschaften Masse, Volumen, Material fuer SLDASM, SLDPRT and SLDDRW --> deaktiviert spary
Sub AddCustPrps(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, p_data As Variant)
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim vConfs As Variant
Dim i As Integer
Dim sFullpath As String
Dim sFilename As String
'Dateipfad ermitteln
sFullpath = swModel.GetPathName
'Dateiname
sFilename = Mid(sFullpath, InStrRev(sFullpath, "\") + 1, Len(sFullpath))
'Get all custom properties; Date added is the last one in the list
Dim vNameArr As Variant
Dim vName As Variant
'Default-Config
Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
For iCounter = 1 To UBound(p_data)
Debug.Print (p_data(iCounter, 1) & " " & p_data(iCounter, 2))
swCustPropMgr.Add2 p_data(iCounter, 1), swCustomInfoText, """" & p_data(iCounter, 2) & "@" & sFilename & """"
Next iCounter
vConfs = swModel.GetConfigurationNames
'All Configs
For i = 0 To UBound(vConfs)
Set swCustPropMgr = swModel.Extension.CustomPropertyManager(vConfs(i))
For iCounter = 1 To UBound(p_data)
Debug.Print (p_data(iCounter, 1) & " " & p_data(iCounter, 2))
swCustPropMgr.Add2 p_data(iCounter, 1), swCustomInfoText, """" & p_data(iCounter, 2) & "@@" & vConfs(i) & "@" & sFilename & """"
Next iCounter
Next
End Sub
'Dateityp ermitteln
Function Extension2Type(ByVal strFileName As String) As swDocumentTypes_e
Dim strExtension As String
Extension2Type = swDocumentTypes_e.swDocNONE
strExtension = Right(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
strExtension = LCase(strExtension)
Select Case (strExtension)
Case "sldprt"
Extension2Type = swDocumentTypes_e.swDocPART
Case "sldasm"
Extension2Type = swDocumentTypes_e.swDocASSEMBLY
Case "slddrw"
Extension2Type = swDocumentTypes_e.swDocDRAWING
End Select
End Function
Code Ende ##################################
Vielen Dank
Bernhard
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
