Moin,
ich habe Dir mal einen Screenshot des Zeichnungskopfes gemacht.
Steht alles in den Eigenschaften der Zeichnung (iProps der Zeichnung).
Der Code sollte die Werte in das Feld schreiben!
So sieht der gesamte Code aus.
'---------------------------------------------------------------------------------------------
'--------------------------iPobs löschen und Modell mit Zeichnung kopieren
'---------------------------------------------------------------------------------------------
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub CopyDrawingWithReferenceReplace()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
'---------------------------------------------------------------------------------------------
'--------------------------die Zeichnung muss geöffnet sein-----------------------------------
'---------------------------------------------------------------------------------------------
If Not oApp.ActiveDocumentType = kDrawingDocumentObject Then
MsgBox "aktive Zeichnung erforderlich", vbCritical
Exit Sub
End If
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = oApp.ActiveDocument
'--------------------------------------------------------------------------------------------
'------------------Only one referenced document is allowed-----------------------------------
'--------------------------------------------------------------------------------------------
If Not oDrawDoc.File.ReferencedFileDescriptors.Count = 1 Then
MsgBox "Nur 1 referenziertes Modell pro Zeichnung zulässig.", vbCritical
Exit Sub
End If
Dim sNewName As String
Dim sOldName As String
If Not oDrawDoc.FullFileName = "" Then
sOldName = Left$(oDrawDoc.FullFileName, Len(oDrawDoc.FullFileName) - 4)
End If
Dim oFileDialog As Inventor.FileDialog
Call oApp.CreateFileDialog(oFileDialog)
'---------------------------------------------------------------------------------------------
'------------------------------Zeichnung neu kopieren-----------------------------------------
'---------------------------------------------------------------------------------------------
oFileDialog.FilterIndex = 1
oFileDialog.CancelError = True
oFileDialog.Filter = "Inventor Files (*.idw)|*.idw|All Files (*.*)|*.*"
oFileDialog.DialogTitle = "Save Drawing Copy"
oFileDialog.FileName = sOldName & "_COPY.idw"
On Error Resume Next
oFileDialog.ShowSave
If Err Then
Exit Sub
ElseIf oFileDialog.FileName <> "" Then
sNewName = oFileDialog.FileName
On Error GoTo 0
End If
Call oDrawDoc.SaveAs(sNewName, False)
Dim oRefedDoc As Document
Set oRefedDoc = oDrawDoc.ReferencedDocuments.Item(1)
Dim sNewModelCopyName As String
sNewModelCopyName = CopyRefedDoc(oRefedDoc, sNewName)
If sNewModelCopyName = "" Then
MsgBox "Modell kopieren fehlgeschlagen.", vbCritical
Exit Sub
End If
Dim oFileDesc As FileDescriptor
Set oFileDesc = oDrawDoc.File.ReferencedFileDescriptors.Item(1)
oFileDesc.ReplaceReference (sNewModelCopyName)
End Sub
Private Function CopyRefedDoc(ByVal oRefedDoc As Document, ByVal sNewName As String) As String
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim sOldName As String
If Not oRefedDoc.FullFileName = "" Then
sOldName = Left$(oRefedDoc.FullFileName, Len(oRefedDoc.FullFileName) - 4)
End If
Dim oFileDialog As Inventor.FileDialog
Call oApp.CreateFileDialog(oFileDialog)
oFileDialog.FilterIndex = 1
oFileDialog.CancelError = True
Select Case oRefedDoc.DocumentType
Case kPartDocumentObject:
'----------------------------------------------------------------------------------------------
'------------------MsgBox "Part"---------------------------------------------------------------
'----------------------------------------------------------------------------------------------
Dim oPartDoc As PartDocument
Set oPartDoc = oRefedDoc
oFileDialog.Filter = "Inventor Files (*.ipt)|*.ipt|All Files (*.*)|*.*"
oFileDialog.DialogTitle = "Save Part Copy"
oFileDialog.FileName = sOldName & "_COPY.ipt"
On Error Resume Next
oFileDialog.ShowSave
If Err Then
Exit Function
ElseIf oFileDialog.FileName <> "" Then
sNewName = oFileDialog.FileName
On Error GoTo 0
End If
Call oPartDoc.SaveAs(sNewName, True)
Case kAssemblyDocumentObject:
'-----------------------------------------------------------------------------------------------
'-----------------MsgBox "Assembly"-------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
Dim oAssDoc As AssemblyDocument
Set oAssDoc = oRefedDoc
oFileDialog.Filter = "Inventor Files (*.iam)|*.iam|All Files (*.*)|*.*"
oFileDialog.DialogTitle = "Save Assembly Copy"
oFileDialog.FileName = sOldName & "_COPY.iam"
On Error Resume Next
oFileDialog.ShowSave
If Err Then
Exit Function
ElseIf oFileDialog.FileName <> "" Then
sNewName = oFileDialog.FileName
On Error GoTo 0
End If
Call oAssDoc.SaveAs(sNewName, True)
Case Else:
MsgBox "Document not an Assembly or Part.", vbCritical
CopyRefedDoc = ""
Exit Function
End Select
Dim oNewDoc As Document
Set oNewDoc = ThisApplication.Documents.Open(sNewName, True) 'Kopie nicht öffnen (Visible=False)
'Das Speichern kann etwas dauern.
'While Not oRefedDoc.FullDocumentName = sNewName
' Sleep 100
' DoEvents
'Wend
Call ClearAllUserDefinediProps(oNewDoc) 'diese Subs auf die Kopie anwenden
Call ClearPartNumberProp(oNewDoc)
oNewDoc.ReleaseReference 'weil unsichtbar geöffnet, sonst bleibts ewig offen
CopyRefedDoc = sNewName
End Function
'--------------------------------------------------------------------------------------------
'----------------------Benutz. iProb löschen-------------------------------------------------
'--------------------------------------------------------------------------------------------
Private Sub ClearAllUserDefinediProps(ByRef oRefedDoc As Document)
Dim oPropset As PropertySet
Set oPropset = oRefedDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
Dim oProp As Property
For Each oProp In oPropset
oProp.Value = ""
Next
End Sub
'--------------------------------------------------------------------------------------------
'----------------------System. iProb löschen-------------------------------------------------
'--------------------------------------------------------------------------------------------
Private Function ClearPartNumberProp(ByRef oRefedDoc As Document)
Dim oPropset As PropertySet
Set oPropset = oRefedDoc.PropertySets.Item("{32853F0F-3444-11D1-9E93-0060B03C1CA6}")
Dim oProp As Property
For Each oProp In oPropset
If oProp.Name = "Part Number" Then
oProp.Value = ""
End If
Next
End Function
'--------------------------------------------------------------------------------------------
'------------------einlesen des aktuellen Benutzernames und Erstelldatum---------------------
'--------------------------------------------------------------------------------------------
Private Sub DrawingProps()
Dim oApp As Inventor.Application
Set oApp = ThisApplication
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = oApp.ActiveDocument
Dim oDate As Date
oDate = Date
Dim sAutor As String
sAutor = oApp.UserName
oDrawDoc.PropertySets("{F29F85E0-4FF9-1068-AB91-08002B27B3D9}").Item(3).Value = sAutor
oDrawDoc.PropertySets("{32853F0F-3444-11D1-9E93-0060B03C1CA6}").Item(1).Value = oDate
End Sub
Gruß
Enric
------------------
Konstruktion
[Diese Nachricht wurde von Enric am 27. Jan. 2024 editiert.]
[Diese Nachricht wurde von Enric am 27. Jan. 2024 editiert.]
[Diese Nachricht wurde von Enric am 27. Jan. 2024 editiert.]
[Diese Nachricht wurde von Enric am 27. Jan. 2024 editiert.]
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
