| タイトル | ： Re^5: 空白ダイアログに名前を入力する |
| 記事No | ： 15373 |
| 投稿日 | ： 2011/12/01(Thu) 16:13 |
| 投稿者 | ： YK |
こんにちは。
一応フォームのコマンドボタンから実行するものとして
標準モジュールに
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 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 Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
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 Const CB_ADDSTRING = &H143
Private Const CB_SETCURSEL = &H14E
Private Const CB_GETCOUNT = &H146
Private Const CB_GETCURSEL = &H147
Private Const CB_GETLBTEXT = &H148
Private Const CB_GETLBTEXTLEN = &H149
Private Const CB_GETITEMDATA = &H150
Private Const CB_RESETCONTENT = &H14B
Private Declare Function GetDlgCtrlID Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Public Declare Function EnumWindows Lib "user32.dll" _
(ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32.dll" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32.dll" _
Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" _
Alias "GetWindowTextLengthA" _
(ByVal hwnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Const BN_CLICKED = 0
Private Const GW_OWNER = 4
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000
Private Const WS_BORDER = &H800000
Public strDwgNo As String
Public aHwnd As Long
Public Function EnumWindowsProc(ByVal hwnd As Long, _
lParam As Long) As Long
Dim strClassBuff As String * 128
Dim strDwgNoBuff As String * 516
Dim lngRtn As Long
Dim lngThreadId As Long
Dim lngProcesID As Long
Dim lngStyle As Long
If IsWindowVisible(hwnd) = 0 Then GoTo EnumPass
If GetParent(hwnd) <> 0 Then GoTo EnumPass
If GetWindowTextLength(hwnd) = 0 Then GoTo EnumPass
lngStyle = GetWindowLong(hwnd, GWL_STYLE)
If Not lngStyle And WS_SYSMENU Then GoTo EnumPass
If Not lngStyle And WS_BORDER Then GoTo EnumPass
lngRtn = GetWindowText(hwnd, strDwgNoBuff, Len(strDwgNoBuff))
strDwgNo = Left(strDwgNoBuff, InStr(strDwgNoBuff, vbNullChar) - 1)
If strDwgNo Like "*AutoCAD*" Then
aHwnd = hwnd
Exit Function
End If
EnumPass:
EnumWindowsProc = True
End Function
Public Sub CutePDFPrintSet()
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
フォームモジュールに
Option Explicit
Private Sub Command1_Click()
Dim lngRtn As Long
' WindowTextから図面番号
lngRtn = EnumWindows(AddressOf EnumWindowsProc, 0&)
If aHwnd = 0 Then
MsgBox "Auto Cad が立ち上がっていません。"
Exit Sub
End If
strDwgNo = Split(Split(strDwgNo, "[")(1), "]")(0)
' ↓図面番号
strDwgNo = Left(strDwgNo, Len(strDwgNo) - (Len(strDwgNo) _
- InStrRev(strDwgNo, ".")) - 1)
' kiyo さんの処理 を実行して
''************************* 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)
' 注
'もし importfile が 図面番号でしたら
'strDwgNo = Left(strDwgNo, Len(importfile) - (Len(importfile) _
- InStrRev(importfile, ".")) - 1)
'としましょう。
'リストボックスの図面をオープン
Set acaddoc = acadapp.Documents.Open(importfile)
acaddoc.SendCommand "(" & "load" & """itoki-pdf-plot.lsp""" & ")" & vbCr
acaddoc.SendCommand "pdf-plot" & vbCr
''---→ここでpdf-plotコマンドが走って、印刷ゲージが終了。この後「CutePDF」
'' からの「名前を付けて保存」画面がでます。
''************************* PDFファイル印刷 *************************
' CutePDFの名前を付けて保存処理
CutePDFPrintSet
Next
Next
End If
End Sub
|