Hallo,
also mir würde nur der Weg über ein Makro einfallen
siehe dazu das Makro im Anhang
Wichtig:
es muss ein Verweis auf "Microsoft XML, v3.0"
im Makro eingefügt werden
'***************************************************
Option Explicit
Private Function GetMaterialAttribute(Materil2Search As String, MatAttribute As String, MaterialDB As String) As String
Dim objXML As MSXML2.DOMDocument
Dim ok As Boolean
Dim lists As MSXML2.IXMLDOMNodeList
Dim i As Integer
Set objXML = New DOMDocument
objXML.SetProperty "SelectionLanguage", "XPath"
ok = objXML.Load(MaterialDB)
Set lists = objXML.selectNodes("//*/material[@name ='" & Materil2Search & "']")
If lists.Length > 0 Then
If lists.Length = 1 Then
If Not lists(0).Attributes.getNamedItem(MatAttribute) Is Nothing Then
GetMaterialAttribute = lists(0).Attributes.getNamedItem(MatAttribute).nodeValue
Exit Function
End If
End If
End If
GetMaterialAttribute = ""
End Function
Function GetMaterial() As String
Dim swApp As SldWorks.SldWorks
Dim doc As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim sMatDB As String
Dim swConfig As SldWorks.Configuration
Set swApp = Application.SldWorks
Set doc = swApp.ActiveDoc
If doc Is Nothing Then
GetMaterial = ""
Exit Function
End If
If doc.GetType = swDocumentTypes_e.swDocPART Then
Set swPart = doc
Set swConfigMgr = swPart.ConfigurationManager
Set swConfig = swConfigMgr.ActiveConfiguration
GetMaterial = swPart.GetMaterialPropertyName2(swConfig.Name, sMatDB)
Else
GetMaterial = ""
End If
End Function
Function GetMaterialDBFileName() As String
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim dbs As Variant
Dim sMatName As String
Dim sMatDB As String
Dim i As Long
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swPart = swModel
dbs = swApp.GetMaterialDatabases
sMatName = swPart.GetMaterialPropertyName2("Default", sMatDB)
For i = 0 To UBound(dbs)
If UCase(Mid(dbs(i), InStrRev(dbs(i), "\") + 1, Len(dbs(i)))) = UCase((sMatDB + ".sldmat")) Then
GetMaterialDBFileName = dbs(i)
Exit Function
End If
Next i
GetMaterialDBFileName = ""
End Function
Sub GetMaterialInfo()
Dim Material As String
Dim MaterialDB As String
Dim beschreibung As String
Dim Quelle As String
Material = GetMaterial
MaterialDB = GetMaterialDBFileName
beschreibung = GetMaterialAttribute(Material, "description", MaterialDB)
Quelle = GetMaterialAttribute(Material, "propertysource", MaterialDB)
MsgBox "Material: " & Material & Chr(10) & "Beschreibung: " & beschreibung & Chr(10) + "Quelle: " & Quelle, vbOKOnly, "Meldung"
End Sub
------------------
Grüße
Heinz
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP