tagCANDY CGI VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
[ツリー表示へ]  [ワード検索]  [Home]

タイトル 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

- 関連一覧ツリー をクリックするとツリー全体を一括表示します)

古いスレッドにレスはつけられません。