Code:
Option ExplicitSub Stückliste()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
If oApp.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
MsgBox "Funktion ist nur in Zeichnungen zulässig"
Exit Sub
End If
Dim oDrawDoc As Inventor.DrawingDocument
Set oDrawDoc = oApp.ActiveDocument
Dim sPath As String, sFileName As String, sTXTFileName As String
'Pfad anpassen
sPath = "C:\Temp\"
' sPath = "W:\000000_Transfer\CAD-Miclas X\" 'wenn diese Zeile nicht mehr auskommentiert ist, sollte es passen!
If oDrawDoc.ActiveSheet.PartsLists.Count = 0 Then
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
Exit Sub
ElseIf oDrawDoc.ActiveSheet.PartsLists.Count > 1 Then
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
End If
Dim oPartslist As PartsList
Set oPartslist = oDrawDoc.ActiveSheet.PartsLists.Item(1)
Dim oRefedDoc As Document
Set oRefedDoc = oPartslist.ReferencedDocumentDescriptor.ReferencedDocument
Dim vArtikel As Variant, vBezeichnung As Variant
vArtikel = ReadCustomiProperty(oRefedDoc, "Z_Artikel Nr.") ' ### ggf. Name anpassen!
vBezeichnung = ReadCustomiProperty(oRefedDoc, "Z_Bezeichnung1")
If IsNull(vArtikel) Or IsNull(vBezeichnung) Then
MsgBox "iProp 'Z_Artikel Nr.' und/oder 'Z_Bezeichnung1' existiert nicht!", vbInformation + vbOKOnly, "leeres iProp - Abbruch"
Exit Sub
End If
sFileName = vArtikel & "_" & vBezeichnung & ".xlsx" 'Trennzeichen ggf. anpassen
sFileName = clear_DatName(sFileName) 'Function unten, Konformität f. Dateiname herstellen
sTXTFileName = sPath & sFileName
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(sPath) Then MkDir sPath
Call oPartslist.Export(sTXTFileName, kMicrosoftExcel) 'geändert auf Excel (und Variable oPartslist benutzt)
End Sub
Private Sub test_MsgBoxen()
MsgBox "Funktion ist nur in Zeichnungen zulässig"
MsgBox "Keine Stückliste vorhanden!", vbCritical + vbOKOnly, "Stückliste fehlt"
MsgBox "Es sind mehrere Stücklisten vorhanden!" & vbCrLf & "Es wird die erste Stückliste verwendet!", vbOKOnly + vbInformation, "Mehrere Stücklisten"
MsgBox "iProp Author in Datei " & vbCrLf & "oRefedDoc.FullDocumentName" & vbCrLf & " ist leer. Abbruch", vbCritical, "leeres iProp"
End Sub
Public Function ReadCustomiProperty(ByRef doc As Document, _
ByRef PropertyName As String, _
Optional forceStringReturn As Boolean = False) As Variant
'Wert aus iProp lesen
' forceStringReturn: gibt "" zurück, (statt Null) auch wenn Prop. nicht existiert
'Default-Rückgabewert (wenn Prop nicht existiert)
If forceStringReturn Then ReadCustomiProperty = "" Else ReadCustomiProperty = Null
'raus, wenn doc nicht gesetzt ist
If doc Is Nothing Then Exit Function
'Rueckgabe mit Defaultwert
' Get the custom property set.
Dim customPropSet As PropertySet
' Set customPropSet = doc.PropertySets.Item("Inventor User Defined Properties")
Set customPropSet = doc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}") 'internalName
' Get the existing property, if it exists.
Dim prop As Property
On Error Resume Next
Set prop = customPropSet.Item(PropertyName)
' Check to see if the above call failed. If it failed
' then the property doesn't exist.
If Err.Number <> 0 Then
' Failed to get the existing property
If False = forceStringReturn Then ' keine Meldung bei forceStringReturn
' MsgBox "iProperty existiert nicht!" & vbCrLf _
' & PropertyName, vbCritical, "Fkt. ReadCustomiProperty"
End If
Else
'Prop existiert, Wert lesen
ReadCustomiProperty = prop.Value
End If
On Error GoTo 0
End Function
Function clear_DatName(str As String) As String
' wandelt einen gegebenen Text in einen "konformen Text"
' dieser neue Wert wird zurückgegeben
' ### nach Wunsch anpassen
' Zeilen auskommentieren, wenn ein Zeichen nicht ersetzt werden soll
Dim name_alt As String
Dim name_neu As String
name_alt = str
name_neu = str
name_neu = Replace(name_neu, " ", "_") 'alle Leerz. ersetzen
'name_neu = Replace(name_neu, "-", "_") 'Bindestriche ersetzen
name_neu = Replace(name_neu, ",", "_")
name_neu = Replace(name_neu, "ä", "ae") 'Umlaute...
name_neu = Replace(name_neu, "Ä", "Ae")
name_neu = Replace(name_neu, "ö", "oe")
name_neu = Replace(name_neu, "Ö", "Oe")
name_neu = Replace(name_neu, "ü", "ue")
name_neu = Replace(name_neu, "Ü", "Ue")
name_neu = Replace(name_neu, "ß", "ss")
name_neu = Replace(name_neu, "^", "_")
name_neu = Replace(name_neu, "°", "_")
name_neu = Replace(name_neu, """", "_") 'Anführungszeichen (")
'name_neu = Replace(name_neu, "§", "_")
'name_neu = Replace(name_neu, "$", "_")
'name_neu = Replace(name_neu, "%", "_")
'name_neu = Replace(name_neu, "&", "_")
name_neu = Replace(name_neu, "/", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, "\", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, "=", "_")
name_neu = Replace(name_neu, "?", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, "*", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, "~", "_")
name_neu = Replace(name_neu, "<", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, ">", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, "|", "_") ' nicht für Dateinamen zugelassen
name_neu = Replace(name_neu, ":", "_") ' nicht für Dateinamen zugelassen
'name_neu = Replace(name_neu, "[", "(")
'name_neu = Replace(name_neu, "]", ")")
dErsetzen name_neu 'Sub, doppelte __ ersetzen, rekursiv
'Rückgabewert
clear_DatName = name_neu
End Function
Private Sub dErsetzen(ByRef txt)
' doppelte Unterstriche "__" werden durch einfache "_" ersetzt
' rekursiv
If Not (0 = InStr(txt, "__")) Then
txt = Replace(txt, "__", "_") 'doppelte __ ersetzen
End If
If Not (0 = InStr(txt, "__")) Then dErsetzen txt 'Rekursion
End Sub
Foren auf CAD.de (alle Foren)
| 
