タイトル : Re^13: 空白ダイアログに名前を入力する 投稿日 : 2011/12/07(Wed) 10:12 投稿者 : YK
こんにちは。 下記の方法で出来ました。 必要なところしかUPしませんので後は付け加えて下さい。 *********** 此処からフォームモジュールに ************ *********** 送って頂いた コードの一部分変更 ************ *********** その他変更無し ************ Private Sub Command1_Click() Dim importfile As String Dim i As Integer, j As Integer, k As Integer Dim strDwgNo As String On Error Resume Next 'AutoCADアプリケーションオブジェクトを取得 Set acadapp = GetObject(, "AutoCAD.Application") 'AutoCADアプリケーションオブジェクト取得に失敗した時 If Err Then 'AutoCAD 2009を起動 Set acadapp = CreateObject("AutoCAD.Application") 'エラーオブジェクトをクリア Err.Clear End If 'AutoCADを表示 acadapp.Visible = True 'Acad2009を最大化 acadapp.WindowState = AcWindowState.acMax 'アプリを最小化 WindowState = 1 '******* その他印刷 ******** ' 省略 '******* PDFファイル印刷 ******** If Check2.Value = 1 Then '印刷部数を繰り返す For k = 1 To Val(Text0.Text) 'リスト内のDWGファイルの数 i = DwgList.ListCount 'リストの数だけ繰り返し For j = 0 To i - 1 'DWGファイル名 importfile = DwgList.List(j) ' **** 変更部分 ↓ ************ ' ↓図面番号 strDwgNo = Dir(importfile) If strDwgNo <> "" Then strDwgNo = Left(strDwgNo, Len(strDwgNo) - (Len(strDwgNo) _ - InStrRev(strDwgNo, ".")) - 1) ' **** 変更部分 此処まで ↑ ************ 'リストボックスの図面をオープン Set acaddoc = acadapp.Documents.Open(importfile) acaddoc.SendCommand "(" & "load" & """D:/Acad/PDF-PLOT2.lsp""" & ")" & vbCr acaddoc.SendCommand "pdf-plot" & vbCr ' **** 変更部分 ↓ ************ ' 此処で ↓ で名前を付けて保存処理 Call CutePDFPrintSet(strDwgNo) ' **** 変更部分 此処まで ↑ ************ 'ファイルを閉じる,図面を変更保存しないで終了 acaddoc.Close (False) End If Next j Next k End If '******* その他印刷 ******** ' 省略 '******* その他印刷 ******** 'ACAD終了 'acadapp.Quit SendKeys "%{F4}", True AppActivate "AutoCAD 2009" Sleep (1000) SendKeys "{Esc} {Esc}", True '変換終了のメッセージを表示 '65584=65536(メッセージボックスを前面)+48(注意メッセージアイコン) MsgBox "印刷終了!", 65584, "End of Plot" 'アプリの最大化 WindowState = 0 End Sub ' その他コードは省いてあります。 *********** フォームモジュールは此処まで **************** *********** 此処から標準モジュールに ******************** *********** 標準モジュールの追加方法は前記述を参照 ******** Option Explicit Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Private Const WM_COMMAND = &H111 Private Const WM_CLOSE = &H10 Private Const BN_CLICKED = 0 Private Declare Function PostMessage Lib "user32" _ Alias "PostMessageA" _ (ByVal hWnd As Long, ByVal Msg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetDlgItem Lib "user32" _ (ByVal hDlg As Long, _ ByVal nIDDlgItem As Long) As Long Private Const WM_SETTEXT = &HC Private Declare Function Sendmessage Lib "user32" _ Alias "SendMessageA" _ (ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function GetDlgCtrlID Lib "user32" _ (ByVal hWnd As Long) As Long Private Declare Sub Sleep Lib "kernel32" _ (ByVal dwMilliseconds As Long) Public Sub CutePDFPrintSet(strDwgNo As String) Dim lngRtn As Long Dim hDlg As Long Dim hPro As Long Dim hOK As Long Dim t t = Timer ' 此処から CutePDF のダイアログ作成待ち Do Sleep 1 hDlg = FindWindow("#32770", "名前を付けて保存") If hDlg Then Exit Do If Timer > t + 10 Then ' Time Over Check MsgBox "CutePDF の名前を付けて保存がありません。" Exit Sub End If Loop ' 図面番号 hPro = GetDlgItem(hDlg, &H480) '名前のWindowHandle Sleep 700 DoEvents ' 図面番号のSET lngRtn = Sendmessage(hPro, WM_SETTEXT, 0, ByVal strDwgNo) DoEvents ' 保存ボタンを押す hOK = GetDlgItem(hDlg, &H1) '保存 ' ↓行のコメントを外すと"名前を付けて保存"の内容が確認できます。 ' Exit Sub lngRtn = PostMessage(hDlg, WM_COMMAND, MAKEWPARAM(GetDlgCtrlID(hOK), BN_CLICKED), hOK) DoEvents Sleep 500 ' 上書きになった場合 hDlg = FindWindow("#32770", "名前を付けて保存") If hDlg = 0 Then Exit Sub ' ' 上書きの場合 hOK = GetDlgItem(hDlg, &H6) 'YES lngRtn = PostMessage(hDlg, WM_COMMAND, MAKEWPARAM(GetDlgCtrlID(hOK), BN_CLICKED), hOK) End Sub Private Function MAKEWPARAM(LOWWORD As Long, HIWORD As Long) As Long MAKEWPARAM = (LOWWORD And &HFFFF&) Or (HIWORD * &H10000) End Function |