インターネットを操る

Excel VBA のトップに戻る

Excel VBA 目次

Internet Explorerオブジェクト
インターネット・エクスプローラ IE のバージョンを調べる
MSXML2.XMLHTTP を使って、HTMLソースを取得
ファイルをダウンロード
ファイルをアップロード
テキスト・データを取得
VBA で FTP アップロード・ファイル一覧取得・ダウンロード

株取引に VBA を使う

IE 画面を、スクリプトで操作する(項目別のテクニック)

索引

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プロパティの値
http://www.ajaxtower.jp/ini/http/index2.html

 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 を取得する方法もあります。


 ここで紹介するマクロは、インターネットの「青空文庫」で公開されている文書ファイルを、一括ダウンロードするために書いたものです。
 このマクロは、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 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の画面を前面表示させて、キー入力でファイルパス名をセットしています。

このマクロをダウンロードできます。→file_uploadVBA02.xls

 注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シートに取り込みます。
 使い方は、色々考えられます。例えば・・・・
 フレームで構成されたページについても、それなりに出力します。

このマクロをダウンロードできます。→IE_text.xls


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で指定ファイルをダウンロード

このExcelをダウンロードできます→FtpPutGetVBA01.xls


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

この種類の目次に戻る↑ 索引へ↓ トップページに戻る


ホームページのトップに戻る