三流君 ＶＢＡで楽しくプログラミング(Excel/Access VBAの解説/サンプルです)
[VBA系のバックナンバー]
[VBA系 TOP]
[三流君 TOP]
＜URLDownloadToFile APIを使用してダウンロードしてみた＞
今回は、
Web上のpdfファイルをダウンロードしてみたいと質問をもらったので、
チャレンジしてみます。
サンプルファイルは、
http://www.ken3.org/vba/lzh/vba120.lzh
にvba120.xlsが保存されています。
/*
* １. 今回のキッカケ
*/
掲示板に下記の質問をもらいました。
-----
>以前のものでExcelからIeを立ち上げて、ユーザー名、パスワードを
>入力して開くということが書かれていました。また、リンク先を拾うと
>言う処理も書かれていました。さて、ここからなんですが、リンク先に
>設定されているPDFファイルを特定のフォルダへ保存するという処理は
>どうやったらいいのでしょうか？
-----
リンク先を保存かぁ、あるよね、そんな処理。
/*
* ２．保存方法を探る
*/
Webで保存方法を探るが、なかなか、ヒットしない。
みなさん、ダイアログにSendKeysしたりとイロイロ苦労しているみたいです。
しかたないので、マイクロソフトのページをみてみる。
使えそうな？
URLDownloadToFile？ってヤツが載ってました。
日本語のサポートかと思ったら、ヘッダ部分だけ日本語？
こんなのアリなの？
なんて、文句は置いといて、下記のURLに情報載ってます。
http://support.microsoft.com/support/kb/articles/q244/7/57.asp
The WebBrowser control and Internet Explorer have Save and Save As options
that can be used to save files using the ExecWB command. However,
this involves prompting from the user.
There is no way to suppress this prompt.
To save files to the hard-disk without prompting,
use the URLDownloadToFile API from URLMON.
MORE INFORMATION
The declaration for URLDownloadToFile is as follows:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
The function can be called as follows:
returnValue = URLDownloadToFile(0, "http://www.microsoft.com/ms.htm" _
"c:\ms.htm", 0, 0)
Note that when downloading HTML files,
embedded content like images and objects will not be downloaded.
/*
* ３．単体でテストを行う
*/
URLDownloadToFile って API が URLMON ってところにあるらしい。
APIの宣言文はそのままコピーして、下記のように使ってみた。
'URLDownloadToFile API from URLMON.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub aaa()
Const strURL = "http://www.ken3.org/index.html"
Dim strFNAME As String 'ダウンロード先（パス＋ファイル名）
Dim returnValue
'ファイル名をブックのパス＋test.htmlとする
strFNAME = ThisWorkbook.Path & "\test.html"
'URLDownloadToFile API をコールする
returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)
'結果の表示
MsgBox "結果は：" & returnValue
MsgBox strFNAME & "に保存されました"
End Sub |
ポイントは
^^^^^^^^^^
特に無く、マイクロソフトのサンプルの変数を変えただけです。（オイオイ）
http://www.ken3.org/index.html
を
ThisWorkbook.Path & "\test.html"とブックと同じ位置のtest.htmlに保存しました。
実行すると、おっ、できてますね。
一安心したところで、pdfファイルをダウンロードしてみます。
IODATAのカタログページから１つテストで落としてみます。
なんて書いてるけど、ＵＲＬとファイル名が違うだけで同じプログラムです。
Sub bbb()
'IODATAのカタログをダウンロードしてみた
Const strURL = "http://www.iodata.co.jp/products/pdf/20030809/memory_n-s-p.pdf"
Dim strFNAME As String 'ダウンロード先（パス＋ファイル名）
Dim returnValue
'ファイル名をブックのパス＋test.pdfとする
strFNAME = ThisWorkbook.Path & "\test.pdf"
'URLDownloadToFile API をコールする
returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)
'結果の表示
MsgBox "結果は：" & returnValue
MsgBox strFNAME & "に保存されました"
End Sub |
無事にＰＤＦファイルも、
URLDownloadToFile API で落とせました。
ただ、気になったのは、
^^^^^^^^^^^^^^^^^^^^^^
処理中砂時計のまんまなので、大きいファイルをダウンロードする時、
固まった（止まっている）イメージを受けてしまう。
ＩＥのダウンロードだとバーが出たり、残り時間が表示されるけど、
男は黙って仕事する・・・じゃないけど、無言で処理が走っている・・・
メッセージとか、一工夫必要かなぁ・・・と思いました。
あと、２回目のダウンロードが早過ぎる。
^^^^^^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
これは、キャッシュから取ってきているんだろうけど、
毎回変わるファイルの時は、少し不安かなぁ
（古いデータを取得する可能性がある？）
/*
* ４．リンクオブジェクトからリンク先を見て、保存する
*/
さてと、単体テストが終了したので、
PDFファイルを取り出してみますか。
※ＰＤＦと思ったけど、ＰＤＦファイルって、サイズ大きいので、
.htmlをテストでダウンロードしてます。
目的のファイルへ拡張子のチェック部分を変更してくださいね。
リンク先のオブジェクトの取り出しは、
http://www.ken3.org/backno/backno_vba15.html#71
の
No.71 IE操作 リンク先を取出す .Document.links(i).href
で、
.Documentオブジェクトのリンクを探り、
.href .outertext .outerHTML を使ってみました。
objIE.Document.links.Length
でリンクの数を取得できるので、
'リンク数分まわす
For i = 0 To objIE.Document.links.Length - 1
Cells(nYLINE, "A") = "'" & objIE.Document.links(i).outerText
Cells(nYLINE, "B") = "'" & objIE.Document.links(i).href
Cells(nYLINE, "C") = "'" & objIE.Document.links(i).outerHTML
nYLINE = nYLINE + 1 'セット位置を＋1する
Next i
みたいにして、リンクを取り出してました。
ここに、ファイルのダウンロード処理をいれてみます。
メインのルーチンで
^^^^^^^^^^^^^^^^^^
・ＩＥ起動
・目的の画面表示、
・リンクのループ、リンク先ＵＲＬをサブに渡す
サブのルーチンで、リンク先ＵＲＬを受け取り
^^^^^^^^^^^^^^^^^^
・拡張子のチェック
・ファイル名の作成
・実際のダウンロードを行う
と処理を分けてみたいと思います。
'URLDownloadToFile API from URLMON.
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
とＡＰＩの宣言をしてから、
まずは、メインのルーチンを作成します。
Sub test_main()
Dim objIE As Object
Dim time10 As Date
Dim strURL As String
Dim i As Integer
Dim nYLINE As Integer
On Error GoTo EMSG
'IEの起動
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True '見えるようにする
objIE.GoHome '初期ページの表示
Do While objIE.Busy = True '起動まで待つ
DoEvents
Loop
'Excelをアクティブにする。
AppActivate "Microsoft Excel"
'初期処理
Rows("13:1000").Select '結果の表示エリアをクリアする
Selection.Delete Shift:=xlUp
nYLINE = 13 '13行目からデータをセットするので
'読み込むページのURLを代入
strURL = "http://www.ken3.org/backno/backno_vba15.html"
objIE.Navigate "" & strURL 'アドレスを渡し表示する
'読みこみ完了まで待つ
'30秒後を計算して、待つ
time10 = DateAdd("s", 30, Now())
Do While objIE.Busy = True
DoEvents
If time10 < Now() Then
Exit Do
End If
DoEvents
Loop
If objIE.Busy = True Then
Cells(nYLINE, "A") = "タイムアウトです、読み込みに失敗しました"
MsgBox "タイムアウトです、読み込みに失敗しました"
Exit Sub '関数を抜ける
End If
'リンクを探す
'リンク数分まわす
For i = 0 To objIE.Document.links.Length - 1
Cells(nYLINE, "A").Select '遊びでカーソル移動
DoEvents
Cells(nYLINE, "A") = "'" & objIE.Document.links(i).outerText
Cells(nYLINE, "B") = "'" & objIE.Document.links(i).href
'後ろが.htmlならファイルダウンロードの関数を呼ぶ
If Right(objIE.Document.links(i).href, 4) = "html" Then
Cells(nYLINE, "C") = Now '遊びで開始時刻をセット
'ダウンロード関数を呼ぶ
Call get_url_file(objIE.Document.links(i).href)
Cells(nYLINE, "D") = Now
End If
'次のセット位置にする
nYLINE = nYLINE + 1 'セット位置を＋1する
Next i
objIE.Quit 'ＩＥを閉じる
MsgBox "終了しました"
Exit Sub
EMSG:
Cells(nYLINE, 2) = "ERR"
objIE.Quit '
MsgBox "errが発生しました"
Exit Sub
End Sub |
次にサブルーチンを作成します。
ＵＲＬを引数で受け取って、ダウンロードしてみます。
'URLを受け取り、ファイルをダウンロードする
'関数内でＵＲＬからファイル名を作成する（/を探す）
Sub get_url_file(strURL As String)
Dim strFNAME As String 'ダウンロード先（パス＋ファイル名）
Dim strWORK As String '後ろから/を探し、ファイル名を取り出す
Dim returnValue
Dim n As Integer
'ファイル名を取り出す
For n = Len(strURL) To 1 Step -1 '後ろから/を探す
If Mid(strURL, n, 1) = "/" Then
Exit For '/が見つかったらループを抜ける
End If
Next n
strWORK = Mid(strURL, n + 1) '/の次からファイル名なのでn+1から
'ファイル名をブックのパス＋\＋取り出したファイル名とする
strFNAME = ThisWorkbook.Path & "\" & strWORK
'strFNAME = "C:\DATA\AAA\" & strWORK と固定のパスでもＯＫだけど
'URLDownloadToFile API をコールする
returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0)
End Sub |
ポイントは、特に無いんだけど、
http://www.ken3.org/backno/backno_vba15.html
と、urlを受け取るので、
/を探して、
backno_vba15.html
とファイル名を取り出して、
strFNAME = ThisWorkbook.Path & "\" & strWORK
と、ファイル名を作成しました。
固定のフォルダーに落としたい時は、
strFNAME = "d:\data\" & strWORK
なんてやると、
d:\data\backno_vba15.html
に保存されると思います。
pdfファイルも同様にダウンロード可能だと思います。
-【けんぞう！】---------------------------------------------------------
月500円、タバコなら２箱、120円缶コーヒーなら４缶分の謝礼をＧｅｔするなら
http://www.ken3.org/etc/500yen/ ←無料アンケート系の広告です。
『チッ、がんばって回答して月500円かよ』（お馬鹿なプログラマー：31歳）
------------------------------------------------------------------------
/*
* ５．終わりの挨拶
*/
今回は、
Web上のファイルを
URLDownloadToFile APIを使用してダウンロードしてみました。
サンプルファイルは、
http://www.ken3.org/vba/lzh/vba120.lzh
にvba120.xlsが保存されています。
テストして、遊んでみてください。
何かの参考となれば幸いです。
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
Excel UserForm リストボックスを使ってみた
どうも、三流プログラマーのＫｅｎ３です。
今回は、
Excelのユーザーフォームで、リストボックスを使ってみます。
サンプルファイルは、
http://www.ken3.org/vba/lzh/vba121.lzh
にvba121.xlsが保存されています。
/*
* １. 今回のキッカケ
*/
掲示板のやりとりから、
-----
>投稿時間：2003/08/03(Sun) 11:26
>タイトル：Re^4: VBAでの自動解凍
>
>現在のコード
>Option Explicit
>Private Declare Function Unlha Lib "UNLHA32.DLL" (ByVal Cal
>lhwnd As Long, ByVal LHACommand As String, ByVal RetBuff As Stri
>ng, ByVal RetBuffSize As Long) As Long
>Private Sub CommandButton1_Click()
>'********* UnLHA32.DLLを使ってLZHファイルを解凍する ***
>******
>Dim Ret As String * 255 'UnLHAからの結果を
>入れるバッファ（長さ255バイト）
>Dim SendStr As String 'コマンド゛文字列
>Dim sourceFile As String '解凍する圧縮ファイル
>Dim targetDir As String '解凍先ディレクトリ
>Dim Result As Long '戻り値
>
>targetDir = "C:\あ\い\"
>
>If targetDir = "" Then Exit Sub '解凍処理中止。
>ChDir "C:\LZHファイル"
>sourceFile = Application.GetOpenFilename("lzhファイル(*
>.lzh),*.lzh")
>
>SendStr = "e " & sourceFile & " " & targetD
>ir '（スペースで区切っていることに注意）
>Result = Unlha(0, SendStr, Ret, 255) 'UnLHA実行!
>If Result = 0 Then MsgBox (Ret) '解凍に
>成功したら、結果報告
>End Sub
>
>なんとか、ここまでたどり着きましたが「ＬＺＨファイル」フォルダ
>の中にあるlzhファイルの種類と数が多いので上の
>「Application.GetOpenFilename〜」では全てのlzhファイルがダイア
>ログボックスに表示してしまいます。
>そこで、ファイル名に含まれる文字である程度絞込み、その中からひ
>とつを選べるようにしたいのですが、どうすればいいでしょうか。
-----
*.lzhファイルが多いので、
ファイルに含まれる文字で絞り込みたいのかぁ。
/*
* ２．Application.GetOpenFilenameをテストしてみる。
*/
そんなの簡単、vb*.lzhとワイルドカード指定でしょ？
と安易に思い、下記のテストを行ってみる。
下記、vb*.lzh指定でダメだったサンプルです・・
なにかありそうだけど・・・
Sub aaa()
'ChDir "e:\work"
Dim strFPTN As String 'ファイルパターン？
strFPTN = "lzhファイル(vb*.lzh),vb*.lzh"
Dim strFN As String
strFN = Application.GetOpenFilename(strFPTN)
MsgBox strFN
End Sub |
あれ・・ダメなの？
でも、拡張子の指定は下記のようにするとＯＫなんだけど。
Sub bbb()
'ChDir "e:\work"
Dim strFPTN As String 'ファイルパターン？
strFPTN = "lzhファイル(*.lzh), *.lzh"
strFPTN = strFPTN & ",テキストファイル, *.txt;*.csv"
Dim strFN As String
strFN = Application.GetOpenFilename(strFPTN)
MsgBox strFN
End Sub |
上記指定で、
*.lzh
と
*.txt *.csv
のワイルドカードが指定可能。
↑ファイルの種類を指定してみた
頭のファイル名の部分は指定できないのかなぁ・・・なんか勘違いありそうだけど。
/*
* ３．Excel UserForm の ListBoxを使ってみた
*/
何で出来ないんだろう・・・う〜ん・・・
Application.GetOpenFilename
のヘルプを見るが、いい方法がない。
あまりやりたくないけど、自作のユーザーフォームを作ってみます。
一覧から選択するので（選択したいので）、
リストボックスを使用してみます。
まずは、白紙のユーザーフォームを追加します。
Alt+F11でVBEの編集画面に行き、
次に、メニューから
挿入 -- ユーザーフォームを選択します。
すると、白紙のフォームを作成することが出来ます。
ツールボックスから
リストボックスコントロールを選択してフォームに貼ります。
フォームの初期化時のイベントで、
カレントディレクトリのvb*.lzhをリストボックスに追加してみます。
Private Sub UserForm_Initialize()
'フォームの初期化イベントでリストボックスにデータをセットする
Dim strWORK As String
Me.ListBox1.Clear '.Clearで内容を全てクリア
strWORK = Dir("vb*.lzh") 'カレントのVB*.lzhを検索する
While strWORK <> ""
'取得したファイル名をリストに追加する、ITEMの追加
Me.ListBox1.AddItem (strWORK)
'次のファイル名を取得する
strWORK = Dir() '引数無しで呼ぶと次のファイル名がセットされる
Wend
End Sub |
ポイントは、
^^^^^^^^^^^^
ListBox1.Clearと.Clearでリスト内の項目をクリア後、
Dir関数を使用して、カレントディレクトリ内のvb*.lzhを取得します。
取得したファイル名を、
.AddItemメソッドを使用して、セットしただけです。
↑リストボックスへセットした結果
リストボックスの中身を用意できたら、
次は、選択されたデータを判断したいですよね。
ボタンが押されたら、選択されたファイル名を表示してみます。
１つボタンのコントロールを追加して、
そのボタンのクリックイベントに書いてみます。
Private Sub btn01_Click()
Dim strDATA As String
strDATA = Me.ListBox1.Text '.Textプロパティの値を代入
MsgBox "選択されたデータは、" & strDATA
End Sub |
まぁ、こんな感じで、選択されたデータを取り出せます。
.Textプロパティなんですね。
んっ、何も選択しないと、、まぁ=""で判断できるのかな。
Private Sub btn01_Click()
Dim strDATA As String
strDATA = Me.ListBox1.Text '.Textプロパティの値を代入
If strDATA = "" Then
MsgBox "データを選択してからボタンを押してね"
Else
MsgBox "選択されたデータは、" & strDATA
End If
End Sub |
/*
* ４．組み合わせて、LZHの解凍を呼ぶ
*/
さてと、組み合わせてみますか。
カレントディレクトリをセットして、
ユーザーフォームを呼ぶ、そんな関数を標準関数に作ります。
Sub ccc()
'ChDrive "E" 'ドライブの変更
'ChDir "e:\work" 'フォルダーの変更
UserForm1.Show 'ユーザーフォームを表示する
End Sub |
まぁ、こんな感じで、
ChDrive "E" 'ドライブの変更
ChDir "e:\work" 'フォルダーの変更
ドライブだったらこれでＯＫですね。
自分の環境に固定の場所を直してコメントを外してください。
※えっ、途中で変更したいって？まぁ、今回はカンベンしてよ・・・
ユーザーフォームで、ファイルを選択後、
LHAのファイルを解凍します。
userform1のモジュールです。
ボタンが押されたら、解凍するためにDLLを呼んでます。
Private Declare Function Unlha Lib "UNLHA32.DLL" (ByVal Callhwnd As Long, _
ByVal LHACommand As String, ByVal RetBuff As String, _
ByVal RetBuffSize As Long) As Long
Private Sub btn01_Click()
Dim strDATA As String
strDATA = Me.ListBox1.Text '.Textプロパティの値を代入
If strDATA = "" Then
MsgBox "データを選択してからボタンを押してね"
Exit Sub
End If
'********* UnLHA32.DLLを使ってLZHファイルを解凍する *********
Dim Ret As String * 255 'UnLHAからの結果を入れるバッファ（長さ255バイト）
Dim SendStr As String 'コマンド゛文字列
Dim sourceFile As String '解凍する圧縮ファイル
Dim targetDir As String '解凍先ディレクトリ
Dim Result As Long '戻り値
Dim Msg1 As String
'↓解凍先ディレクトリ
'targetDir = "e:\work\test\" '←固定値をセットしてもいいし
targetDir = CurDir() & "\" 'カレントディレクトリをセットする
'↓解凍したい.lzhファイル
sourceFile = CurDir() & "\" & strDATA
'↑選択されたファイル名を＋して、フルパスを作成する
'C:\Documents and Settings\ken3\My Documents
'みたいに、スペース付のフォルダの予防で”chr(&h22)を付ける
sourceFile = Chr(&H22) & sourceFile & Chr(&H22)
targetDir = Chr(&H22) & targetDir & Chr(&H22)
'"C:\Documents and Settings\ken3\My Documents"とダブルコーテーション付にする
'ここで、コマンドを作っている
SendStr = "e " & sourceFile & " " & targetDir
'（スペースで区切っていることに注意）
Result = Unlha(0, SendStr, Ret, 255) 'UnLHA実行!
If Result = 0 Then MsgBox (Ret) '解凍に成功したら、結果報告
'作業が終了、フォームを閉じる
Unload Me
End Sub |
とくにポイントは無いんだけど、
ファイル名で（フォルダーで）
My Documents
みたいに、スペースが入っているフォルダーがあります。
これをそのままスペース区切りのコマンドに乗せると、
e C:My Documents\vb00aaa.lzh C:My Documents\
となり、正しく渡らないので、
""を付け（””で囲い）
e "C:My Documents\vb00aaa.lzh" "C:My Documents\"
がパラメータで渡るように細工してます。
あとは、うまくアレンジして、解凍処理を作れると思います。
フォームの初期化のタイミングで、ファイル名をセットする。
ホントは、ここで、フォルダーを変更したいが（変更機能がほしいが）
カレントディレクトリを対象としています。
Private Sub UserForm_Initialize()
'フォームの初期化イベントでリストボックスにデータをセットする
Dim strWORK As String
Me.ListBox1.Clear '.Clearで内容を全てクリア
strWORK = Dir("vb*.lzh") 'カレントのVB*.lzhを検索する
While strWORK <> ""
'取得したファイル名をリストに追加する、ITEMの追加
Me.ListBox1.AddItem (strWORK)
'次のファイル名を取得する
strWORK = Dir() '引数無しで呼ぶと次のファイル名がセットされる
Wend
End Sub |
-【けんぞう！】---------------------------------------------------------
月500円、タバコなら２箱、120円缶コーヒーなら４缶分の謝礼をＧｅｔするなら
http://www.ken3.org/etc/500yen/ ←無料アンケート系の広告です。
『チッ、がんばって回答して月500円かよ』（お馬鹿なプログラマー：31歳）
------------------------------------------------------------------------
/*
* ５．終わりの挨拶
*/
今回は、
Excelのユーザーフォームで、
リストボックスを使用してみました。
例題は、ファイル名をセットして、選択だったけど、
いろいろと使ってみてください。
今回のサンプルファイルは、
http://www.ken3.org/vba/lzh/vba121.lzh
にvba121.xlsが保存されています。
テストして、遊んでみてください。
何かの参考となれば幸いです。
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
＜Excel UserForm ラベルに情報を表示する＞
どうも、三流プログラマーのＫｅｎ３です。
今回は、
Excelのユーザーフォームに、
ラベルで情報を表示してみます。
今回のサンプルファイルは、
http://www.ken3.org/vba/lzh/vba122.lzh
にvba122.xlsが保存されています。
/*
* １. 今回のキッカケ
*/
前回、質素な（機能的に貧しい）、
ファイル選択のユーザーフォームを作成しました。
作成したユーザーフォームを呼ぶ前に
カレントディレクトリをセットして、
ユーザーフォームを呼ぶ、そんな処理でした。
Sub ccc()
ChDrive "E" 'ドライブの変更
ChDir "e:\work" 'フォルダーの変更
UserForm1.Show 'ユーザーフォームを表示する
End Sub |
すごい不親切なプログラムで、
リストボックスにファイル名が表示されるが、
ChDrive "E" や ChDir "e:\work"
で変更したカレントドライブ・フォルダーを表示してなく、
どこのフォルダー？と一瞬わからない作りです。
↑選択元フォルダーがよくわからないイメージです。
~~~~~~~~~~~~~~~~~~
/*
* ２．ラベルを貼り、フォルダーを表示する
*/
そこで、ラベルコントロールをフォームに貼り、
ファイルの選択元のフォルダー名を表示してみたいと思います。
まず、表示用のラベルコントロールをフォームに貼ります。
あとは、フォームの初期化イベントで、
ラベルコントロールの.Captionプロパティに表示したい文字列をセットします。
Private Sub UserForm_Initialize()
'ラベルにフォルダーを表示する
Me.Label1.Caption = CurDir() & "\" 'カレントディレクトリをセットする
'フォームの初期化イベントでリストボックスにデータをセットする
Dim strWORK As String
Me.ListBox1.Clear '.Clearで内容を全てクリア
strWORK = Dir("vb*.lzh") 'カレントのVB*.lzhを検索する
While strWORK <> ""
'取得したファイル名をリストに追加する、ITEMの追加
Me.ListBox1.AddItem (strWORK)
'次のファイル名を取得する
strWORK = Dir() '引数無しで呼ぶと次のファイル名がセットされる
Wend
End Sub |
意外とあっけなく、
'ラベルにフォルダーを表示する
Me.Label1.Caption = CurDir() & "\" 'カレントディレクトリをセットする
と
.Captionに表示したい文字列をセットするだけでＯＫでした。
↑無事、フォルダー名が表示されました。
/*
* ３． １＋１で２を作成する。フォルダーの選択関数を流用する
*/
これで、当初の目的、どこのフォルダーかわからない？
は、解消されたけど、
今度は、自分でフォルダーを選択したい、
デフォルトのフォルダーから自由なフォルダーに変えたい、、、
なんて要望が出てきます。
１＋１＝２じゃないけど、機能を＋してみます。
追加する機能は、フォルダーの選択機能です。
フォルダーの選択は、昔作ったヤツを流用（+1機能）します。
フォルダーの選択処理の詳細は、
フォルダーを選択してファイルリストを作成する
http://www.ken3.org/vba/vba-folder.html
と
No.114 VBA で WScript.ShellのSpecialFoldersプロパティを使ってみた
http://www.ken3.org/backno/backno_vba23.html#114
を見てください。
'フォルダー選択ダイアログを表示して、リターン値で選択場所を返す
'キャンセルの時は文字列""（空文字列）を返す
Public Function getFOLDER() As String
Dim objShell As Object 'Shell
Dim objFolder As Object 'Shell32.Folder
Const strTitle = "フォルダを選択してください。"
'シェルのオブジェクトを作成する
Set objShell = CreateObject("Shell.Application")
'フォルダー参照に設定
Const lngRef = &H1
'ルートフォルダーをデスクトップに設定
'5でMy Documents、6でFavoritesなど
Const fldRoot = &H0
Set objFolder = _
objShell.BrowseForFolder(0, _
strTitle, lngRef, fldRoot)
'フォルダー名を取出し、リターン値をセット
If objFolder Is Nothing Then 'キャンセルチェック
getFOLDER = "" 'リターン値に""空文字列をセット
Else
If objFolder.ParentFolder Is Nothing Then '下位を未選択デスクトップ？
Dim objWShell As Object 'WScript.Shell
'シェルのオブジェクトを作成する
Set objWShell = CreateObject("WScript.Shell")
'デスクトップの場所を返す
getFOLDER = objWShell.SpecialFolders("Desktop")
'オブジェクトの開放
Set objWShell = Nothing
Else
getFOLDER = objFolder.Items.Item.Path 'パスをセットする
End If
End If
Set objFolder = Nothing
Set objShell = Nothing
End Function |
と、このgetFOLDER関数を標準モジュールに書いておいて、
フォームにフォルダー選択のボタンを１つ追加します。
Private Sub CommandButton2_Click()
Dim strFOLDER As String '選択されたフォルダー名称
strFOLDER = getFOLDER() 'フォルダーの選択関数を呼ぶ
If strFOLDER = "" Then '選択結果がキャンセルかチェックする
Exit Sub '関数を途中で抜ける
End If
'カレントドライブ、ディレクトリを変更する
ChDrive Left(strFOLDER, 1) '頭のドライブ文字のセット
ChDir strFOLDER 'フォルダーの変更
'リストボックスの内容を変更する
'ラベルにフォルダーを表示する
Me.Label1.Caption = CurDir() & "\" 'カレントディレクトリをセットする
'フォームの初期化イベントでリストボックスにデータをセットする
Dim strWORK As String
Me.ListBox1.Clear '.Clearで内容を全てクリア
strWORK = Dir("vb*.lzh") 'カレントのVB*.lzhを検索する
While strWORK <> ""
'取得したファイル名をリストに追加する、ITEMの追加
Me.ListBox1.AddItem (strWORK)
'次のファイル名を取得する
strWORK = Dir() '引数無しで呼ぶと次のファイル名がセットされる
Wend
End Sub |
処理のポイントは、
strFOLDER = getFOLDER() 'フォルダーの選択関数を呼ぶ
と、フォルダーの選択関数を呼んでフォルダーを選択させます。
If strFOLDER = "" Then '選択結果がキャンセルかチェックする
Exit Sub '関数を途中で抜ける
End If
で、フォルダー選択がキャンセルか判断して、
選択されていたら、
'カレントドライブ、ディレクトリを変更する
ChDrive Left(strFOLDER, 1) '頭のドライブ文字のセット
ChDir strFOLDER 'フォルダーの変更
と、
カレントのドライブ、ディレクトリを選択されたフォルダーに変更します。
あとは、ラベルとリストボックスに新しい値をセットします。
↑無事、フォルダーが変更されました。
-【けんぞう！】---------------------------------------------------------
ASPが利用可能なレンタルサーバーをお探しのアナタ、
http://www.ken3.org/asp/server.html ← けんぞうも使っているサーバーの紹介
『おっIISでbasp21でメール送信、mdbも使えるよ』（三流ＰＧ：31歳）
------------------------------------------------------------------------
/*
* ４．終わりの挨拶
*/
今回は、
Excelのユーザーフォームで、
ラベルに情報を表示してみました。
.Captionにセットしただけなんだけど。
あとは、固定のフォルダーだとイヤなので、
フォルダー選択の関数を＋して、
カレントディレクトリの切り替えを可能としました。
すると、出てくるのが、
今、vb*.lzh固定でやっている、
これを自分でdoc*.lzhやmdb??.lzhなど、
ワイルドカードを入力したりし、パターンを変えたくなって来るよね。
汎用のファイル選択には、まだまだ程遠いかなぁ。
今回のサンプルファイルは、
http://www.ken3.org/vba/lzh/vba122.lzh
にvba122.xlsが保存されています。
テストして、遊んでみてください。
何かの参考となれば幸いです。
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
＜Excel 漢字のフリガナ候補の表示＞
どうも、三流プログラマーのＫｅｎ３です。
今回は、読者数６人の有料メルマガから宣伝で１つサンプルを出します。
/*
* １. 今回のキッカケ
*/
有料版のメルマガ、読者数６人まで減りました。
内容が薄いから？なんだけど・・・（オイオイ）
先月書いてたメルマガからサンプルを１つダイジェストで載せます。
気に入ったら、登録してみてください。
よろしくお願いします。
----- こんな感じで書いてます -----
/*
* １. 今日の狙い・・・
*/
今回は、
根拠の無いうらないツールを作ろうと思い、
ＩＭＥの辞書から固有名詞を取り出せないか？
なんてことを探っていたら、
フリガナの候補を表示する方法を見つけたので書きたいと思います。
※狙っていたのは、
今日のラッキーアイテムはパソコン、電車、ＸＸＸＸ
と固有名詞をランダムにＩＭＥ辞書から取り出し表示だったけど。
/*
* ２．Application.GetPhonetic (EXCEL)
*/
いろいろと探っていたら、本題とは違うけど、
Application.GetPhonetic (Excel2000)
なんてのを見つけました。
使い方は簡単で、
Sub aaa()
Dim strWORK As String
'呼び出しは簡単で、調べたい文字列を渡す
strWORK = Application.GetPhonetic("三流君")
While strWORK <> ""
Debug.Print strWORK
MsgBox strWORK
'次の候補を見たいときは、引数無しで呼び出す
strWORK = Application.GetPhonetic()
Wend
End Sub |
と、
strWORK = Application.GetPhonetic("三流君")
みたいに、まず探したい単語を引数で渡します。
すると読み方の候補が返ってきます。
漢字の読みかたっていろいろな候補があるので、
次の候補を取得したい場合は、
strWORK = Application.GetPhonetic()
と引数無しで呼び、
While strWORK <> ""
と、候補がなくなるまでループさせてます。
んっ、どこかで見た処理方法ですね。
えっ、どこで？
Ｄｉｒ関数でファイル名を取り出す時も、
はじめにファイルパターンを指定、
引数無しで呼び出してましたね。
応用技として、フリガナを振ってないデータがあったら、
Sub bbb()
Dim y As Long
y = 1 '1行目から調べる
While Cells(y, "A") <> ""
'B列にフリガナをセットする
Cells(y, "B") = Application.GetPhonetic(Cells(y, "A"))
y = y + 1
Wend
End Sub |
みたいにして、第一候補でフリガナを振ることも出来ます。
漢字はいろいろな読み方あるので、使えるかわからないけど。
/*
* ３．終わりの挨拶
*/
今回は、うらないツールを作ろうとして、漢字のフリガナを振る、
そんな関数を発見したので、紹介してみました。
もし、大量のデータにフリガナをフレと言われたら、
機械的に、
y = 1 '1行目から調べる
While Cells(y, "A") <> ""
'B列にフリガナをセットする
Cells(y, "B") = Application.GetPhonetic(Cells(y, "A"))
y = y + 1
Wend
みたいに振ってから、修正するのも一つの手だと思って。
これだと、ＩＭＥからデータ抜いて・・なんてツールもいらないですね。
う〜ん・・
次回は、もう少しマシな解説をしたいですが・・・
※できたら、世に出せるくらいのツールになるといいけど、、、
プログラム作りは簡単で面白いなぁと感じるような
解説／メールマガジンを書きたいと思ってます。
月400円は高いので、気長にヒット作を待てる人は購読続けて下さいね。
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
よろしくお願いします。
※ハヤク、効果のあるツール、サンプルを作らないと、、、
ＡＢ型の変わり者、三流プログラマーのＫｅｎ３でした。
-----
-【けんぞう！】---------------------------------------------------------
転職関係、在宅プログラマー、SOHOの広告まとめました
http://www.ken3.org/etc/500yen/zaitaku.html いろいろとあるので転機の人はぜひ
登録料無料、匿名で探せるので在宅で小金稼ぎの人も見てね
~~~~~~~~~~~~~~~~
オレ様、私は、ＳＥ様だ、月給３０万以上ボーナス100万を探すのもありだよ。
私にみたいにVBA少しできるぐらいだと仕事無いよ・・・なんて冷たく、
と軽く言われても匿名なら気にならないし（笑）
逆にこんな簡単な仕事で月給27万貰えるの？って会社もあるし、世の中イロイロ。
http://www.ken3.org/etc/500yen/job.html
------------------------------------------------------------------------
/*
* ２．終わりの挨拶
*/
どうでしたか？
えっ、これで月400円は高いって？
ですよねぇ・・作者本人も月400円、発行数が月４回か５回だろ？
１つ１００円の情報だとすると、
Excel2000のApplication.GetPhoneticでフリガナが・・・
そんな情報に１００円は高いよな。
ツールって言うなら、
^^^^^^^^^^^^^^^^^^^^
y = 1 '1行目から調べる
While Cells(y, "A") <> ""
'B列にフリガナをセットする
Cells(y, "B") = Application.GetPhonetic(Cells(y, "A"))
y = y + 1
Wend
とかじゃなくて、
せめて、
ファイル名(d:\zzz\aaa.xls)と漢字列(A列)・フリガナ列(B列)を選択したら、
実行する・・とか仕上げないと、１００円は払えないよね。
なんて、いつもの自分落としネタを書いておいて、
もし、興味を持った人が居たら、
http://www.ken3.org/pmagmag/office/
の下記、有料版のメルマガ、
Microsoft Officeで作るツールと業務システム
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
発行周期 毎週土曜日(年末年始除く)
購読料 400円/月
Microsoft Officeを使用してツール、業務のシステムを作成（手順を解説します）
主にExcel -- Accessの連携、VBAの解説です
初心者歓迎です、有料版なので遠慮しないでドンドン質問下さい。
毎週土曜日発行サンデープログラマーの楽しみ〜プロまで役立つツールを作りたいと
思ってます。
----
ヨロシク検討してね。
※あっ、有料版の特典が１つあった。
有料版読者の質問には、真っ先に答えてます。
（出来なかった質問も３人あって、たぶん解除されたんだけど・・・）
※金返せとメール来た時はショックだったけど・・・・
※無料版のほうが面白いけど、無料版を有料と思って購読してます
とメール来たのは、複雑な心境になったけど。
（有料版価値無いけど、無料版が役に立ったからお金払ってあげる？って感じ？）
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
＜IE _BeforeNavigate2イベントでPostデータを覗き見する＞
どうも、三流プログラマーのＫｅｎ３です。
今回は、読者数６人の有料メルマガから宣伝で１つサンプルを出します。
/*
* １. 今回のキッカケ
*/
有料版のメルマガ、読者数６人まで減りました。
内容が薄いから？なんだけど・・・（オイオイ）
先週発行したメルマガからサンプルを１つダイジェストで載せます。
気に入ったら、
http://www.ken3.org/pmagmag/office/
から、登録してみてください。
よろしくお願いします。
----- こんな感じで書いてます -----
[ Microsoft Officeで作るツールと業務システム No.032 ] 2003/09/06 毎週土曜日
＜IEの送信データを覗き見する＞
こんにちは、三流プログラマーのＫｅｎ３です。
http://www.ken3.org/p/office-032.lzh
に、
今回使用した、ＩＥのイベントを探るテストプログラムが圧縮されてます。
動かしてテストしてみてください。
(Access2000 形式のMDBです。)
/*
* １. 今日の狙い・・・
*/
今回は、ＩＥの送信データを覗き見、してみたいと思います。
なんて書いてますが、たいしたことなく、
Formなどで送信したデータを見るだけです。
/*
* ２．フォームにWebのコントロールを貼る
*/
まず、フォームにWebのコントロールを貼ります。
まず、Accessのフォーム作成で、
挿入・ActiveXコントロールを選択します。
次に、
Microsoft Web Browser コントロールを選択します。
すると、簡単にコントロールを貼ることが出来ます。
/*
* ３．ＩＥのイベントを探る
*/
通常、コントロールに対して、プロパティやメソッドを実行して、
操作を行います。
Private Sub cmdHOME_Click()
Me.WebBrowser0.GoHome
End Sub |
cmdHOMEとボタンのコントロールを作成後、
_Click()のクリックイベントに処理を記述してます。
記述した処理は、
Me.WebBrowser0.GoHome
Me.自分のフォーム
WebBrowser0 WebBrowserコントロール
.Gohome 初期ページへ飛ぶメソッド
を実行しただけです。
cmdHOME_Click()
は、ボタンのクリックイベントでした。
これと同様に、
WebBrowserコントロール
もイベントを持っています。
どのようなイベントがあるか、簡単な方法は、
左上のオブジェクトの選択で、
WebBrowser0(WebBrowserコントロール)
を
選択後、右上のイベントボックスをみるといろいろとあります。
↑選択のイメージ
今回は、
_BeforeNavigate2で、次のＵＲＬへ移る前のイベント、
_DocumentCompleteで、ドキュメントの完了
（_NavigateComplete2 の違い)
を探ってみます。
まず、
_BeforeNavigate2
のイベント。
このイベントは、次のＵＲＬに移る前に発生します。
Private Sub WebBrowser0_BeforeNavigate2( _
ByVal pDisp As Object, _
URL As Variant, _
Flags As Variant, _
TargetFrameName As Variant, _
PostData As Variant, _
Headers As Variant, _
Cancel As Boolean)
Debug.Print "URL:" & URL
Debug.Print "FlagsL:" & Flags
Debug.Print "PostData2" & StrConv(PostData, vbUnicode)
If Len(PostData) <> 0 Then
Me![txtSENDDATA] = StrConv(PostData, vbUnicode) '送信データのチェック
End If
End Sub |
テストのポイントは、
StrConv(PostData, vbUnicode)
と、送信データを変換して、テキストボックスにセットしてます。
このイベントが、次のＵＲＬに行く前に発生するので、
USER-NAME=%93%BD%96%BC%8A%F3%96%5D
など、通常は見えない、ＩＥがＷｅｂのＣＧＩへ送るデータを横取りしてます。
下記は、おまけのテストで、
_DocumentComplete
で、完了時にデータをセットしてます。
広告が別フレームで表示されている時も、発生して、少々うざいけど。
Private Sub WebBrowser0_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Debug.Print URL
Debug.Print pDisp.Document.Title
Me![txtURL] = URL
Me![txtTITLE] = pDisp.Document.Title
Me![txtHTML] = pDisp.Document.all(0).innerHTML
End Sub |
Private Sub WebBrowser0_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
Debug.Print "n:" & URL
Debug.Print "n:" & pDisp.Document.Title
End Sub |
/*
* ３．終わりの挨拶
*/
http://www.ken3.org/p/office-032.lzh
に、
今回使用した、ＩＥのイベントを探るテストプログラムが圧縮されてます。
動かしてテストしてみてください。
(Access2000 形式のMDBです。)
いろいろとデーターを送信するページでテストしてみてください。
掲示板やアンケート、いろいろなデータを送っているのがわかると思います。
これを応用して、自動実行、ＩＥ操作記録ツールなんてのを狙っているんだけどなぁ。
次回は、もう少しマシな解説をしたいですが・・・
※できたら、世に出せるくらいのツールになるといいけど、、、
プログラム作りは簡単で面白いなぁと感じるような
解説／メールマガジンを書きたいと思ってます。
月400円は高いので、気長にヒット作を待てる人は購読続けて下さいね。
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
よろしくお願いします。
※ハヤク、効果のあるツール、サンプルを作らないと、、、
ＡＢ型の変わり者、三流プログラマーのＫｅｎ３でした。
-----
-【けんぞう！】---------------------------------------------------------
転職関係、在宅プログラマー、SOHOの広告まとめました
http://www.ken3.org/etc/500yen/zaitaku.html いろいろとあるので転機の人はぜひ
登録料無料、匿名で探せるので在宅で小金稼ぎの人も見てね
~~~~~~~~~~~~~~~~
オレ様、私は、ＳＥ様だ、月給３０万以上ボーナス100万を探すのもありだよ。
私にみたいにVBA少しできるぐらいだと仕事無いよ・・・なんて冷たく、
と軽く言われても匿名なら気にならないし（笑）
逆にこんな簡単な仕事で月給27万貰えるの？って会社もあるし、世の中イロイロ。
http://www.ken3.org/etc/500yen/job.html
------------------------------------------------------------------------
/*
* ２．終わりの挨拶
*/
どうでしたか？
えっ、これで月400円は高いって？
ですよねぇ・・
Officeで作るツールと業務システム、、、とタイトルはリッパなんだけど、
中身がねぇ。
これなら、400円のシェアウエアを買ったほうがいいって？
ですよねぇ・・・
なんて、いつもの自分落としネタを書いておいて、
もし、興味を持った人が居たら、
http://www.ken3.org/pmagmag/office/
の下記、有料版のメルマガ、
Microsoft Officeで作るツールと業務システム
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
発行周期 毎週土曜日(年末年始除く)
購読料 400円/月
Microsoft Officeを使用してツール、業務のシステムを作成（手順を解説します）
主にExcel -- Accessの連携、VBAの解説です
初心者歓迎です、有料版なので遠慮しないでドンドン質問下さい。
毎週土曜日発行サンデープログラマーの楽しみ〜プロまで役立つツールを作りたいと
思ってます。
----
ヨロシク検討してね。
※あっ、有料版の特典が１つあった。
有料版読者の質問には、真っ先に答えてます。
（出来なかった質問も３人あって、たぶん解除されたんだけど・・・）
※金返せとメール来た時はショックだったけど・・・・
※無料版のほうが面白いけど、無料版を有料と思って購読してます
とメール来たのは、複雑な心境になったけど。
（有料版価値無いけど、無料版が役に立ったからお金払ってあげる？って感じ？）
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
検索して目的の情報を探す。
目的の情報を探すには、最近はググれとよく聞きます。なので、検索ボックスを付けました。
いろいろなキーワードを入れて、検索してみてください。
ページフッター
ここまで、読んでいただきどうもです。ここから下は、三流君宛のメッセージ送信や 三流君のホームページの紹介・案内です
目的の情報が見つかったか？少々心配しつつ、、、※質問や感想は、気軽に送ってくださいね。
質問や要望など メッセージを送る(三流君に連絡する)
質問や要望など連絡方法でお互い確認が取りやすく、便利なのが掲示板なのですが、私の対応のまずさから不定期で荒れてしまい、掲示板は現在封鎖中です。(反省しなきゃ)
|
|
感想や質問・要望・苦情など 三流君へメッセージを送る。
時間的余裕のある要望・質問・苦情の場合は、下記のフォームからメッセージを送ることができます。
|
急ぎで連絡がほしい、そんな時は:[三流君連絡先]に連絡してください。
リンクや広告など
項目別に↓に人気の記事をまとめてみました。お探しのジャンルを選択してください。
人気記事(来場者が多いTOP3):
[VBAでIE,WebBrowserを操作]・・・VBAでIE,WebBrowserを操作する サンプルです
[Access から Excel 連携 CreateObject("Excel.Application")]・・・AccessからExcelを操作したりデータの書き出しなどです
[VBAでOutlookの操作 CreateObject("Outlook.Application" )]・・・VBAからOutlookを使い、メール関係を処理するサンプルです
↑上記３つみたいなCreateObjectで他のアプリケーションを操作するサンプルが人気です。
開発時の操作:
[F1を押してHELPを見る]/
[Debug.Print と イミディエイトウインドウ]/
[実行時エラーでデバッグ]/
[ウォッチ式とSTOP]/
[参照設定を行う]
仕様書(設計書？) XXXX書類:
[基本設計書や要求仕様書]/
[テスト仕様書 テストデータ]/
[バグ票]/
[関数仕様書]/
[流れは 入力・処理・出力]
Excel関係:
[Excel UserFormを操作する]・・・エクセルでユーザーフォームを作成して入力などを行ってます
[ExcelからAccessを操作する]・・・ExcelからAccessのマクロを起動してみました、
[Excel関係 関数、その他]・・・その他Excel関係です
Access関係:
[Access UserForm/サブフォーム 操作]・・・アクセスでフォームを使ったサンプルです
[Access レポート操作]・・・レポートを操作してみました
[Access クエリーやその他関数]・・・あまりまとまってませんが、スポット的な単体関数の解説です
その他：VBAの共通関数やテキストファイルの操作など
[VBAでテキストファイル(TextFile)の操作]・・・普通のテキストファイルを使ったサンプルです
[VBA 標準関数関係とその他解説]・・・その他、グダグタ解説してます
Blog:[三流君の作業日記]/
[サンプルコードのゴミ箱]/
広告-[通販人気商品の足跡]
[三流君(TOP ken3.org へ戻る)]
/ [VBA系TOPへ]
/ [VBA系バックナンバー目次へ移動]
