アクセスカウンタ

プロフィール

Author:croissant3

カテゴリー

最近の記事

月別アーカイブ(タブ)

最近のコメント

最近のトラックバック

月別アーカイブ

ブロとも申請フォーム

この人とブロともになる

月別アーカイブ

カレンダー

11 | 2016/12 | 01
- - - - 1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31

小さな天気予報


-天気予報コム- -FC2-

全ての記事を表示する

全ての記事を表示する

PCノンセクションの10♪
PCに関することを色々と。っつうか最近VBネタばっかorz
スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
↑参考になったら拍手よろろ
VBでmht保存(その2)

とりあえずこんな感じで作ってみました。

CRAM



WebBrowserでWebを表示、保存ボタンを押すと
「Webページを保存」画面で
ファイル名、保存形式を自動入力し
mht保存を行います。

もうちょい時間があれば1問1問自分でWEBを巡回して
勝手にmht保存する形にしたかったのですが
そこまで作っている時間がなかった。orz


今回もmht保存する関数のソースを載せてみます。


Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetForegroundWindow 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
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const LB_SETTOPINDEX = &H197
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Const WM_ACTIVATE = &H6
Private Const WM_CLOSE = &H10
Private Const WM_COMMAND = &H111
Private Const WM_COPY = &H301
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_PASTE = &H302
Private Const WM_QUIT = &H12
Private Const WM_SETTEXT = &HC
Private Const WM_CLEAR = &H303
Private Const EM_SETSEL = &HB1
Private Const EM_REPLACESEL = &HC2
Private Const BN_CLICKED = 0
Private Const BM_CLICK = &HF5
Private Const CB_SETCURSEL = &H14E



Public Sub SaveAs_Input()

'名前を付けて保存ダイアログを検索、
'ファイル名を入力し、mht形式をSendKeysで選択、
'保存ボタンを押すだけ


Const WINDOW_NAME As String = "Web ページの保存"
Const BUTTON_NAME As String = "保存(&S)"

Dim hwnd As Long    '親   Dialog
Dim hChild As Long   '子供  ComboBoxEx32
Dim hhChild As Long   '孫   ComboBox
Dim hhhChild As Long  'ひ孫  Edit


'名前を付けて保存ウィンドウの検索
hwnd = FindWindow(vbNullString, WINDOW_NAME)


'ファイル名入力用のエディットボックスの検索
'ダイアログ-->ComboBoxEx32-->ComboBox-->Editの
'3段になっていることに注意。


If hwnd = 0 Then
  MsgBox "WEBページの保存画面が見つかりません"
  Exit Sub
End If

'エディットボックスの検索
hChild = SearchHandle(hwnd, "ComboBoxEx32")
If hChild = 0 Then
  MsgBox "WEBページの保存:ComboBoxEx32 が見つかりません"
  Exit Sub
End If

hhChild = SearchHandle(hChild, "ComboBox")
If hhChild = 0 Then
  MsgBox "WEBページの保存:ComboBox が見つかりません"
  Exit Sub
End If

hhhChild = SearchHandle(hhChild, "Edit")
If hhhChild = 0 Then
  MsgBox "WEBページの保存:Edit が見つかりません"
  Exit Sub
End If


'---- 保存ファイル名の入力 ----
'見つかったEditボックス(hhhChild)に SendMessage

Call SetForegroundWindow(hwnd)
SendMessage hwnd, WM_ACTIVATE, 1, ByVal 0&
SendMessage hhhChild, WM_ACTIVATE, 1, ByVal 0&
SendMessage hhhChild, WM_CLEAR, 0, ByVal 0&
SendMessage hhhChild, WM_SETTEXT, 0, ByVal "C: emp est.mht"


'---- コンボボックスからmhtを指定する ----
Dim tmpStr As String
Dim tmpCls As String
Dim tmpl As Long
Dim combownd As Long
Dim buf As String * 1024

