' urlmonライブラリからファイルをダウンロードする関数を宣言
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
' shell32.dllからURLやファイルを開く関数を宣言
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
' ボタンクリック時の処理を記述
Private Sub cmdOpenLink_Click()
' ファイル選択ダイアログを表示してExcelファイルのパスを取得
Dim FileName As Variant
FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
' ファイルが選択されていなければ処理を終了
If FileName = False Then Exit Sub
' 選択したExcelファイルを開く
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(FileName)
' フィルタリング条件を設定してデータを絞り込む
targetWorkbook.Sheets("生技_作業手順").Range("A2").AutoFilter Field:=1, Criteria1:="=〇*", Operator:=xlAnd
Dim lngRes As LongPtr
Dim strURL As String, strPath As String, strFolder As String
Dim i As Long
Dim ws As Worksheet
Set ws = targetWorkbook.Sheets("生技_作業手順")
' ダウンロード先フォルダのパスを生成
strFolder = "C:\Users\takka\OneDrive\デスクトップ\ここに保存\" & Format(Date, "yyyymmdd") & "_" & _
Replace(Replace(Mid(FileName, InStrRev(FileName, "\") + 1), ".xlsx", ""), ".xls", "") & "\"
' ダウンロード先フォルダが存在しなければ作成
If Dir(strFolder, vbDirectory) = "" Then
MkDir strFolder
End If
' ダウンロードしたPDFのパスを格納するためのCollectionを初期化
Dim pdfPaths As New Collection
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' 生技_作業手順シートのデータを走査して条件に合致する行のファイルをダウンロード
For i = 12 To lastRow
If ws.Cells(i, 1).Value Like "〇*" Then
' 必要なセルの値が空か確認
If IsEmpty(ws.Cells(i, 4).Value) Or IsEmpty(ws.Cells(i, 5).Value) Then
MsgBox i & "行目に必要なデータが不足しています。", vbExclamation
GoTo NextIteration
End If
' ダウンロード先のファイルパスとURLを生成
strPath = strFolder & ws.Cells(i, 4).Value & ".pdf"
strURL = ws.Cells(i, 5).Value
' "extension://"のURLの場合、ShellExecuteで開く
If Left(strURL, 11) = "extension://" Then
ShellExecute 0, "open", strURL, vbNullString, vbNullString, 1
Else
' 通常のURLの場合、URLDownloadToFileでダウンロード
lngRes = URLDownloadToFile(0, strURL, strPath, 0, 0)
If lngRes <> 0 Then
MsgBox i & "行目のファイルをダウンロードできませんでした。不正なURLかもしれません: " & strURL, vbCritical
Else
' ダウンロード成功時、PDFのパスをCollectionに保存
pdfPaths.Add strPath
End If
End If
End If
NextIteration:
Next i
' 処理完了を通知
MsgBox "処理完了！", vbInformation
' ダウンロードしたPDFファイルを開く
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
Dim pdfPath As Variant
For Each pdfPath In pdfPaths
objShell.Open pdfPath
Next pdfPath
' デフォルトのシートをアクティブにする
targetWorkbook.Sheets("Sheet1").Activate
End Sub
