「ExcelVBA」カテゴリーアーカイブ

getElementByID(“id”)

getElementByID(“id”)・・・要素のIDを指定して単一の要素を取得
getElementsByName(“name”)・・・要素のNameを指定して単一の要素を取得
getElementsByTagName(“タグ名”)・・・要素のタグ名を指定して複数要素を取得
getElementsByTagName(“タグ名”)(n)・・・要素のタグ名を指定して複数要素の中からn番目の要素を取得
getElementsByClassName(“クラス名”)・・・要素のクラス名を指定して複数要素を取得
getElementsByClassName(“クラス名”)(n)・・・要素のクラス名を指定して複数要素の中からn番目の要素を取得
querySelector(“CSSセレクタ”)・・・CSSセレクタで要素を指定して複数要素の中から1番目の要素を取得
querySelectorAll(“CSSセレクタ”)・・・CSSセレクタで要素を指定して複数要素を取得
    Dim search_result_list
    Set search_result_list = oIE.Document.querySelectorAll(“.srg .rc”)
Private Sub cmd調査_Click()

    Dim r As Long
    Dim lastRow As Long, lng検索No As Long, lngページ数 As Long
    Dim str検索キー As String

    With Worksheets(sheetName2)
        
        For r = 1 To 5
        
            If .Range("C" & r + 4).Value = "" Then
                Exit Sub
            End If
        
            lng検索No = r
            str検索キー = .Range("B" & r + 4).Value & " " & Replace(.Range("C" & r + 4).Value, "-", " ")
            lngページ数 = 2
    
            'Yahoo!ショッピング検索
            Call set_Yahoo(lng検索No, str検索キー, lngページ数)

            '安値順にソート
            Call sort_Yahoo(lng検索No)

            'Yahoo!ショッピング表示
            Call set_Yahoo結果2(lng検索No, lngページ数)

            '楽天検索
            Call set_Rakuten2(lng検索No, str検索キー, lngページ数)
            
            '安値順にソート
            Call sort_Rakuten(lng検索No)

            '楽天表示
            Call set_Rakuten結果2(lng検索No, lngページ数)
            
        Next
        
    End With
    
    MsgBox "完了"

End Sub

Private Sub CommandButton2_Click()

'    Worksheets(sheetName2).Range("B5:C100").ClearContents
    Worksheets(sheetName2).Range("E5:AN100").ClearContents


