Code:
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
' Hier werden die Solidworkssystem Variablen bestimmt
p_data(1, 1) = "NEU_Werkstoff"
p_data(1, 2) = "SW-Material"
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
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
AddCustPrps swApp, Part, p_data
Debug.Print "Assembly, Part and Drawing"
End If
End If
End If
MsgBox "Alle NICHT - NEU_ Eigenschaften sind gelöscht" & vbCrLf & "" & vbCrLf & "NEU_Dichte" & vbCrLf & "NEU_Gewicht" & vbCrLf & "NEU_Werkstoff" & vbCrLf & "NEU_Volumen sind nachgetragen"
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
strCustomPropNewName = Replace(varCustomPropNames(i), "ALT_", "NEU_")
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
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
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