|
|
Koyano
- 10/11/12(金) 15:44 -
|
|
|
| |
Inventor2010で複数のidwファイルをDXF,DWG,PDF等のファイルの一括変換が出来ずに困っていました。独学でInventorのVBAを勉強し下記のプログラムを作成しました。
使用してみてください。ファイルダイアログのデフォルトフォルダは自分用に修正ください。又、PDF変換はPDF用のプリンタドライバを使用していますので、ご自分のPDF用のプリンタドライバ名に変更してください。
＜＜プログラム＞＞
Dim FileArray() As String
'--------------------------------------------------------------------------
' Dxf
'--------------------------------------------------------------------------
Public Sub Sel_Conv_Dxf()
Dim Sss As Variant
Dim idwDoc As DrawingDocument
'ファイルの選択
If TestFileDialog() = False Then Exit Sub
DoEvents
'選択したファイルの処理
For Each Sss In FileArray
Set idwDoc = ThisApplication.Documents.Open(Sss)
DoEvents
Call ExportToDxf(idwDoc)
idwDoc.Close
Next
MsgBox "変換が終了しました。"
End Sub
Public Sub ExportToDxf(ByRef idwDoc As DrawingDocument)
Dim sFname As String
Dim sFname_Temp As String
If idwDoc.DocumentType = kDrawingDocumentObject Then
idwDoc.Activate
sFname = idwDoc.FullFileName
If sFname <> "" Then
sFname_Temp = Left$(sFname, Len(sFname) - 3)
sFname = sFname_Temp & "dxf"
Call PublishDWG(sFname)
DoEvents
End If
End If
End Sub
Public Sub PublishDXF(ByVal TempName As String)
' Get the DXF translator Add-In.
Dim DXFAddIn As TranslatorAddIn
Set DXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
'Set a reference to the active document (the document to be published).
Dim oDocument As Document
Set oDocument = ThisApplication.ActiveDocument
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism
' Create a NameValueMap object
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
' Create a DataMedium object
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
'Set the destination file name
oDataMedium.FileName = TempName
'Publish document.
Call DXFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
End Sub
'--------------------------------------------------------------------------
' Dwg
'--------------------------------------------------------------------------
Public Sub Sel_Conv_Dwg()
Dim Sss As Variant
Dim idwDoc As DrawingDocument
'ファイルの選択
If TestFileDialog() = False Then Exit Sub
DoEvents
'選択したファイルの処理
For Each Sss In FileArray
Set idwDoc = ThisApplication.Documents.Open(Sss)
DoEvents
Call ExportToDwg(idwDoc)
idwDoc.Close
Next
MsgBox "変換が終了しました。"
End Sub
Public Sub ExportToDwg(ByRef idwDoc As DrawingDocument)
Dim sFname As String
Dim sFname_Temp As String
If idwDoc.DocumentType = kDrawingDocumentObject Then
idwDoc.Activate
sFname = idwDoc.FullFileName
If sFname <> "" Then
sFname_Temp = Left$(sFname, Len(sFname) - 3)
sFname = sFname_Temp & "dwg"
Call PublishDWG(sFname)
DoEvents
End If
End If
End Sub
Public Sub PublishDWG(ByVal TempName As String)
' Get the DWG translator Add-In.
Dim DWGAddIn As TranslatorAddIn
Set DWGAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC2-122E-11D5-8E91-0010B541CD80}")
'Set a reference to the active document (the document to be published).
Dim oDocument As Document
Set oDocument = ThisApplication.ActiveDocument
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism
' Create a NameValueMap object
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
' Create a DataMedium object
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
' Check whether the translator has 'SaveCopyAs' options
If DWGAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
Dim strIniFile As String
strIniFile = "C:\tempDWGOut.ini"
' Create the name-value that specifies the ini file to use.
oOptions.Value("Export_Acad_IniFile") = strIniFile
End If
'Set the destination file name
'oDataMedium.FileName = "c:\tempdwgout.dwg"
oDataMedium.FileName = TempName
'Publish document.
Call DWGAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
End Sub
'--------------------------------------------------------------------------
' Pdf
'--------------------------------------------------------------------------
Public Sub Sel_Conv_Pdf()
Dim Sss As Variant
Dim idwDoc As DrawingDocument
'ファイルの選択
If TestFileDialog() = False Then Exit Sub
DoEvents
'選択したファイルの処理
For Each Sss In FileArray
Set idwDoc = ThisApplication.Documents.Open(Sss)
DoEvents
Call ExportToPdf(idwDoc)
idwDoc.Close
Next
MsgBox "変換が終了しました。"
End Sub
Public Sub ExportToPdf(ByRef idwDoc As DrawingDocument)
Dim sFname As String
Dim sFname_Temp As String
If idwDoc.DocumentType = kDrawingDocumentObject Then
idwDoc.Activate
sFname = idwDoc.FullFileName
If sFname <> "" Then
sFname_Temp = Left$(sFname, Len(sFname) - 3)
sFname = sFname_Temp & "pdf"
Call PrintDrawing
DoEvents
End If
End If
End Sub
'--------------------------------------------------------------------------
' Print Drawings with PDF Printer Driver
'--------------------------------------------------------------------------
Public Sub PrintDrawing()
' Set a reference to the print manager object of the active document.
' This will fail if a drawing document is not active.
Dim oPrintMgr As DrawingPrintManager
Set oPrintMgr = ThisApplication.ActiveDocument.PrintManager
' Set to printer
oPrintMgr.Printer = "Adobe PDF"
' Set to print in color.
oPrintMgr.ColorMode = kPrintGrayScale
' Set to print two copies.
oPrintMgr.NumberOfCopies = 2
' Set to print using portrait orientation.
oPrintMgr.Orientation = kLandscapeOrientation
' Set the paper size.
oPrintMgr.PaperSize = kPaperSizeA3
' Set to print all sheets.
oPrintMgr.PrintRange = kPrintAllSheets
' Set to print BestFit scale.
oPrintMgr.ScaleMode = kPrintBestFitScale
' Submit the print.
oPrintMgr.SubmitPrint
' Change the number of copies to 1.
oPrintMgr.NumberOfCopies = 1
' Get and set the current sheet range.
Dim iFromSheet As Long
Dim iToSheet As Long
Call oPrintMgr.GetSheetRange(iFromSheet, iToSheet)
' Submit the print.
oPrintMgr.SubmitPrint
End Sub
'--------------------------------------------------------------------------
' File Dialog
'--------------------------------------------------------------------------
Public Function TestFileDialog() As Boolean
' Create a new FileDialog object.
Dim oFileDlg As FileDialog
Call ThisApplication.CreateFileDialog(oFileDlg)
' Define the filter to select part and assembly files or any file.
oFileDlg.Filter = "Inventor idw Files (*.idw)|*.idw"
' Define the part and assembly files filter to be the default filter.
oFileDlg.FilterIndex = 1
' Set the title for the dialog.
oFileDlg.DialogTitle = "Open File Test"
' Set the initial directory that will be displayed in the dialog.
oFileDlg.InitialDirectory = "P:\Vison\VW18HD2\users.fld\保管１.fld"
' Set the flag so an error will be raised if the user clicks the Cancel button.
oFileDlg.CancelError = True
oFileDlg.MultiSelectEnabled = True
' Show the open dialog. The same procedure is also used for the Save dialog.
' The commented code can be used for the Save dialog.
On Error Resume Next
oFileDlg.ShowOpen
' If an error was raised, the user clicked cancel, otherwise display the filename.
If Err Then
TestFileDialog = False
Else
If oFileDlg.FileName <> "" Then
FileArray() = Split(oFileDlg.FileName, "|")
TestFileDialog = True
End If
End If
End Function
|
|
|
|
|
 |
|
![[添付]](./file/1%96%B3%91%E8.bmp){kind=small}
〜添付ファイル〜
![[添付]](./file/2%96%B3%91%E8.bmp){kind=small}
〜添付ファイル〜
![[添付]](./file/err.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/2.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/eval.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/2010_10_18.gif){kind=small}
〜添付ファイル〜
![[添付]](./file/%8C%8A%92%8D%8BL.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/%8EQ%8Dl%90%7D.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/%90%E0%96%BE2.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/%90%E0%96%BE1.JPG){kind=small}
〜添付ファイル〜
![[添付]](./file/%8EQ%8Dl%90%7D.jpg){kind=small}
〜添付ファイル〜
![[添付]](./file/L20.png){kind=small}
〜添付ファイル〜