End Sub
Sub set_Yahoo(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'           Yahoo!ショッピング内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        Dim txtInput As HTMLInputTextElement
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_Y
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機
    
       '検索情報の自動入力
        '検索BOX
        Set txtInput = objIE.document.getElementById("ss_yschsp")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementById("ss_srch_btn")
        button.Click
    
        
        Call WaitFor2(2)
        
        '表示ボタンの切り替え(列表示)
'        Set button = objIE.document.querySelector(".Icon--list")
'        button.Click
    
        'サーチ結果のURL取得
        URL_search0 = objIE.document.url
        
        Application.ScreenUpdating = False

        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
        
            'URLの設定
            If k > 1 Then
                         
                URL_search = URL_search0 & "&b=" & 30 * k - 29
                
            Else
            
                URL_search = URL_search0

            End If
        
            objIE.Navigate URL_search
        
            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            
            Set search_result_list = objIE.document.querySelectorAll(".LoopList__item")
            
            'search_result の個数分繰り返し処理
            With Worksheets("Y" & lng検索No)
                
                If search_result_list.Length = 0 Then Exit For
            
                For i = 0 To search_result_list.Length - 1
                    If InStr(search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText, "中古") = 0 Then
    
                        .Cells(nn, 1).Value = k
                        .Cells(nn, 2).Value = i + 1
'                        .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".WeRPqEQO_DMj").innerText  'タイトル
                        .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                        .Cells(nn, 4).Value = search_result_list.Item(i).querySelector("._2RweXo29absZ").innerText  '店名
                        strV = search_result_list.Item(i).querySelector("._3Z3ly613XmPi").innerText   '価格
                        strP = search_result_list.Item(i).querySelector("._2UkNjGl36tm2").innerText   'ポイント
            
                        strV = Replace(strV, ",", "")
                        strV = Replace(strV, "円", "")
                        .Cells(nn, 5).Value = Val(strV)
                        .Cells(nn, 6).Value = Mid(strP, InStr(strP, "(") + 1, InStr(strP, "ポ") - InStr(strP, "(") - 1)

                        t = t + 1
                            
                    End If
            
                    nn = nn + 1
                     
                Next

                
            End With
            
            If t = 0 Then
                Worksheets(sheetName2).Range("E" & r).Value = "見つかりませんでした。"
            End If
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

End Sub

Sub sort_Yahoo(lng検索No As Long)

'######################################################################
'
'           Yahoo!ショッピング内検索結果を安値でソート
'
'######################################################################
    Dim lastRow As Long

    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
    
        Call .Range("A2:F" & lastRow).Sort( _
                    Key1:=.Range("E1"), _
                    Order1:=xlAscending)
    
    
    End With
    
End Sub

Sub set_Rakuten(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'                 楽天内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_R
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機

       '検索情報の自動入力
       '検索BOX
        Set txtInput = objIE.document.getElementById("sitem")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementById("searchBtn")
        button.Click
        
        Call WaitFor2(2)
    
        'サーチ結果のURL取得
        URL_search = objIE.document.url
        
        Application.ScreenUpdating = False
        
        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
            'URLの設定
            If k > 1 Then
                URL_search2 = URL_search & "?p=" & k
            Else
                URL_search2 = URL_search

            End If
            
            On Error Resume Next

            Set objIE = New InternetExplorer
            objIE.Visible = True
            
            objIE.Navigate URL_search2
            

            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
            
            'search_result の個数分繰り返し処理
            With Worksheets("R" & lng検索No)
            
                If search_result_list.Length = 0 Then Exit For
            
                    For i = 0 To search_result_list.Length - 1
                        If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
                            
                            .Cells(nn, 1).Value = k
                            .Cells(nn, 2).Value = i + 1
                            .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                            .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText  '店名
                            strV = search_result_list.Item(i).querySelector(".important").innerText  '価格
                            strP = search_result_list.Item(i).querySelector(".points").innerText  'ポイント
                            
                            strV = Replace(strV, ",", "")
                            strV = Replace(strV, "円", "")
                            .Cells(nn, 5).Value = Val(strV)
                            .Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
                            
                            t = t + 1
                            
                         End If
                         
                         nn = nn + 1
                    Next
                    
            End With
             
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

'MsgBox "完了"



End Sub

Sub set_Rakuten2(lng検索No As Long, str検索キー As String, lngページ数 As Long)

'######################################################################
'
'                 楽天内検索
'
'######################################################################

        Dim i As Integer, k As Integer, l As Integer, n As Integer, nn As Integer, t As Integer
        Dim URL_search As String, strP As String, strV As String
        Dim txtInput As HTMLInputTextElement
        Dim button As Object
    
        
        t = 0
        
        'ブラウザのオープン
        Dim objIE As InternetExplorer
        
        Set objIE = New InternetExplorer
        objIE.Visible = True
        
        'IEで開く
        objIE.Navigate searchURL_R
        Call IEWait2(objIE)                          '自作関数: IE待機用
        Call WaitFor2(2)                             '自作関数: WaitFor2(t):t秒待機

       '検索情報の自動入力
       '検索BOX
        Set txtInput = objIE.document.getElementById("common-header-search-input")
        txtInput.Value = str検索キー
        
        '送信ボタン押下
        Set button = objIE.document.getElementsByClassName("button--15weO button--uGWy7 undefined")(0)
        button.Click
        
        Call WaitFor2(2)
    
        'サーチ結果のURL取得
        URL_search = objIE.document.url
        
        Application.ScreenUpdating = False
        
        nn = 2 '各シートの2行目から書き出す
        
        For k = 1 To lngページ数     'lngページ数まで検索する
            'URLの設定
            If k > 1 Then
                URL_search2 = URL_search & "?p=" & k
            Else
                URL_search2 = URL_search

            End If
            
            On Error Resume Next

            Set objIE = New InternetExplorer
            objIE.Visible = True
            
            objIE.Navigate URL_search2
            

            Call IEWait2(objIE)
            Call WaitFor2(2)
            
            
            'search_result に検索結果部分をページごとにリストとして格納
            Dim search_result_list
            Set search_result_list = objIE.document.querySelectorAll(".searchresultitem")
            
            'search_result の個数分繰り返し処理
            With Worksheets("R" & lng検索No)
            
                If search_result_list.Length = 0 Then Exit For
            
                    For i = 0 To search_result_list.Length - 1
                        If InStr(search_result_list.Item(i).querySelector("h2").innerText, "中古") = 0 Then
                            
                            .Cells(nn, 1).Value = k
                            .Cells(nn, 2).Value = i + 1
                            .Cells(nn, 3).Value = search_result_list.Item(i).querySelector("a").href   'URL
                            .Cells(nn, 4).Value = search_result_list.Item(i).querySelector(".merchant").innerText  '店名
                            strV = search_result_list.Item(i).querySelector(".important").innerText  '価格
                            strP = search_result_list.Item(i).querySelector(".points").innerText  'ポイント
                            
                            strV = Replace(strV, ",", "")
                            strV = Replace(strV, "円", "")
                            .Cells(nn, 5).Value = Val(strV)
                            .Cells(nn, 6).Value = Left(strP, InStr(strP, "ポ") - 1)
                            
                            t = t + 1
                            
                         End If
                         
                         nn = nn + 1
                    Next
                    
            End With
             
        Next

            'IEクローズ
            objIE.Quit
            Set objIE = Nothing
        
        Application.ScreenUpdating = True

'MsgBox "完了"



End Sub

Sub sort_Rakuten(lng検索No As Long)

'######################################################################
'
'           Rakuten内検索結果を安値でソート
'
'######################################################################
    Dim lastRow As Long

    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
    
        Call .Range("A2:F" & lastRow).Sort( _
                    Key1:=.Range("E1"), _
                    Order1:=xlAscending)
    
    
    End With
    
End Sub

'IE待機用関数
Public Sub IEWait2(ByRef objIE As Object)
    Do While objIE.Busy Or objIE.readyState <> 4
        DoEvents
    Loop
End Sub

't[sec]待機させる関数
Public Sub WaitFor2(ByVal second As Integer)
    Dim futuretime As Date
    futuretime = DateAdd("s", second, Now)
    While Now < futuretime
        DoEvents
    Wend
End Sub


Sub set_Yahoo結果(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 1
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(M列)、価格(N列)、商品URL(O列)
            Worksheets(sheetName).Range("M" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName).Range("N" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName).Range("O" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName).Range("O" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 2 To 6
               'Q列(価格)、R列(店舗名)、S列(ポイント)
                Worksheets(sheetName).Range("Q" & lng行番号).Value = .Range("E" & i).Value
                Worksheets(sheetName).Range("R" & lng行番号).Value = .Range("D" & i).Value
                Worksheets(sheetName).Range("S" & lng行番号).Value = .Range("F" & i).Value
            
                lng行番号 = lng行番号 + 1
                
            Next i
            
         End If

    End With
    
    
End Sub

Sub set_Yahoo結果2(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String, rngA As Range
    
    '占有率表示
    With Worksheets("Y" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 4
        
        If lastRow > 1 Then
        
            On Error GoTo myError
            
            Set rngA = .Range("D2:D" & lastRow)
        
            rowNo = rngA.Find(str店名, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(M列)、価格(N列)、商品URL(O列)
            Worksheets(sheetName2).Range("W" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName2).Range("X" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName2).Range("Y" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName2).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName2).Range("Y" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 0 To 4
               'Q列(価格)、R列(店舗名)、S列(ポイント)
                Worksheets(sheetName2).Cells(lng行番号, 26 + i * 3).Value = .Range("E" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 27 + i * 3).Value = .Range("D" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 28 + i * 3).Value = .Range("F" & i + 2).Value
                
            Next i
            
         End If

    End With
    
    Exit Sub
    
myError:
    MsgBox "ヤフショの検索結果では、モダンブルーの商品は見つかりません。検索対象の品番を見直すか、検索ページ数を増やしてください。"       '表示されます
    
    
End Sub

Sub set_Rakuten結果(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No * 5 + 1
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(F列)、価格(G列)、商品URL(H列)
            Worksheets(sheetName).Range("F" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName).Range("G" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName).Range("H" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName).Range("H" & lng行番号), _
                                                           Address:=strURL)
        
            For i = 2 To 6
               'J列(価格)、K列(店舗名)、L列(ポイント)
                Worksheets(sheetName).Range("J" & lng行番号).Value = .Range("E" & i).Value
                Worksheets(sheetName).Range("K" & lng行番号).Value = .Range("D" & i).Value
                Worksheets(sheetName).Range("L" & lng行番号).Value = .Range("F" & i).Value
            
                lng行番号 = lng行番号 + 1
                
            Next i
            
         End If

    End With
    
End Sub


Sub set_Rakuten結果2(lng検索No As Long, lngページ数 As Long)

    Dim lng行番号 As Long, i As Long
    Dim lastRow As Long, rowNo As Long, strURL As String
    
    '占有率表示
    With Worksheets("R" & lng検索No)
    
        lastRow = .Cells(Rows.Count, 3).End(xlUp).Row
        
        lng行番号 = lng検索No + 4
        
        If lastRow > 1 Then
        
            rowNo = .Range("D2:D" & lastRow).Find(str店名2, LookAt:=xlWhole).Row
            
            'モダンブルーの表示順位(F列)、価格(G列)、商品URL(H列)
            Worksheets(sheetName2).Range("E" & lng行番号).Value = .Range("B" & rowNo).Value
            Worksheets(sheetName2).Range("F" & lng行番号).Value = .Range("E" & rowNo).Value
            strURL = .Range("C" & rowNo).Value
            Worksheets(sheetName2).Range("G" & lng行番号).Value = strURL
            
            'URLにハイパーリンクをつける
            Dim hyplink  As Hyperlink
            Set hyplink = Worksheets(sheetName).Hyperlinks.Add( _
                                                           Anchor:=Worksheets(sheetName2).Range("G" & lng行番号), _
                                                           Address:=strURL)
        

            
            For i = 0 To 4
               '(価格)、(店舗名)、(ポイント)
                Worksheets(sheetName2).Cells(lng行番号, 8 + i * 3).Value = .Range("E" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 9 + i * 3).Value = .Range("D" & i + 2).Value
                Worksheets(sheetName2).Cells(lng行番号, 10 + i * 3).Value = .Range("F" & i + 2).Value
                
            Next i
            
         End If

    End With
    
End Sub


Public Const searchURL_R = "https://www.rakuten.co.jp/"

Public Const searchURL_Y = "https://shopping.yahoo.co.jp/"

Public Const sheetName = "最安値調査"

Public Const sheetName2 = "改善案"

Public Const str店名 = "モダンブルーYahoo!店"

Public Const str店名2 = " モダンブルー楽天市場店"

重複配列の取得と、各配列ごとの平均値取得(動的配列、UBound、Dictionary 使用)

‘重複品番のうち、価格が同じはOKと判断する。
‘配列に重複品番を格納
Dim Dic As Object, buf As String
Dim Arr() As String: ReDim Arr(0) ‘Index 0で初期化
Dim sum下代 As Currency, ave下代 As Currency
Dim rowNo As Long, i As Long, k As Long, m As Long
Dim LastRow As Long

‘ s1 = “新規メニュー予定”
LastRow = Worksheets(s1).Cells(Rows.Count, 14).End(xlUp).Row ‘N列(モダンブルー品番)最終行番号取得

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets(s1)
    For i = 4 To LastRow

        If .Range("A" & i) = "重複" Then

            buf = .Range("N" & i).Value         ''セルの値を変数bufに格納する
            If Not Dic.Exists(buf) Then     ''まだ登録されていなかったら…

                Dic.Add buf, buf  ''セルの値を連想配列に登録する

                'Arrへの格納時に、添え字の数値指定ではなくUboundで最大要素に追加する。
                 Arr(UBound(Arr)) = .Range("N" & i).Value

                 '拡張
                 ReDim Preserve Arr(UBound(Arr) + 1)

            End If

        End If

    Next i

    '1つ余分に作ってしまうので削除
    ReDim Preserve Arr(UBound(Arr) - 1)

    MsgBox Dic.Count & "件の品番が重複しています。"

    '重複品番の各品番ごとに下代の平均値を算出し、それに下代の金額が合致していたら問題ないと判定し、「重複」⇒「OK」に変更する
    For i = 0 To Dic.Count - 1

        sum下代 = 0
        m = 0
        For k = 4 To LastRow
            '重複品番のある行数を取得
            If .Range("N" & k).Value = Arr(i) Then
                '下代(U列)の合計を算出
                sum下代 = sum下代 + .Range("U" & k).Value
                m = m + 1
            End If
        Next k

        ave下代 = sum下代 / m

        For k = 4 To LastRow
            '重複品番のある行数を取得
            If .Range("N" & k).Value = Arr(i) And .Range("U" & k).Value = ave下代 Then
                .Range("A" & k).Value = "OK"

                '背景色とフォントカラーを通常に戻す。
                .Range("A" & k).Interior.Color = RGB(255, 255, 255)
                .Range("A" & k).Font.Color = RGB(0, 0, 0)
                .Range("Q" & k).Interior.Color = RGB(255, 255, 255)
                .Range("R" & k).Interior.Color = RGB(255, 255, 255)
                .Range("U" & k).Interior.Color = RGB(255, 255, 255)


            End If
        Next k

    Next
    MsgBox "重複品番については、下代の金額が合致していた場合、" & vbCrLf & "問題ないと判定しますので、A列を「OK」に変更いたします。"

End With

'-----検証----

Debug.Print "----"

For i = 0 To UBound(Arr)
    Debug.Print Arr(i)
Next i
Debug.Print "----"

Set Dic = Nothing

参考文献
https://thom.hateblo.jp/entry/2015/03/19/213019
★動的配列:UBound
http://officetanaka.net/excel/vba/function/UBound.htm

エクセル「(自分)が使用中です」エラーの対処方法

サーバに保管しているエクセルファイルを閉じているにもかかわらず、「○○(自分)が使用中です」というメッセージがでるときがあります。

削除するファイルのあるパスをいつも忘れるので、備忘録として、記録します~

解決法

WIN+R でコマンドプロンプトを開いて「 %temp% 」と入力し、
テンポラリフォルダ(一時フォルダ)を開き、不要なファイルを削除する。
C:\Users\(ユーザ名)a\AppData\Local\Temp

*.tmp
MSForms.exd ファイルを削除

※注意点: tempフォルダの中のLowフォルダは削除しない!!

Excel VBAでWindows APIの 関数を使ってファイルをWEBからダウンロード(URLDownloadToFile関数)

参照 https://tonari-it.com/excel-vba-windowsapi-urldownloadtofile/

https://www.vba-ie.net/

https://www.vba-ie.net/element/subroutine-filedownload.html

マイクロソフト Windows API リストhttps://msdn.microsoft.com/ja-jp/windows/hh240557

https://plannauts.co.jp/vba-skillup-survice/

①まずは宣言セクションでURLDownloadToFileの宣言

Windows APIを使用するには、まずVBAコードの宣言セクションで、「このWindows APIを使います」という宣言が必要です。URLDownloadToFile関数はurlmonというDLLに含まれていますので、API名にはURLDownloadToFileを、DLL名にはurlmonを指定します。そしてこの関数はLong型の返り値を返してくれますので、Long型で宣言しておきましょう。

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

特に値を指定したりするのはszURLszFileNameの2つで、それぞれの役割と型がこちら。

  • szURL ダウンロードしたいファイルのURLを関数に渡すもの。String型。
  • szFileName  ダウンロードしたファイルを保存するパスをAPIに渡すもの。String型。

szURLとszFileName以外3つの変数は”0″を渡すだけなので、このままでも問題ありません。

そしてコード部分でURLDownloadToFile関数を呼び出す際の記述がこちら。

変数 = URLDownloadToFile(0, ファイルのURL, ファイルを保存するパス, 0, 0)

変数に返された値が0ならファイルダウンロード完了、それ以外ならダウンロードできていないということになります。

②このWindows APIでファイルをダウンロードしてみる

Option Explicit
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 Download_File()
Dim lngRes As Long
Dim strURL As String
Dim strPath As String
     
    strPath = “C:\Users\users\Desktop\File\画像.png”
    strURL = “https://www.google.co.jp/images/branding/googlelogo/1x/googlelogo_color_272x92dp.png”;
    
    lngRes = URLDownloadToFile(0, strURL, strPath, 0, 0)
    If lngRes = 0 Then
        MsgBox “ダウンロード完了!”
    Else
        MsgBox “ファイルをダウンロードできませんでした”
    End If
End Sub

このコードを実行してみると、引数の”strPath”に指定したパスに、strURLで指定したURLのファイルがダウンロードされます。

VBA>oleオートメーション>ブラウザのテキスト・HTMLを書き出す

「Document メソッドは失敗しました IWebBrowser2 オブジェクト」
⇒「Microsoft SkyDrive Pro Browser Helper」というIEのアドオンを無効にしているとこの症状が発生するようです。
【参照】http://d.hatena.ne.jp/Shinez/20150225/p1
【参照】https://community.office365.com/ja-jp/b/office_365_buzz/archive/2013/04/07/activex-addons-on-browsers-to-work-with-office-365
画面右上の歯車をクリックして[アドオンの管理]
└[表示]ドロップダウンを [現在読み込まれているアドオン]から [すべてのアドオン]に変更することで、現在読み込まれていないアドオンもあわせてすべてのもののリストを見ることができます。このダイアログボックスで各アドオンの有効化/無効化を行うことができます。
※acceleratorアクセラレータとは、コンピュータの処理能力を高めるために、追加して利用するハードウェアやソフトウェアの総称

★拡張保護モードとアドオン
拡張保護モードでは、マルウェアなどの攻撃から PC や個人データを保護できます。Internet Explorer 11 では既定で有効になっています。有効になっていると、ツール バー、拡張機能、ブラウザー ヘルパー オブジェクトなどのアドオンは、拡張保護モードと互換性がある場合にのみ実行できます。アドオンに互換性がない場合はユーザーに通知されます。互換性のないアドオンを実行する必要がある場合は、デスクトップ ブラウザーで拡張保護モードを無効に設定できます。⇒既に『拡張保護モード=”無効”』になっている。