インターネットを操る
Internet Explorerオブジェクト
Internet Explorerオブジェクト (InternetExplorer.Application)については、牟田口大介さんの、下記サイトで紹介されています。
Windows Script Host Laboratory
http://www.roy.hi-ho.ne.jp/mutaguchi/wsh/
Internet Explorerオブジェクト (InternetExplorer.Application)
http://www.roy.hi-ho.ne.jp/mutaguchi/wsh/object/ie.htm
Internet Explorer オブジェクト モデルへのアクセス
http://msdn.microsoft.com/library/ja/jpdnfp2k2/htm/odc_accessingie.asp
VBA便利帳
http://www2s.biglobe.ne.jp/~iryo/
ExcelVBAでInternetExplorerHTMLファイルを操作する方法
http://www2s.biglobe.ne.jp/~iryo/vba/IE/index00.html
↑ 上で紹介されているマクロを、一つの Excel Book に登録しました。→ OperateIEbyVBA.xls
Terr さんの、
選択IEオブジェクト取得関数
http://hp.vector.co.jp/authors/VA036013/script/GetSelectedIEObject.html
三流君VBAでIE操作 InternetExplorer.Applicationを操作する
http://www.ken3.org/cgi-bin/group/vba_ie.asp
三流君VBAでIE操作 まずは、参照設定から
http://www.ken3.org/cgi-bin/group/vba_ie_object.asp
↑ 動画を使った解説が、親切で分りやすいです
↓[名無しのボタンを押す(.Click)] は、珠玉のテクニックです。
http://www.ken3.org/cgi-bin/group/vba_ie.asp#Input_button_NoNAME
私はこれを知るまで、バカのように、IEの登録環境に合せて、TAB を数えてマウスを送って、ボタンクリックしていました。感謝!!
readyStateプロパティの値
https://www.javadrive.jp/javascript/ajax/index1.html
https://developer.mozilla.org/ja/docs/Web/API/XMLHttpRequest/readyState
documentオブジェクト
http://www.geocities.jp/mitaka_makita/html/script/document/document.html
IE8用「クロネコヤマト荷物問合せ」自動検索VBA
http://www.tokyocafe.net/slog/?eid=226
ウィンドウをマクロで操作
http://oshiete.goo.ne.jp/qa/4654756.html
インターネット・エクスプローラ IE のバージョンを調べる
インターネットを閲覧するブラウザである、インターネット・エクスプローラは、Version 7 から、タブ・ブラウザになりました。
このため、Internet Explorer のオブジェクトが変更になっているため、使っているIEのバージョンによって、VBAのコードを変える必要があります。
ここでは、IEのバージョンを取得します。
OSのバージョンとExcelのバージョンを取得 も参照下さい。
Sub IEのバージョンを調べる()
Dim ファイルシステムオブジェクト As Object
Set ファイルシステムオブジェクト = CreateObject ("Scripting.FileSystemObject ")
IEバージョン = ファイルシステムオブジェクト.GetFileVersion _
("C:\Program Files\Internet Explorer\IEXPLORE.EXE ")
MsgBox IEバージョン
IEバージョン = Left(IEバージョン, InStr (IEバージョン, ".") - 1)
Set ファイルシステムオブジェクト = Nothing
End Sub
解説:
GetFileVersion メソッド は、指定したファイルのバージョン番号を返します。
object .GetFileVersion(pathspec )
object 必ず指定します。FileSystemObject オブジェクトの名前を指定します。
pathspec 必ず指定します。指定したファイルの絶対パスまたは相対パスです。
引数 pathspec に指定した文字列の最後が名前付きのファイルになっていないか、指定したファイルにバージョン情報が含まれていない場合、GetFileVersion メソッドは長さ 0 の文字列 ("") を返します。
GetFileVersion メソッドは、パス文字列で指定された文字列に対してのみ処理を行います。指定されたパスを解決したり、指定されたパスが実際に存在するかどうかを確認したりしません。
MSXML2.XMLHTTP を使って、HTMLソースを取得
ブラウザの画面で何か操作する場合には、IEオブジェクトを使います。
しかし、ブラウザに表示される文字列を、データとして利用するために、HTMLソース を単純に取得するだけなら、MSXML2.XMLHTTP を使う方が高速なことを知りました。
IEオブジェクトを使わないので、IEのバージョンを取得 する必要もありません。
取得したHTMLソースは、まず、一行ずつに切り分けて配列に格納します。
そして、この配列を一行ずつHTMLのタグを利用して検索して、必要な文字列を取り出します。
HTMLソースを一行ずつに切り分けずに、HTMLのタグを利用して 正規表現オブジェクトの Executeメソッド を実行して、Matches コレクション、SubMatches コレクションから必要な文字列を取り出す こともできます。
追記:
インターネットから株価を取得2 (MSXML2.XMLHTTP を使う) も参照下さい。
MSXML2.XMLHTTP を使わずに、直接 URLから 直接 HTMLDocument を取得する 方法もあります。
ホームページ (DHolic) から写真リンクを取得
韓国発のファッション・ブランド DHolic(ディーホリック)の通販サイトには、美しいモデル写真がたくさん掲載されています。
https://www.dholic.co.jp/
対象カテゴリを指定して、該当する商品ページの写真 URL を一括取得するマクロを作ってみました。
写真(jpg)の URL が分かれば、Free Download Manager の「クリップボードのURLを貼り付け」機能を使えば、まとめてダウンロードできます。
dholic モデルの instagram アカウントまとめ
https://kumaos.xyz/entry/dholicmodel
Jin Hee
https://www.pinterest.jp/azmahaninoor/jin-hee/
Option Explicit
Option Base 1
'韓国発のファッションブランド DHOLIC(ディーホリック) の
'カテゴリページから索引ページを抽出して、
'対象URLを取得する。
'01:2021/02/22:作成
Public シート名 As String
Dim 対象URL As String
Dim HTMLソース As String
Dim 追加シート名 As String
Dim シート As Worksheet
Dim シート数 As Integer
Dim 写真URL As String
Dim Stime As Variant
Dim Etime As Variant
Dim 入力行 As Integer
Dim XMLHTTPオブジェクト As Object
Dim 対象シート As Worksheet
Dim 索引URL(100) As String
Dim 索引ページ As Integer
'★★★★★★★★★★★★★★★★★★★★★★★★
Sub 索引ページを抽出して対象ページURLを取得して写真URLを抽出()
Stime = Now()
Application.DisplayStatusBar = True
' 処理を高速化するため、画面描画停止
Application.ScreenUpdating = False
Call 索引ページ抽出
Call 対象ページURL取得
Call 写真URL取得
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly
End Sub
'★★★★★★★★★★★★★★★★★★★★★★★★
'★★★★★★★★★★★★★★★★★★★★★★★★
Private Sub 索引ページ抽出()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 出力行 As Integer
Dim URL開始 As Integer
Dim URL終了 As Integer
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
ThisWorkbook.Worksheets("カテゴリ指定").Activate
If Range("A1").Value = "" Then Exit Sub
対象URL = Range("A1").Value
索引ページ = 0
HTMLソース = HTML取得 (対象URL)
Debug.Print HTMLソース
'1行ずつに分割
文字配列 = Split(HTMLソース, vbLf)
'全体行数を取得
ページ行数 = UBound(文字配列)
'1行目から順に、最後の行まで
For 行数 = 1 To ページ行数
If InStr(文字配列(行数), "pnb_paging") > 0 Then
URL開始 = 0
URL終了 = 0
' Stop
索引ページ = 索引ページ + 1
URL開始 = InStr(文字配列(行数), "href=")
URL終了 = InStr(URL開始, 文字配列(行数), ">")
If URL開始 = 0 Or URL終了 = 0 Then
Stop
End If
URL開始 = URL開始 + 6
URL終了 = URL終了 - 2
索引URL(索引ページ) = Mid(文字配列(行数), URL開始, URL終了 - URL開始)
索引URL(索引ページ) = "https://www.dholic.co.jp/Nshopping/ItemShopping_detail.asp" & 索引URL(索引ページ)
' Stop
End If
Next 行数
End Sub
'★★★★★★★★★★★★★★★★★★★★★★★★
Private Sub 対象ページURL取得()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 出力行 As Integer
Dim URL開始 As Integer
Dim URL終了 As Integer
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim ページURL As String
Dim 直前抽出URL As String
追加シート名 = "対象URL"
'対象URLシートが既存なら、前もって削除
ThisWorkbook.Activate
' 作業中のブックのすべてのワークシートの名前を、For〜Nextで確認します。
For Each 対象シート In Worksheets
If 追加シート名 = 対象シート.Name Then
Application.DisplayAlerts = False
Worksheets(追加シート名).Delete
Application.DisplayAlerts = True
End If
Next
'単純に最後にシートを追加する
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = 追加シート名
Columns("A:A").ColumnWidth = 80
出力行 = 0
For 入力行 = 1 To 索引ページ
'索引ページ分繰返し
対象URL = 索引URL(入力行)
Application.StatusBar = 対象URL
ThisWorkbook.Worksheets(追加シート名).Activate
HTMLソース = HTML取得 (対象URL)
Debug.Print HTMLソース
'1行ずつに分割
文字配列 = Split(HTMLソース, vbLf)
'全体行数を取得
ページ行数 = UBound(文字配列)
'1行目から順に、最後の行まで
For 行数 = 1 To ページ行数
If InStr(文字配列(行数), "a href=") > 0 _
And InStr(文字配列(行数), "/Nshopping/GoodView_Item.asp?Gserial=") > 0 Then
URL開始 = 0
URL終了 = 0
' Stop
URL開始 = InStr(文字配列(行数), "/Nshopping/GoodView_Item.asp?Gserial=")
URL終了 = InStr(URL開始, 文字配列(行数), "&")
If URL開始 = 0 Or URL終了 = 0 Then
Stop
End If
URL開始 = URL開始
URL終了 = URL終了
ページURL = Mid(文字配列(行数), URL開始, URL終了 - URL開始)
ページURL = "https://www.dholic.co.jp" & ページURL
' Stop
If ページURL <> 直前抽出URL Then
出力行 = 出力行 + 1
Range("A1").Cells(出力行, 1).Value = ページURL
直前抽出URL = ページURL
'ハイパーリンクを設定
With Worksheets(追加シート名)
.Hyperlinks .Add .Range("A1").Cells(出力行, 1), 写真URL
End With
End If
End If
Next 行数
Next 入力行 '索引ページがなくなるまで繰返し
ThisWorkbook.Worksheets(追加シート名).Activate
End Sub
'韓国発のファッションブランド DHOLIC(ディーホリック) の指定ページから写真のURLを取得する。
'00:2021/02/21:作成
'02:2021/02/27:jpg 抽出条件追加
'03:2021/02/27:連想配列 を使って jpg 重複排除
Option Explicit
Option Base 1
Public シート名 As String
Public メッセージ As String
Public エラーメッセージ As String
Dim 対象URL As String
Dim HTMLソース As String
Dim 追加シート名 As String
Dim シート As Worksheet
Dim シート数 As Integer
Dim 写真URL As String
Dim 直前写真URL As String
Dim 入力行 As Integer
Dim XMLHTTPオブジェクト As Object
Dim 対象シート As Worksheet
'★★★★★★★★★★★★★★★★★★★★★★★★
Sub 写真URL取得()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 出力行 As Integer
Dim URL開始 As Integer
Dim URL終了 As Integer
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim 写真URL索引 As Object 'Scripting.Dictionary オブジェクト
'★写真URL索引を作成★
Set 写真URL索引 = CreateObject("Scripting.Dictionary") '★連想配列 の定義
追加シート名 = "写真URL"
'作品リストが既存なら、前もって削除
ThisWorkbook.Activate
' 作業中のブックのすべてのワークシートの名前を、For〜Nextで確認します。
For Each 対象シート In Worksheets
If 追加シート名 = 対象シート.Name Then
Application.DisplayAlerts = False
Worksheets(追加シート名).Delete
Application.DisplayAlerts = True
End If
Next
'単純に最後にシートを追加する
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = 追加シート名
Columns("A:A").ColumnWidth = 80
入力行 = 0
出力行 = 0
Do '対象URLの空白セルまで繰返し
入力行 = 入力行 + 1
ThisWorkbook.Worksheets("対象URL").Activate
If Range("A1").Cells(入力行, 1).Value = "" Then Exit Do
対象URL = Worksheets("対象URL").Range("A1").Cells(入力行, 1).Value
Application.StatusBar = 対象URL
' Stop
ThisWorkbook.Worksheets(追加シート名).Activate
HTMLソース = HTML取得 (対象URL)
Debug.Print HTMLソース
' '1行ずつに分割
' 文字配列 = Split(HTMLソース, vbLf)
'タグを使って分割
文字配列 = Split(HTMLソース, ">")
' Stop
'全体行数を取得
ページ行数 = UBound(文字配列)
' Stop
'1行目から順に、最後の行まで
For 行数 = 1 To ページ行数
' If InStr(文字配列(行数), "_info_") > 0
' And InStr(文字配列(行数), "<img") > 0 Then
' If 入力行 > 2 And 行数 > 3500 Then Stop
If InStr(文字配列(行数), "<img") > 0 _
And ((InStr(文字配列(行数), "Dahong") > 0) Or (InStr(文字配列(行数), "_info_") > 0)) _
And (InStr(文字配列(行数), "jpg") > 0 Or InStr(文字配列(行数), "JPG") > 0) Then
URL開始 = 0
URL終了 = 0
' Stop
URL開始 = InStr(文字配列(行数), "src=")
URL終了 = InStr(URL開始, 文字配列(行数), "jpg")
If URL終了 = 0 Then
URL終了 = InStr(URL開始, 文字配列(行数), "JPG")
End If
If URL開始 = 0 Or URL終了 = 0 Then
Stop
End If
URL開始 = URL開始 + 5
URL終了 = URL終了 + 3
写真URL = Mid(文字配列(行数), URL開始, URL終了 - URL開始)
' Stop
If InStr(写真URL, "https:") = 0 Then
写真URL = "https:" & 写真URL
End If
If 写真URL <> 直前写真URL Then
If 写真URL索引.Exists (写真URL) = False Then
'★写真URL が新規の場合
出力行 = 出力行 + 1
Worksheets(追加シート名).Range("A1").Cells(出力行, 1).Value = 写真URL
直前写真URL = 写真URL
写真URL索引(写真URL) = 出力行
'ハイパーリンクを設定
With Worksheets(追加シート名)
.Hyperlinks .Add .Range("A1").Cells(出力行, 1), 写真URL
End With
End If
End If
End If
Next 行数
Loop '対象URLの登録がなくなるまで繰返し
Set 写真URL索引 = Nothing '★連想配列 を削除
ThisWorkbook.Worksheets(追加シート名).Activate
End Sub
生成AI画像を一括ダウンロード
生成 AI を利用した画像ファイルを公開していただいている「エロココ!」というサイト を見つけました。
この大量の画像ファイルを一括ダウンロードするマクロを作成しました。
(マンガ・児童・挿入画像は、ダウンロードの対象から除外しています。)
私の環境で、30分程度で 2万5千点余り(2.5GB)の画像をダウンロードできました。
画像ダウンロード用のフォルダにこの Excelブックを保存します。
マクロを実行すると、サブフォルダをサイトのページ毎に作って画像ファイルをダウンロードします。
Excel画面の左下のステータスバーに進捗状況が表示されます。
ダウンロードした拡張子 webp のファイルは XnView を使うと簡単に jpg に変換できます。
注: 「エロココ! 」に掲示されている画像は、画像の作者が「創作的寄与 」した「AI生成物」だと私は考えます。
このためダウンロードした画像は、著作権法第30条により著作権者の許諾なく行うことができる、「私的使用のための複製 」に留めてください。
Option Explicit
Option Base 1
'01:2024/03/23:作成
Dim 対象URL As String
Dim HTMLソース As String
Dim 保存フォルダ As String
Dim 画像URL As String
Dim XMLHTTPオブジェクト As Object
'http://www.ken3.org/
'AB型の変わり者 三流プログラマー Ken3のHP
'の
'http://www.ken3.org/vba/backno/vba120.html
'URLDownloadToFile APIを使用してダウンロード
'を、そのまま使わせていただいています。感謝いたします。m(__)m
'URLDownloadToFile API from URLMON.
Private Declare PtrSafe 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 画像URL取得()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim Stime As Variant
Dim Etime As Variant
Dim 出力行 As Integer
Dim URL開始 As Integer
Dim URL終了 As Integer
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim ページURL As String
Dim 最初のquot As Integer
Dim 最終行 As Integer
Dim 処理行 As Integer
Stime = Now()
出力行 = 0
ページURL = ""
ThisWorkbook.Worksheets("対象URL").Activate
最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
For 処理行 = 1 To 最終行
保存フォルダ = Worksheets("対象URL").Range("A1").Cells(処理行, 1).Value
保存フォルダ = ThisWorkbook.Path & "\" & 保存フォルダ
If ページURL = "" Then
対象URL = Worksheets("対象URL").Range("B1").Cells(処理行, 1).Value
Else
対象URL = ページURL
ページURL = ""
End If
'進捗状況をステータスバーに表示
Application.StatusBar = 対象URL
HTMLソース = HTML取得 (対象URL)
' Debug.Print HTMLソース
' '1行ずつに分割
文字配列 = Split(HTMLソース, vbLf)
' Stop
'全体行数を取得
ページ行数 = UBound(文字配列)
' Stop
'1行目から順に、最後の行まで
For 行数 = 1 To ページ行数
If InStr(文字配列(行数), "ページが見つかりません") > 0 _
Or InStr(文字配列(行数), "ページが見つかりませんでした") > 0 Then
Exit For
End If
'複数ページの取得
If InStr(文字配列(行数), "<li class=""active"">") > 0 Then
' Stop
If InStr(文字配列(行数 + 1), "page=") > 0 Then
最初のquot = InStr(文字配列(行数 + 1), """")
ページURL = Mid(文字配列(行数 + 1), _
最初のquot + 1, InStr(最初のquot + 1, 文字配列(行数 + 1), """") - 最初のquot - 1)
' Stop
If Left(ページURL, 1) = "/" Then
ページURL = "https://les-koko.com" & ページURL
End If
' Stop
Else
ページURL = ""
End If
End If
' 画像取得
If InStr(文字配列(行数), "<img loading=""lazy""") > 0 Then
' Stop
URL開始 = 0
URL終了 = 0
' Stop
URL開始 = InStr(文字配列(行数), "data-src=")
URL終了 = InStr(URL開始, 文字配列(行数), ".webp")
URL開始 = URL開始 + 10
URL終了 = URL終了 + 5
画像URL = Mid(文字配列(行数), URL開始, URL終了 - URL開始)
' Stop
画像URL = Replace(画像URL, "../../", "")
' Stop
If Trim(画像URL) <> "" Then
Call ファイルダウンロード
End If
End If
Next 行数
If ページURL <> "" Then
処理行 = 処理行 - 1
End If
Next 処理行
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "hh時間nn分ss秒") & " でした。", vbOKOnly
Exit Sub
End Sub
'★★★★★★★★★★★★★★★★★★★★★★★★
Private Sub ファイルダウンロード()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 保存ファイル名 As String
Dim 結果 As Long
'ダウンロード先フォルダが存在しない場合は、作成する
If Dir(保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
MkDir 保存フォルダ
End If
' Stop
保存ファイル名 = Right(画像URL, Len(画像URL) - InStrRev(画像URL, "/"))
結果 = URLDownloadToFile (0, 画像URL, 保存フォルダ & "\" & 保存ファイル名, 0, 0)
' MsgBox "結果は:" & 結果 & " ← 0なら正常終了、0以外は失敗です。"
' MsgBox 保存ファイル名 & "に保存されました"
' Stop
End Sub
「青空文庫」から一括ダウンロード
ここで紹介するマクロは、インターネットの「青空文庫 」で公開されている文書ファイルを、一括ダウンロードするために書いたものです。
このマクロは、AozoraGetter の項で、ダウンロードできます。
Option Explicit
Option Base 1
Public シート名 As String
Public メッセージ As String
Public エラーメッセージ As String
Public ウインドウ数 As Integer
Public 処理 As String
Dim 作家名 As String
Dim 作品名 As String
Dim ファイルリスト() As String
Dim 対象URL As String
Dim HTMLソース As String
Dim 追加シート名初期 As String
Dim 追加シート名 As String
Dim 重複 As Integer
Dim シート As Worksheet
Dim シート数 As Integer
Dim ファイル種別 As String
Dim 圧縮 As String
Dim ファイルURL As String
Dim ファイル名 As String
Dim 文字集合と符号化方式 As String
Dim サイズ As String
Dim 初登録日 As String
Dim 最終更新日 As String
Dim 出力行 As Integer
Dim IEバージョン As String
Dim Stime As Variant
Dim Etime As Variant
Dim 入力行 As Integer
Dim XMLHTTPオブジェクト As Object
'★★★★★★★★★★★★★★★★★★★★★★★★
Sub 作家別作品リスト取得()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 作家別作品リストURL As String
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim 出力行 As Integer
Dim URL開始 As Integer
Dim URL終了 As Integer
Dim 作品URL As String
Dim As Integer
Stime = Now()
Application.ScreenUpdating = False
追加シート名初期 = "作品リスト"
追加シート名 = 追加シート名初期
For 重複 = 1 To 100
' 100枚まで追加しても重複しないように追番を設定します。
For Each シート In Worksheets
If シート.Name = 追加シート名 Then
追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
End If
Next シート
Next 重複
シート数 = Worksheets.Count
Worksheets("テンプレ作品").Copy After:=Worksheets(シート数)
ActiveSheet.Name = 追加シート名
入力行 = 0
出力行 = 0
Do '入力指示の作家名空白セルまで繰返し
入力行 = 入力行 + 1
ThisWorkbook.Worksheets("入力指示").Activate
If Range("A12").Cells(入力行, 1).Value = "" Then Exit Do
作家名 = Range("A12").Cells(入力行, 1).Value
作家別作品リストURL = Range("B12").Cells(入力行, 1).Value
対象URL = 作家別作品リストURL
ThisWorkbook.Worksheets(追加シート名).Activate
HTMLソース = HTML取得 (対象URL)
Debug.Print HTMLソース
'1行ずつに分割
文字配列 = Split (HTMLソース, vbNewLine )
'全体行数を取得
ページ行数 = UBound (文字配列)
If ページ行数 < 10 Then 'vbNewLine で分割できない場合
文字配列 = Split (HTMLソース, vbLf )
ページ行数 = UBound (文字配列)
End If
'1行目から順に、最後の行まで
= 0
For 行数 = 1 To ページ行数
If InStr (文字配列(行数), "../cards/") Then
出力行 = 出力行 + 1
= + 1
URL開始 = InStr (文字配列(行数), "../cards/") + 3
URL終了 = InStr (URL開始, 文字配列(行数), ">") - 1
作品URL = "http://www.aozora.gr.jp/" _
& Mid (文字配列(行数), URL開始, URL終了 - URL開始)
URL開始 = URL終了 + 2
URL終了 = InStr (URL開始, 文字配列(行数), "</li>", vbTextCompare )
If URL終了 = 0 Then
URL終了 = Len(文字配列(行数))
End If
作品名 = Trim(Mid (文字配列(行数), URL開始, URL終了 - URL開始))
作品名 = Replace (作品名, "</a>", "")
作品名 = Replace (作品名, "</A>", "")
Range("A2").Cells(出力行, 1).Value = 作家名
Range("B2").Cells(出力行, 1).Value =
Range("C2").Cells(出力行, 1).Value = 作品名
Range("D2").Cells(出力行, 1).Value = 作品URL
With Worksheets(追加シート名)
.Hyperlinks .Add .Range("D2").Cells(出力行, 1), 作品URL
End With
End If
Next 行数
Loop '作家の登録がなくなるまで繰返し
Application.ScreenUpdating = True
ThisWorkbook.Worksheets(追加シート名).Activate
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly
End Sub
'★★★★★★★★★★★★★★★★★★★★★★★★
Sub ファイルリスト取得()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 対象シート As Worksheet
Dim 作品URL As String
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim ファイル領域 As Integer
Dim TDカウンタ As Integer
Dim 文字列開始 As Integer
Dim 文字列終了 As Integer
Dim 作品パス As String
Dim 行文字列 As String
Dim 出力行数 As Integer
On Error GoTo エラー確認
Stime = Now()
' 処理を高速化するため、画面描画停止
Application.ScreenUpdating = False
シート名 = "作品リスト"
メッセージ = "「作品リスト」シートができていません。" _
& Chr(13) & "「A作品リスト取得」を先にして下さい。"
Call シートの存在チェック(シート名, メッセージ)
追加シート名初期 = "ファイルリスト"
追加シート名 = 追加シート名初期
For 重複 = 1 To 100
' 100枚まで追加しても重複しないように追番を設定します。
For Each シート In Worksheets
If シート.Name = 追加シート名 Then
追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
End If
Next シート
Next 重複
シート数 = Worksheets.Count
Worksheets("テンプレファイル").Copy After:=Worksheets(シート数)
ActiveSheet.Name = 追加シート名
出力行 = 1
入力行 = 0
Do '作品リストの最後まで
入力行 = 入力行 + 1
Dim 文字配列
Worksheets(シート名).Activate
作家名 = Range("A2").Cells(入力行, 1).Value
作品名 = Range("C2").Cells(入力行, 1).Value
If 作品名 = "" Then Exit Do '作品名の空白セルで判断して、終了。
作品URL = Range("D2").Cells(入力行, 1).Value
作品パス = Left(作品URL, InStrRev (作品URL, "/"))
対象URL = 作品URL
HTMLソース = HTML取得 (対象URL)
'1行ずつに分割
文字配列 = Split (HTMLソース, vbNewLine )
'全体行数を取得
ページ行数 = UBound (文字配列)
If ページ行数 < 10 Then
文字配列 = Split (HTMLソース, vbLf )
ページ行数 = UBound (文字配列)
End If
Debug.Print HTMLソース
'1行目から順に、最後の行まで
ファイル領域 = 0
出力行数 = 0
For 行数 = 1 To ページ行数
If InStr (文字配列(行数), "ファイル種別") Then
ファイル領域 = 1
End If
If ファイル領域 = 1 Then
If InStr (UCase(文字配列(行数)), "<TR") > 0 Then
If 出力行数 > 0 Then
Call ファイルリスト書出(出力行)
出力行 = 出力行 + 1
End If
出力行数 = 出力行数 + 1
TDカウンタ = 0
End If
If InStr (UCase(文字配列(行数)), "<TD>") > 0 Then
TDカウンタ = TDカウンタ + 1
Select Case TDカウンタ
Case 1
行文字列 = 文字配列(行数)
ファイル種別 = Trim (正規表現で置換 ("<(.*?)> ", 行文字列, ""))
If ファイル種別 = "" Then
行数 = 行数 + 1
行文字列 = 文字配列(行数)
ファイル種別 = Trim (正規表現で置換 ("<(.*?)> ", 行文字列, ""))
End If
Case 2
文字列開始 = InStr (文字配列(行数), ">") + 1
圧縮 = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
Case 3
If InStr (文字配列(行数), "files/") > 0 Then
文字列開始 = InStr (文字配列(行数), "files/")
文字列終了 = InStr (文字列開始, 文字配列(行数), ">") - 1
ファイルURL = 作品パス _
& Mid (文字配列(行数), 文字列開始 _
, 文字列終了 - 文字列開始)
文字列開始 = 文字列終了 + 2
ファイル名 = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
If InStrRev (ファイル名, "/") > 0 Then
ファイル名 = Right(ファイル名, Len(ファイル名) _
- InStrRev (ファイル名, "/"))
End If
Else
ファイルURL = "★無し?★"
行文字列 = 文字配列(行数)
ファイル名 = Trim(正規表現で置換 ("<(.*?)> ", 行文字列, ""))
End If
Case 4
文字列開始 = InStr (文字配列(行数), ">") + 1
文字集合と符号化方式 = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
Case 5
文字列開始 = InStr (文字配列(行数), ">") + 1
サイズ = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
Case 6
文字列開始 = InStr (文字配列(行数), ">") + 1
初登録日 = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
Case 7
文字列開始 = InStr (文字配列(行数), ">") + 1
最終更新日 = Mid (文字配列(行数), 文字列開始 _
, InStr (文字列開始, 文字配列(行数), "<") - 文字列開始)
Case Else ' その他の値の場合。
MsgBox "1 から 7 以外の数値"
Exit Sub
End Select
End If
If InStr (UCase(文字配列(行数)), "</TABLE>") > 0 Then
Call ファイルリスト書出(出力行)
出力行 = 出力行 + 1
Exit For
End If
End If
Next 行数
Loop '作品リストの最後まで繰返し
' 画面描画再開
Application.ScreenUpdating = True
ThisWorkbook.Worksheets(追加シート名).Activate
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly
Exit Sub
エラー確認:
エラーメッセージ = "ウインドウ数= " & ウインドウ数 & " エラー位置= " & 処理 & Chr(13) _
& "作家名= " & 作家名 & " , 入力行= " & 入力行 & Chr(13) _
& "作品名=" & 作品名 & Chr(13) _
& "エラー番号 " & Str(Err.Number) & " , " & Err.Source & _
" でエラーが発生しました。" & Chr(13) & Err.Description
Debug.Print エラーメッセージ
MsgBox エラーメッセージ, , "エラー", Err.HelpFile, Err.HelpContext
Stop
End Sub
'***************************************
Private Sub ファイルリスト書出(出力行)
'***************************************
Dim 図書カードm品名 As String
Dim 図書カードctァイル名 As String
ThisWorkbook.Worksheets(追加シート名).Activate
Range("A2").Cells(出力行, 1).Value = 作家名
Range("B2").Cells(出力行, 1).Value = 作品名
Range("C2").Cells(出力行, 1).Value = ファイル種別
Range("D2").Cells(出力行, 1).Value = 圧縮
Range("E2").Cells(出力行, 1).Value = ファイル名
Range("F2").Cells(出力行, 1).Value = ファイルURL
Range("G2").Cells(出力行, 1).Value = 文字集合と符号化方式
Range("H2").Cells(出力行, 1).Value = サイズ
Range("I2").Cells(出力行, 1).Value = 初登録日
Range("J2").Cells(出力行, 1).Value = 最終更新日
図書カードm品名 = Mid (作品名, InStr (作品名, ":") + 1 _
, InStr (InStr (作品名, ":"), 作品名, ")") - InStr(作品名, ":") - 1)
If InStr(ファイル名, "_") > 0 Then
図書カードctァイル名 = Left(ファイル名, InStr (ファイル名, "_") - 1)
Else
図書カードctァイル名 = Left(ファイル名, InStr (ファイル名, ".") - 1)
End If
If 図書カードm品名 <> 図書カードctァイル名 Then
Range("B2").Cells(出力行, 1).ColorIndex = 3
Range("E2").Cells(出力行, 1).ColorIndex = 3
Range("K2").Cells(出力行, 1).Value = "図書カードus一致"
' Stop
End If
End Sub
Sub シートの存在チェック(シート名, メッセージ)
Dim 対象シート As Worksheet
ThisWorkbook.Activate
' 作業中のブックのすべてのワークシートの名前を、For〜Nextで確認します。
For Each 対象シート In Worksheets
If シート名 = 対象シート.Name Then
Exit Sub
End If
Next
MsgBox メッセージ
End
End Sub
解説:
Split 関数 は、各要素ごとに区切られた文字列から 1 次元配列を作成し、返します。
インデックス番号は、0から始まる 点に、要注意です。
Option Base ステートメントを使っても、変わりません。
構文
Split (expression[, delimiter[, limit[, compare ]]] )
指定項目 説明
expression 必ず指定します。文字列と区切り文字を含んだ文字列式を指定します。引数 expression が長さ 0 の文字列 ("") である場合、Split 関数は、要素もデータもない空の配列を返します。
delimiter 省略可能です。文字列の区切りを識別する文字を指定します。引数 delimiter を省略すると、区切り文字にスペース (" ") が使用されます。引数 delimiter が長さ 0 の文字列 ("") である場合は、引数 expression 全体の文字列を含む単一の要素の配列を返します。
タイプ ライブラリ で定義された定数や、文字コードを使うこともできます。
limit 省略可能です。返す配列の要素数を指定します。-1 を指定すると、すべての文字列を含んだ配列を返します。
compare 省略可能です。文字列式を評価するときに使用する文字列比較のモードを表す数値を指定します。
Join 関数 は、Split 関数 とは逆に、配列に含まれる各要素の内部文字列を結合して作成される文字列を返します。
構文Join (sourcearray [, delimiter ])
指定項目 説明
sourcearray 必ず指定します。結合する文字列を含む 1 次元配列を指定します。
delimiter 省略可能です。戻り値となる文字列を区切るのに使用する文字を指定します。省略すると、スペース (" ") が使用されます。引数 delimiter が長さ 0 の文字列 ("") である場合は、リスト内のすべての項目が区切り文字なしで連結されます。
Hyperlinks オブジェクト は、ワークシートまたはセル範囲のハイパーリンクのコレクションを表します。
各ハイパーリンクは、Hyperlink オブジェクトで表されます。
Hyperlinks コレクションを取得するには、Hyperlinks プロパティを使用します。
ハイパーリンクを作成し、それを Hyperlinks コレクションに追加するには、Add メソッド を使用します。
次の使用例は、ワークシート 1 上のハイパーリンクで "Microsoft" という単語を含むものを調べます。
Visual Basic for Applications
For Each h in Worksheets(1).Hyperlinks
If InStr (h.Name, "Microsoft") <> 0 Then h.Follow
Next
次の使用例は、セル E5 に新しいハイパーリンクを作成します。
Visual Basic for Applications
With Worksheets(1)
.Hyperlinks.Add .Range("E5"), "http://www.gohere.com"
End With
ファイルをダウンロード
ここで紹介するマクロは、インターネットの「青空文庫 」で公開されている文書ファイルを、一括ダウンロードするために書いたものです。
このマクロは、AozoraGetter の項で、ダウンロードできます。
Option Explicit
Option Base 1
'http://www.ken3.org/
'AB型の変わり者 三流プログラマー Ken3のHP
'の
'http://www.ken3.org/vba/backno/vba120.html
'URLDownloadToFile APIを使用してダウンロード
'を、そのまま使わせていただいています。感謝いたします。m(__)m
'URLDownloadToFile API from URLMON.
Private Declare PtrSafe 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 青空文庫ファイルダウンロード()
'★★★★★★★★★★★★★★★★★★★★★★★★
Dim 行数 As Integer
Dim Stime As Variant
Dim Etime As Variant
Dim 結果
Dim ダウンロードファイルパス As String
Dim ファイル保存フォルダ As String
Dim 保存ファイル名 As String
Dim 作品名 As String
Dim 作家別保存先(100, 2) As String '作家名、ファイル保存フォルダ
Dim 入力行 As Integer
Dim 作家 As Integer
Dim フォルダ階層数 As Integer
Dim カウンタ As Integer
Dim パス As String
Stime = Now()
入力行 = 0
ThisWorkbook.Worksheets("入力指示").Activate
Do '入力指示の作家名空白セルまで繰返し
入力行 = 入力行 + 1
If Range("A12").Cells(入力行, 1).Value = "" Then Exit Do
作家別保存先(入力行, 1) = Range("A12").Cells(入力行, 1).Value
作家別保存先(入力行, 2) = Range("C12").Cells(入力行, 1).Value
Loop '作家の登録がなくなるまで繰返し
On Error GoTo エラー確認
シート名 = "ファイルリスト"
メッセージ = "「ファイルリスト」シートができていません。" _
& Chr(13) & "「A作品リスト取得」「Bファイルリスト取得」を先にして下さい。"
Call シートの存在チェック(シート名, メッセージ)
ThisWorkbook.Worksheets("ファイルリスト").Activate
行数 = 0
Do
行数 = 行数 + 1
ダウンロードファイルパス = Range("F2").Cells(行数, 1).Value
If ダウンロードファイルパス = "" Then Exit Do
作品名 = Range("B2").Cells(行数, 1).Value
If InStr (作品名, "(") > 0 Then
作品名 = Trim (Left(作品名, InStr (作品名, "(") - 1))
End If
For 作家 = 1 To 入力行 - 1
If 作家別保存先(作家, 1) = Range("A2").Cells(行数, 1).Value Then
ファイル保存フォルダ = 作家別保存先(作家, 2)
Exit For
End If
Next 作家
'「Cダウンロード先フォルダ」が存在しない場合は、作成する
フォルダ階層数 = 出現回数 (ファイル保存フォルダ, "\\") '正規表現で \ はエスケープ文字なので重ねる
For カウンタ = 1 To フォルダ階層数 - 1
'最初の階層から順に確認して、無ければ作っていく
パス = Left(ファイル保存フォルダ, 出現位置 (ファイル保存フォルダ, "\\", カウンタ + 1) - 1)
If Dir (パス, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
MkDir パス
End If
Next カウンタ
'最後のフォルダ階層
If Dir (ファイル保存フォルダ, vbDirectory) = "" Then 'この名前のフォルダが存在しなければ
MkDir ファイル保存フォルダ
End If
保存ファイル名 = ファイル保存フォルダ & "\" _
& 作品名 & Range("E2").Cells(行数, 1).Value
結果 = URLDownloadToFile (0, ダウンロードファイルパス, 保存ファイル名, 0, 0)
' MsgBox "結果は:" & 結果 & " ← 0なら正常終了、0以外は失敗です。"
' MsgBox 保存ファイル名 & "に保存されました"
If 結果 <> 0 Then
Range("K2").Cells(行数, 1).Value = 結果
End If
Loop '空白セルが来るまで、繰返し
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly
Exit Sub
エラー確認:
エラーメッセージ = "エラー番号 " & Str(Err.Number) & Err.Source & _
" でエラーが発生しました。" & Chr(13) & Err.Description
MsgBox エラーメッセージ, , "エラー", Err.HelpFile, Err.HelpContext
End Sub
解説:
URLDownloadToFile 関数 は、インターネットからビットを ダウンロード して、ファイルに保存します。
http://msdn2.microsoft.com/en-us/library/ms775123.aspx
http://msdn2.microsoft.com/en-us/library/aa923795.aspx
構文
HRESULT URLDownloadToFile(
LPUNKNOWN pCaller ,
LPCTSTR szURL ,
LPCTSTR szFileName ,
DWORD dwReserved ,
LPBINDSTATUSCALLBACK lpfnCB
);
pCaller
ActiveX コンポーネントから呼び出して使える、Microsoft ActiveX コンポーネントの IUnknown インタフェースを制御するポインタです。
呼び出すアプリケーションが ActiveX コンポーネントでない場合は、この値をNULLに設定できます。
それ以外の場合は、呼び出し元は、HTMLページの文脈のActiveX コントロールのように、別のコンポーネントに含まれているコンポーネント・オブジェクト・モデル(COM)オブジェクトです。
このパラメタは、呼び出し元のコンポーネントの、最も外側の IUnknown を表します。
この関数は、ActiveXクライアント・フレームワークの文脈の中で、ダウンロードを試みます。そして、呼び出し元のコンテナが、ダウンロードの進行状況を受信できるようします。
szURL
ダウンロードする URL を含む文字列のポインタです。 NULL に設定することはできません。
szFileName
ダウンロードするビットで作成するファイル名を含む、文字列のポインタ。
(渡辺 注:このパラメータを使って、ダウンロードしたファイルに、自分で名前を付けられる、という意味です。)
dwReserved
予約されています。 0 にする必要があります。
lpfnCB
呼び出し元 IBindStatusCallback インターフェイスのポインタです。
URLDownloadToFileは、データの到着を含む、接続活動に、このインタフェースIBindStatusCallback::OnProgressメソッドを呼び出します。
IBindStatusCallback::OnDataAvailable メソッドは、呼び出されることはありません。
IBindStatusCallback::OnProgressを使って、呼び出し元は、ユーザーインタフェースか、他の進行状況監視機能を実装できます。
IBindStatusCallback::OnProgress呼び出しから、E_ABORTを返すことで、ダウンロード操作を中止できます。
これを NULL に設定できます。
この関数は、次の表に示す、値の 1 つを返します。
Value Description
E_OUTOFMEMORY
バッファの長さが無効か、もしくは、操作を完了するためのメモリが不足しています。
S_OK
操作に成功しました。
INET_E_DOWNLOAD_FAILURE
指定されたリソースのダウンロードは失敗しました。
クライアントは、通知コールバックを使って、進行状況を知ることができます。
ファイルをアップロード
ここでは、複数のファイルを、IEの画面で、アップロードするマクロを紹介します。
IEの画面のテキスト・ボックスには、value= で文字を入力できますが、input type="file" の要素の場合は、セキュリティのためこの方法が使えません。
このため、下記のマクロでは、IEの画面を前面表示させて、キー入力でファイルパス名をセットしています。
注1:プログラム開発関連 で紹介している UWSC は、ファイル名をキー入力を使わずに設定できます。
注2:IE8〜では、キー入力も使えなくなりました。 ファイル名(ファイル・パス)を入力 の項で、WSHを使って、ファイル名を入力させる方法を追記しました。
Option Explicit
Option Base 1
Dim 配列()
Dim HTMLソース As String
Dim 最終行 As Long
Dim ファイル件数 As Long
Dim 監視モード As String
Dim メッセージ As String
Dim Inputタグオブジェクト As Object 'Inputタグ格納用
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim ファイルシステムオブジェクト As Object ' FileSystemObject
Dim 出力テキストストリームオブジェクト As Object ' TextStream
Dim カウンタ再処理 As Integer
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。
Sub 処理開始()
開始日時 = Now ' 開始時刻を変数に格納します。
カウンタ再処理 = 0
Call ベアマウス 終了
Call 指定秒待つ(2)
Call ベアマウス 起動
Call ファイルアップロード
終了日時 = Now
MsgBox "処理時間は、" _
& Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub
' ★★★★★★★★★
Sub ファイルアップロード()
Dim IEオブジェクト As Object
Dim URL As String 'URL
Dim ファイル名 As String
Dim 行 As Long
Dim スタート行 As Long
Dim ファイル種別 As String
Dim 出力ファイル名 As String
Dim 出力行 As String
Dim 現在のパス As String
Dim カウンタ検索 As Long
Dim カウンタ更新 As Long
Dim 環境 As String
Dim エラー番号 As Integer
Dim カウンタ As Integer
Dim WshShell As Object
カウンタ検索 = 0
カウンタ更新 = 0
'処理対象を配列に読み込み
ThisWorkbook.Worksheets("ファイル名").Activate
'デフォルト設定
ファイル種別 = Range("B7").Value
スタート行 = Range("A9").Value
If Range("G8").Value = True Then
監視モード = "監視モード"
Else
監視モード = ""
End If
If Range("B4").Value = 1 Then
環境 = "インターネット"
URL = "https://GU120100.do?EVENT_ID=E00"
Else
' 環境 = "イントラネット"
URL = "https://GU120100.do?EVENT_ID=E00"
End If
'変換対象のファイル名とパス取得
現在のパス = ActiveWorkbook.Path
If Mid(Time, 2, 1) <> ":" Then ' 0時台は、0:01:05などとなるための対応
出力ファイル名 = 現在のパス & "\" & ファイル名 & "ファイル名" & _
Left(Date, 4) & Mid(Date, 6, 2) & Right(Date, 2) & "_" & _
Left(Time, 2) & Mid(Time, 4, 2) & Right(Time, 2) & ".txt"
Else
出力ファイル名 = 現在のパス & "\" & ファイル名 & "ファイル名" & _
Left(Date, 4) & Mid(Date, 6, 2) & Right(Date, 2) & "_" & _
"0" & Left(Time, 1) & Mid(Time, 3, 2) & Right(Time, 2) & ".txt"
End If
Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
' 指定ファイルをOPEN(出力モード)
Set 出力テキストストリームオブジェクト = _
ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
'登録データ読み込み
最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
ファイル件数 = 最終行 - 10
ReDim 配列(ファイル件数, 5)
配列 = Range("A11").Resize(ファイル件数, 5).Value
'Webページ表示
Set IEオブジェクト = CreateObject("InternetExplorer.Application")
With IEオブジェクト
.Navigate URL
.Visible = True
End With
'画面表示待ち
While IEオブジェクト.ReadyState <> 4 'READYSTATE_COMPLETE = 4
While IEオブジェクト.Busy = True
Sleep (100) '特に何もしないで.Busyの状態が変わるまで待つ
Wend
Sleep (1000)
Wend
Set WshShell = CreateObject("Wscript.Shell")
WshShell .AppActivate "ファイルアップロード" 'タイトルが左記で終わるウィンドウを探し、前面に表示させる。
Set WshShell = Nothing
' ★★★★★★★★★
For 行 = スタート行 To ファイル件数
' ★★★★★★★★★
If 監視モード = "" Then
Call 指定秒待つ(1) '指定秒待つ
End If
もう一度繰返し:
ファイル名 = 配列(行, 2)
ファイル名 = 現在のパス & "\" & ファイル名
'ドロップダウンリストの選択
Select Case ファイル種別
Case "品目ファイル"
IEオブジェクト.Document.forms(0)("classification").Value = "item"
Case "機種ファイル"
IEオブジェクト.Document.forms(0)("classification").Value = "model"
Case "構成ファイル"
IEオブジェクト.Document.forms(0)("classification").Value = "struct"
Case "チェーンファイル"
IEオブジェクト.Document.forms(0)("classification").Value = "chain"
Case "工場ファイル"
IEオブジェクト.Document.forms(0)("classification").Value = "factory"
End Select
SendKeys "{TAB}", True
Call 指定秒待つ(1)
SendKeys ファイル名, True
Call 指定秒待つ(1)
Do While IEオブジェクト.Busy = True
Call 指定秒待つ(1)
Loop
Call 指定秒待つ(1)
'Stop
カウンタ検索 = カウンタ検索 + 1
For Each Inputタグオブジェクト In IEオブジェクト.Document.all.tags("INPUT") 'Inputのタグを.allから抜く
If Inputタグオブジェクト.Value = "アップロード" Then '.Value値(ボタンの名称) が 「検索」 か?
Inputタグオブジェクト.Click '見つけたINPUTオブジェクト(ボタン)を.Clickクリックする
Exit For '用が済んだので(見つかったので)ループを抜ける
End If
Next
While IEオブジェクト.ReadyState <> 4 'READYSTATE_COMPLETE = 4
While IEオブジェクト.Busy = True
Call 指定秒待つ(1)
Wend
Wend
'Stop
For カウンタ = 1 To 6
Call 指定秒待つ(10)
Next カウンタ
'表示したページの<BODY>部のHTMLを取得
HTMLソース = IEオブジェクト.Document.Body.innerHTML
配列(行, 1) = 行
'Stop
Call bodyデータ抽出
' Stop
配列(行, 3) = メッセージ
If メッセージ = "現在、バッチが起動中のため当画面は使用できません。" Then
For カウンタ = 1 To 6
Call 指定秒待つ(10)
Next カウンタ
GoTo もう一度繰返し
End If
Range("A9").Value = 行
For カウンタ = 1 To 6
Call 指定秒待つ(10)
Next カウンタ
次の行へ:
出力行 = 配列(行, 1) & vbTab & 配列(行, 2) & vbTab & 配列(行, 3) & vbTab & 配列(行, 4) & vbTab & 配列(行, 5) _
& vbTab & Date & vbTab & Time
出力テキストストリームオブジェクト.WriteLine 出力行 ' 改行(CrLf)付き
HTMLソース = ""
Next 行
終了処理:
出力テキストストリームオブジェクト.Close
Set 出力テキストストリームオブジェクト = Nothing
Set ファイルシステムオブジェクト = Nothing
IEオブジェクト.Quit
Set IEオブジェクト = Nothing
Exit Sub
End Sub
Private Sub bodyデータ抽出()
Dim 文字配列
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim 列数 As Integer
Dim 読み込み対象 As String
Dim 開始文字目 As Integer
Dim 終了文字目 As Integer
Dim 判定 As String
'1行ずつに分割
文字配列 = Split(HTMLソース, vbNewLine)
'全体行数を取得
ページ行数 = UBound(文字配列)
'1行目から順に、最後の行まで
読み込み対象 = ""
メッセージ = ""
列数 = 1
For 行数 = 1 To ページ行数
If InStr(文字配列(行数), "messagearea") > 0 Then
If InStr(文字配列(行数), "現在、バッチが起動中のため当画面は使用できません") > 0 Then
メッセージ = "現在、バッチが起動中のため当画面は使用できません。"
ElseIf InStr(文字配列(行数), "ファイルタイプ、文字コードを確認してください") > 0 Then
メッセージ = "ファイルタイプ、文字コードを確認してください。"
ElseIf InStr(文字配列(行数), "データ内にダブルクォーテーションは入力できません") > 0 Then
メッセージ = Mid(Trim(文字配列(行数)), 23, Len(Trim(文字配列(行数))) - 69)
Else
メッセージ = Mid(Trim(文字配列(行数)), 23, Len(Trim(文字配列(行数))) - 69)
End If
Exit For
End If
Next 行数
End Sub
Private Sub 指定秒待つ(待ち時間 As Integer)
Sleep (待ち時間 * 1000)
End Sub
解説:
AppActivate メソッド は、アプリケーション ウィンドウをアクティブにします。
object.AppActivate title
引数
object
WshShell オブジェクトです。
title
アクティブにするアプリケーションを指定します。
この引数には、アプリケーションのタイトル バーに表示されるタイトル文字列か、アプリケーションのプロセス ID を指定できます。
AppActivate メソッドは、プロシージャ コールが正常終了したかどうかを示すブール値を返します。
このメソッドを呼び出すと、指定されたアプリケーションまたはウィンドウにフォーカスが移りますが、最大化と最小化には影響がありません。
参照:Window を操作(終了・アクティブ・元のサイズに戻す・最前面に表示・最小化)
ユーザーがフォーカスを切り替えたりウィンドウを閉じたりすると、アクティブなアプリケーション ウィンドウからフォーカスが移ります。
実行中の各アプリケーションのタイトル文字列を title と比較することで、どのアプリケーションがアクティブになるかが決まります。
完全に一致するタイトルが見つからない場合、タイトル文字列の先頭が title と一致するアプリケーションがアクティブになります。
そのようなアプリケーションが見つからない場合、タイトル文字列の最後が title と一致するアプリケーションがアクティブになります。
名前が title と一致するアプリケーションのインスタンスがいくつかある場合、アクティブになるインスタンスは不定です。
使用例
次のコードは、VBScript で記述された例です。ジョブの機能は、Windows の電卓を起動して簡単な計算を実行するキーストロークを送ります。
この例では、Windows の電卓を起動し、AppActivate を使って電卓が一番手前に表示されるようにしています。
<script language="VBScript">
set WshShell = WScript.CreateObject("WScript.Shell")
WshShell .Run "calc"
WScript.Sleep 100
WshShell .AppActivate "Calculator"
WScript.Sleep 100
WshShell .SendKeys "1{+}"
WScript.Sleep 500
WshShell .SendKeys "2"
WScript.Sleep 500
WshShell .SendKeys "~"
WScript.Sleep 500
WshShell .SendKeys "*3"
WScript.Sleep 500
WshShell .SendKeys "~"
WScript.Sleep 2500
</script>
参照:
スクリプトを実行する | WshShell オブジェクト | SendKeys メソッド
テキスト・データを取得
上では 、ホームページのHTMLソースを取得しましたが、ここでは、テキスト・データのみを取得します。
パソコンで開いている全てのページのテキスト・データを対象に、Excelシートに取り込みます。
使い方は、色々考えられます。例えば・・・・ 。
フレームで構成されたページについても、それなりに出力します。
Option Explicit
Option Base 1
Dim ブラウザ
Dim HTMLテキスト As String
Dim 画面数
Dim ページ行数 As Integer
Dim 行数 As Integer
Dim 追加シート名 As String
Sub 表示されているページのテキストを取得()
Dim ファイルシステムオブジェクト
Dim プログラム名
Dim ブラウザ配列()
Dim HTML配列()
Dim 追加シート名初期 As String
Dim 重複 As Integer
Dim シート As Worksheet
Dim シート数 As Integer
Dim Stime As Variant
Dim Etime As Variant
Stime = Now()
追加シート名初期 = "HTMLテキスト"
追加シート名 = 追加シート名初期
For 重複 = 1 To 100
' 100枚まで追加しても重複しないように追番を設定します。
For Each シート In Worksheets
If シート.Name = 追加シート名 Then
追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
End If
Next シート
Next 重複
シート数 = Worksheets.Count
Worksheets("テンプレート").Copy After:=Worksheets(シート数)
ActiveSheet.Name = 追加シート名
Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
画面数 = 1
For Each ブラウザ In CreateObject("Shell.Application").Windows
プログラム名 = ファイルシステムオブジェクト.GetFileName(ブラウザ.FullName)
If LCase (プログラム名) = "iexplore.exe" Then
Dim 文字配列
Erase HTML配列
ReDim Preserve ブラウザ配列(1, 画面数)
ブラウザ配列(1, 画面数) = ブラウザ.LocationURL
画面数 = 画面数 + 1
HTMLテキスト = ブラウザ.Document.body.innerText
If HTMLテキスト = "" Then '取得するテキストがない場合にも、エラーにならぬように
HTMLテキスト = "★空白★" & vbNewLine & "☆空白☆"
End If
'1行ずつに分割
文字配列 = Split (HTMLテキスト, vbNewLine )
'全体行数を取得
ページ行数 = UBound (文字配列)
ReDim HTML配列(ページ行数 + 1, 1)
For 行数 = 0 To ページ行数
If LenMbcs (CStr(文字配列(行数))) > 900 Then 'セルの文字数オーバー対策
文字配列(行数) = CStr(MidMbcs (文字配列(行数), 1, 900)) & "★900文字以上★"
End If
HTML配列(行数 + 1, 1) = 文字配列(行数)
Next 行数
Worksheets(追加シート名).Activate
Range("A1").Cells(1, 画面数) = ブラウザ.Document.Title
Range("A2").Cells(1, 画面数) = ブラウザ.LocationURL '対象URL
Range("A3").Cells(1, 画面数) = ページ行数 + 1
Range("A4").Cells(1, 画面数).Resize(ページ行数 + 1, 1).Value = HTML配列
If HTMLテキスト = "★空白★" & vbNewLine & "☆空白☆" Then
Call フレームチェック
End If
'Stop
End If
Next
Set ファイルシステムオブジェクト = Nothing
Etime = Now()
MsgBox "処理が終了しました。" & Chr(13) _
& "処理時間は、" & Format(Etime - Stime, "nn分ss秒") & " でした。", vbOKOnly
End Sub
'★★★★★★★★★★★★★★★★★★★★★★★★
Private Sub フレームチェック()
'AB型の変わり者 三流プログラマー Ken3のHP
'http://www.ken3.org/
'の
'InternetExplorer操作 Frameと遊ぶ Objectを探る方法
'http://www.ken3.org/vba/backno/vba116.html
'のコードを使わせていただきました。m(__)m
On Error Resume Next
Dim FRAMEオブジェクト As FramesCollection
Dim フレーム数 As Integer
Set FRAMEオブジェクト = ブラウザ.Document.frames 'フレームの代入
If FRAMEオブジェクト.length > 0 Then 'フレームの数
'フレームの抽出
For フレーム数 = 0 To FRAMEオブジェクト.length - 1
HTMLテキスト = FRAMEオブジェクト(フレーム数).Document.body.innerText
画面数 = 画面数 + 1
Dim 文字配列
'1行ずつに分割
文字配列 = Split (HTMLテキスト, vbNewLine )
'全体行数を取得
ページ行数 = UBound (文字配列)
ReDim HTML配列(ページ行数 + 1, 1)
For 行数 = 0 To ページ行数
If LenMbcs (CStr(文字配列(行数))) > 900 Then 'セルの文字数オーバー対策
文字配列(行数) = CStr(MidMbcs (文字配列(行数), 1, 900)) & "★900文字以上★"
End If
HTML配列(行数 + 1, 1) = 文字配列(行数)
Next 行数
Worksheets(追加シート名).Activate
Range("A1").Cells(1, 画面数) = ブラウザ.Document.Title
Range("A2").Cells(1, 画面数) = ブラウザ.LocationURL '対象URL
Range("A3").Cells(1, 画面数) = ページ行数 + 1
Range("A4").Cells(1, 画面数).Resize(ページ行数 + 1, 1).Value = HTML配列
Next フレーム数
End If
End Sub
解説:
LCase 関数 は、アルファベットの大文字を、小文字に変換する文字列処理関数です。
引数 string には、任意の文字列式を指定します。この引数は必ず指定します。string に Null 値が含まれている場合、Null 値を返します。
大文字だけが小文字に変換されます。大文字のアルファベット以外の文字は影響を受けません。
UCase 関数 は、指定したアルファベットの小文字を、大文字に変換します。
小文字だけが大文字に変換されます。小文字のアルファベット以外の文字は影響を受けません。
Document.Frames プロパティ は、文書内のすべてのフレームを表す Frames コレクションを取得します。
構文
Visual Basic (宣言)
Public Overridable ReadOnly Property Frames As Frames
Visual Basic (使用法)
Dim instance As Document
Dim value As Frames
value = instance.Frames
次のコード例では、最初の段落にテキストを追加し、そのテキストにテキスト フレームを追加します。その後、テキスト フレームを wdLineStyleDouble に変更します。
Visual Basic コードのコピー
Private Sub DocumentFrames()
Dim textFrame As Word.Frame
Me.Paragraphs(1).Range.InsertParagraphAfter()
Me.Paragraphs(1).Range.Text = "Sample paragraph text."
textFrame = Me.Frames.Add(Me.Paragraphs(1).Range)
textFrame.Borders.OutsideLineStyle = Microsoft.Office.Interop. _
Word.WdLineStyle.wdLineStyleDouble
End Sub
VBA で FTP アップロード・ファイル一覧取得・ダウンロード
FTP には、通常は FTP クライアント・アプリを使います。しかし、毎月、定型的な処理として FTP を使うため、自動化する雛形として Excel マクロにしました。
必要なコードは、ネット検索して、すぐに見つかりました。
Tatsuya's Home Page の VB FTP操作
http://www.red.oit-net.jp/tatsuya/vb/WinInet.htm
VB のコードがそのまま VBA でも使えるのですね!
と、
Happy! Happy! Island の、番外編1.HTTPやFTPを使うには
http://www.happy2-island.com/access/gogo03/capter90100.shtml
です。
以下は、メインの手続き部分のコードです。
1.ファイルを開くダイアログで複数ファイルをFTPアップロード
2.FTPで指定ディレクトリのファイル一覧を取得する
3.FTPで指定ファイルをダウンロード
Sub ファイルを開くダイアログで複数ファイルをFTPアップロード ()
'IME を off (半角英数) にする
'http://www.isa-school.net/map/funabashi/2009/06/14/inputbox%E3%81%A7ime%E5%88%B6%E5%BE%A1%E3%80%90vba%E3%80%91/
If IMEStatus <> vbIMEModeOff Then
SendKeys "{kanji}"
End If
パスワード = InputBox("パスワードを入力して下さい", "パスワード設定")
If パスワード = "" Then Exit Sub 'パスワード未入力で、終了
ホスト名 = ThisWorkbook.Worksheets("Sheet1").Range("A14").Value
ユーザ名 = ThisWorkbook.Worksheets("Sheet1").Range("D14").Value
サーバパス = ThisWorkbook.Worksheets("Sheet1").Range("A16").Value
対象拡張子 = ThisWorkbook.Worksheets("Sheet1").Range("A18").Value
転送方法指定 = ThisWorkbook.Worksheets("Sheet1").Range("B18").Value
If InStr(転送方法指定, "B") > 0 Then
転送方法 = &H2 'FTP_TRANSFER_TYPE_BINARY
Else
転送方法 = &H1 'FTP_TRANSFER_TYPE_ASCII
End If
'このマクロのExcelのフォルダをデフォルトとする
ChDrive ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
'アップロード対象のファイル名とパス取得
対象ファイル群 = Application.GetOpenFilename _
(FileFilter:="指定拡張子,*." & 対象拡張子, Title:="アップロードするファイル(複数可)を指定して下さい", MultiSelect:=True)
'キャンセルが押された時の処理
'http://tarohome.web.fc2.com/CCP035.html
'http://okwave.jp/qa/q291242.html
If IsArray(対象ファイル群) = False Then
MsgBox "ファイルが指定されていません!"
Stop
Exit Sub
End If
開始時刻 = Now()
'http://www.happy2-island.com/access/gogo03/capter90302.shtml
Dim lngRC As Long
'インターネットサービスをオープンします
lngRC = fcInternetOpen
'オープンに成功したらFTPサーバとの接続と切断を行います
If lngRC = 0 Then
'FTPサーバへ接続します
lngRC = fcFTPConnect(ホスト名, ユーザ名, パスワード)
'接続に成功したら、FTPサーバへファイルをアップロードします
If lngRC = 0 Then
For 処理カウンタ = 1 To UBound(対象ファイル群)
ファイルフルパス = 対象ファイル群(処理カウンタ)
ファイル名 = Dir(ファイルフルパス)
Call fcFTPPutFile(ファイルフルパス _
, サーバパス & ファイル名 _
, 転送方法)
Application.StatusBar = 処理カウンタ & ファイル名 & " をアップロードしました。"
Next 処理カウンタ
Else
MsgBox "FTPサーバに接続できませんでした!"
Stop
End If
Else
MsgBox "インターネットサービスをオープンできませんでした!"
Stop
End If
'FTPをクローズします
Call fcFTPDisConnect
'インターネットサービスをクローズします
Call fcInternetClose
終了時刻 = Now()
MsgBox "処理が終了しました。" & Chr(13) & _
"処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
End Sub
'===============================================
' FTPで指定ディレクトリのファイル一覧を取得する
'===============================================
'http://www.red.oit-net.jp/tatsuya/vb/WinInet.htm
' VB のコードがそのまま VBA でも使えるのですね!
Sub ファイル一覧取得()
Dim hOpen As Long 'インターネットサービスのハンドル
Dim hConnection As Long 'インターネットセッションのハンドル
Dim result As Long
hOpen = 0
hConnection = 0
Dim hFind As Long
Dim w32FindData As WIN32_FIND_DATA
Dim strFile As String
Dim FileList() As String 'ファイル名一覧
Dim cnt As Long
Dim サーバ名 As String
Dim ユーザ名 As String
Dim パスワード As String
Dim ディレクトリ As String
Dim 処理行 As Integer
Dim 対象ファイル数 As Integer
Dim 対象拡張子 As String
Dim エラー配列() As Variant
Dim エラー数 As Integer
Dim エラー配列索引 As Object 'Scripting.Dictionary オブジェクト
Dim エラー配列添え字 As Integer 'Scripting.Dictionary オブジェクトのデータ
Dim エラーコード As String
Dim エラーメッセージ As String
'IME を off (半角英数) にする
'http://www.isa-school.net/map/funabashi/2009/06/14/inputbox%E3%81%A7ime%E5%88%B6%E5%BE%A1%E3%80%90vba%E3%80%91/
If IMEStatus <> vbIMEModeOff Then
SendKeys "{kanji}"
End If
パスワード = InputBox("パスワードを入力して下さい", "パスワード設定")
If パスワード = "" Then Exit Sub
'エラー・メッセージの辞書を作成する
ThisWorkbook.Worksheets("エラー・コード").Activate
エラー数 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
エラー配列 = Range("A1").Resize(エラー数, 2)
'★エラー配列の索引を作成★
Set エラー配列索引 = CreateObject("Scripting.Dictionary") '★連想配列の定義
For 処理行 = 1 To エラー数
エラーコード = エラー配列(処理行, 1)
エラー配列索引(エラーコード) = 処理行
Next 処理行
'FTPのパラメータを取得する
ThisWorkbook.Worksheets("Sheet1").Activate
サーバ名 = ThisWorkbook.Worksheets("Sheet1").Range("A14").Value
ユーザ名 = ThisWorkbook.Worksheets("Sheet1").Range("D14").Value
ディレクトリ = ThisWorkbook.Worksheets("Sheet1").Range("A16").Value
対象拡張子 = ThisWorkbook.Worksheets("Sheet1").Range("A18").Value
cnt = 0
'インターネットサービスのハンドル取得 - hOpen
hOpen = InternetOpen("FTPSample", INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
If (hOpen <> 0) Then 'ハンドル取得成功
'インターネットセッションのハンドル取得(FTPサーバへ接続) - hConnection
hConnection = InternetConnect(hOpen, サーバ名, INTERNET_INVALID_PORT_NUMBER, _
ユーザ名, パスワード, INTERNET_SERVICE_FTP, 0, 0)
If (hConnection <> 0) Then '接続成功
'FTPサーバのカレントディレクトリを変更
result = FtpSetCurrentDirectory(hConnection, ディレクトリ)
If (result <> 0) Then 'ディレクトリ変更成功
'ファイルリストを取得
hFind = FtpFindFirstFile(hConnection, "*.*", w32FindData, INTERNET_FLAG_RELOAD, 0)
If (hFind = 0) Then
If エラー配列索引.Exists (Trim(Err.LastDllError)) = True Then
'★エラー配列に存在した場合
エラー配列添え字 = エラー配列索引(Trim(Err.LastDllError))
エラーメッセージ = エラー配列(エラー配列添え字, 2)
Else
エラーメッセージ = Err.LastDllError
End If
MsgBox "ファイル名を取得できませんでした。" & vbNewLine _
& エラーメッセージ
Else
Do
strFile = Left(w32FindData.cFileName, InStr(w32FindData.cFileName, vbNullChar) - 1)
strFile = Mid(strFile, InStrRev(strFile, " ") + 1) 'ファイル名にゴミが付く場合は、排除。
If ((w32FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = &H10) Then
strFile = strFile & "/" 'ディレクトリなら "/" を付ける
End If
cnt = cnt + 1
ReDim Preserve FileList(cnt)
FileList(cnt) = strFile 'ファイル名(ディレクトリ名)をファイル名リストに追加
Loop Until InternetFindNextFile(hFind, w32FindData) = 0 '次のファイル名を取得
End If
Else
If エラー配列索引.Exists (Trim(Err.LastDllError)) = True Then
'★エラー配列に存在した場合
エラー配列添え字 = エラー配列索引(Trim(Err.LastDllError))
エラーメッセージ = エラー配列(エラー配列添え字, 2)
Else
エラーメッセージ = Err.LastDllError
End If
MsgBox "ディレクトリの移動に失敗しました。" & vbNewLine _
& エラーメッセージ
End If
Else
If エラー配列索引.Exists (Trim(Err.LastDllError)) = True Then
'★エラー配列に存在した場合
エラー配列添え字 = エラー配列索引(Trim(Err.LastDllError))
エラーメッセージ = エラー配列(エラー配列添え字, 2)
Else
エラーメッセージ = Err.LastDllError
End If
MsgBox "FTPサーバへ接続できませんでした。" & vbNewLine _
& エラーメッセージ
End If
Else
If エラー配列索引.Exists (Trim(Err.LastDllError)) = True Then
'★エラー配列に存在した場合
エラー配列添え字 = エラー配列索引(Trim(Err.LastDllError))
エラーメッセージ = エラー配列(エラー配列添え字, 2)
Else
エラーメッセージ = Err.LastDllError
End If
MsgBox "FTPサーバへ接続できませんでした。" & vbNewLine _
& エラーメッセージ
End If
Set エラー配列索引 = Nothing '★連想配列 を削除
'インターネットセッションを閉じる
If (hConnection <> 0) Then InternetCloseHandle hConnection
'インターネットサービスを閉じる
If (hOpen <> 0) Then InternetCloseHandle hOpen
'シートへの出力
For 処理行 = 1 To cnt
If Right(FileList(処理行), Len(FileList(処理行)) - InStrRev(FileList(処理行), ".")) = 対象拡張子 Then
対象ファイル数 = 対象ファイル数 + 1
ThisWorkbook.Worksheets("Sheet1").Range("A21").Cells(対象ファイル数, 1).Value = FileList(処理行)
End If
Next 処理行
End Sub
Sub FTPで指定ファイルをダウンロード ()
'http://officetanaka.net/other/extra/tips07.htm
Dim ロング As Long
'IME を off (半角英数) にする
'http://www.isa-school.net/map/funabashi/2009/06/14/inputbox%E3%81%A7ime%E5%88%B6%E5%BE%A1%E3%80%90vba%E3%80%91/
If IMEStatus <> vbIMEModeOff Then
SendKeys "{kanji}"
End If
パスワード = InputBox("パスワードを入力して下さい", "パスワード設定")
If パスワード = "" Then Exit Sub
開始時刻 = Now()
ホスト名 = ThisWorkbook.Worksheets("Sheet1").Range("A14").Value
ユーザ名 = ThisWorkbook.Worksheets("Sheet1").Range("D14").Value
サーバパス = ThisWorkbook.Worksheets("Sheet1").Range("A16").Value
転送方法指定 = ThisWorkbook.Worksheets("Sheet1").Range("B18").Value
If InStr(転送方法指定, "B") > 0 Then
転送方法 = &H2 'FTP_TRANSFER_TYPE_BINARY
Else
転送方法 = &H1 'FTP_TRANSFER_TYPE_ASCII
End If
'http://officetanaka.net/other/extra/tips07.htm
ローカルパス = ThisWorkbook.Path & "\ダウンロード\"
ロング = SHCreateDirectoryEx(0&, ローカルパス, 0&)
'http://www.happy2-island.com/access/gogo03/capter90301.shtml
Dim lngRC As Long
'インターネットサービスをオープンします
lngRC = fcInternetOpen
'オープンに成功したらFTPサーバとの接続と切断を行います
If lngRC = 0 Then
'FTPサーバへ接続します
lngRC = fcFTPConnect(ホスト名, ユーザ名, パスワード)
'接続に成功したら、FTPサーバからファイルをダウンロードします
If lngRC = 0 Then
For 処理行 = 21 To Cells(ThisWorkbook.Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row
ファイル名 = ThisWorkbook.Worksheets("Sheet1").Range("A1").Cells(処理行, 1).Value
Call fcFTPGetFile(サーバパス & ファイル名 _
, ローカルパス & ファイル名 _
, 転送方法)
Application.StatusBar = 処理カウンタ & ファイル名 & " をダウンロードしました。"
Next 処理行
Else
MsgBox "FTPサーバに接続できませんでした!"
Stop
End If
Else
MsgBox "インターネットサービスをオープンできませんでした!"
Stop
End If
'FTPをクローズします
Call fcFTPDisConnect
'インターネットサービスをクローズします
Call fcInternetClose
終了時刻 = Now()
MsgBox "処理が終了しました。" & Chr(13) & _
"処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。", vbOKOnly
End Sub
Google と DeepL で翻訳比較
AI を使った 2 つの翻訳サービスで翻訳表示します。興味深い結果を比較できます。
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If
Dim 文字列 As String
Dim URL As String
Dim セル名 As String
Sub 翻訳()
セル名 = "C7"
Call DeepL
Call Google
セル名 = "C9"
Call DeepL
Call Google
End Sub
'*************************************************
'参考にさせていただいたサイト
'https://www.vba-ie.net/form/text.php
'VBAでIEのテキストボックスに値入力
'*************************************************
'「参照設定」で、下の2つの、IEを制御するために必要なライブラリ追加します
'Microsoft HTML Object Library
'Microsoft Internet Controls
Sub DeepL ()
Dim objIE As InternetExplorer
Dim objInpTxt As HTMLDivElement
文字列 = ThisWorkbook.Worksheets("Sheet1").Range(セル名).Value
If IsJapan (文字列) = True Then '日本語
URL = ThisWorkbook.Worksheets("Sheet1").Range("C2").Value
Else '英語
URL = ThisWorkbook.Worksheets("Sheet1").Range("C3").Value
End If
'InternetExplorer でホームページを起動
Call ieView (objIE, URL)
' 参考にさせていだいたサイト
' https://developer.mozilla.org/ja/docs/Web/API/Document/getElementsByClassName
' https://developer.mozilla.org/ja/docs/Web/API/Element/getElementsByClassName
' https://www.sejuku.net/blog/68588
Set objInpTxt = objIE.document.getElementsByClassName _
("lmt__textarea lmt__source_textarea lmt__textarea_base_style")(0)
'テキストボックスに値を入力
objInpTxt.Value = 文字列
SendKeys "{ENTER}"
End Sub
Sub Google ()
Dim objIE As InternetExplorer
Dim objInpTxt As HTMLDivElement
文字列 = ThisWorkbook.Worksheets("Sheet1").Range(セル名).Value
If IsJapan (文字列) = True Then '日本語
URL = ThisWorkbook.Worksheets("Sheet1").Range("C4").Value
Else '英語
URL = ThisWorkbook.Worksheets("Sheet1").Range("C5").Value
End If
'InternetExplorer でホームページを起動
Call ieView (objIE, URL)
' 参考にさせていだいたサイト
' https://developer.mozilla.org/ja/docs/Web/API/Document/getElementsByClassName
' https://developer.mozilla.org/ja/docs/Web/API/Element/getElementsByClassName
' https://www.sejuku.net/blog/68588
Set objInpTxt = objIE.document.getElementsByClassName _
("orig tlid-source-text-input goog-textarea")(0)
'テキストボックスに値を入力
objInpTxt.Value = 文字列
End Sub
Function IsJapan (Arg As String) As Boolean
' https://oshiete.goo.ne.jp/qa/1940242.html
' By hanka2 2006/02/03 19:24
' 引数の中身が日本語ならTrueをそれ以外ならFalseを返します。
IsJapan = Not (LenB(StrConv(StrConv(StrConv(StrConv(Arg, vbWide), vbHiragana), vbNarrow), vbFromUnicode)) = Len(Arg))
End Function