'とりあえずダイアログの中の子供を一つ取得
combownd = GetWindow(hwnd, GW_CHILD)

Do While combownd <> 0
  '子供のクラス名を取得
  tmpCls = String(255, Chr(0))
  tmpl = GetClassName(combownd, tmpCls, Len(tmpCls))
  tmpStr = Left(tmpCls, tmpl)

  'クラス名がComboBoxならコンボボックスの中の文字列を取得する
  If tmpStr = "ComboBox" Then
    buf = String(1024, Chr(0))
    SendMessage combownd, WM_GETTEXT, 1024, ByVal buf

    Dim a As String
    a = Left(buf, InStr(1, buf, Chr(0), vbTextCompare) - 1)

    Select Case a
      Case "Web ページ、完全 (*.htm;*.html)"
          '---- TAB,DOWN,DOWN,TAB ----
          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          DoEvents

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{DOWN}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{DOWN}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Exit Do

      Case "Web アーカイブ、単一のファイル (*.mht)"
          '---- TAB,TAB ----
          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          DoEvents

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Exit Do

      Case "Web ページ、HTML のみ (*.htm;*.html)"
          '---- TAB,DOWN,UP,TAB
          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          DoEvents

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{DOWN}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{UP}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Exit Do

      Case "テキスト ファイル (*.txt)"
          '---- TAB DOWN,UP,UP,TAB
          'MsgBox "txt"
          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          DoEvents

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{DOWN}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{UP}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{UP}", True
          DoEvents
          Sleep 300

          Call SetForegroundWindow(hwnd)
          SendMessage combownd, WM_ACTIVATE, 1, ByVal 0&
          SendKeys "{TAB}", True
          DoEvents
          Sleep 300

          Exit Do

    End Select
  End If
  combownd = GetWindow(combownd, GW_HWNDNEXT)
Loop

'---- 保存ボタンを検索してクリック
hChild = FindWindowEx(hwnd, 0, vbNullString, BUTTON_NAME)
If hChild = 0 Then
  MsgBox "WEBページの保存:保存ボタンが見つかりません"
  Exit Sub
End If
Call SetForegroundWindow(hwnd)
SendMessage hwnd, WM_ACTIVATE, 1, ByVal 0&
SendMessage hChild, WM_ACTIVATE, 1, ByVal 0&
SendMessage hChild, BM_CLICK, 0, ByVal 0&

End Sub





Public Function SearchHandle(hwnd As Long, ClsName As String) As Long
'hwndウィンドウから指定したクラスの部品を検索、
'ウィンドウハンドルを返すだけ


SearchHandle = 0

Dim hChild As Long

'とりあえずダイアログ画面の子供を1個取得
hChild = GetWindow(hwnd, GW_CHILD)

Dim tmpStr As String
Dim tmpCls As String
Dim tmpl As Long

Do While hChild <> 0
'クラス名を取得
  tmpCls = String(255, Chr(0))
  tmpl = GetClassName(hChild, tmpCls, Len(tmpCls))
  tmpStr = Left(tmpCls, tmpl)
  If tmpStr = ClsName Then
    'MsgBox ClsName & "見つけた!"
    SearchHandle = hChild
    Exit Function
  End If
  hChild = GetWindow(hChild, GW_HWNDNEXT)
Loop

'MsgBox ClsName & "みつからんかった"

End Function

スポンサーサイト
↑参考になったら拍手よろろ

テーマ:プログラミング - ジャンル:コンピュータ

■ この記事に対するコメント

■ この記事に対するコメントの投稿














管理者にだけ表示を許可する。


■ この記事に対するトラックバック
トラックバックURL
→http://croissant3.blog66.fc2.com/tb.php/49-ee7cadf9
この記事にトラックバックする。(FC2ブログユーザー)
ブログ内検索

RSSフィード

リンク

このブログをリンクに追加する

メールフォーム

名前:
メール:
件名:
本文:



上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。