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
' ボタン（cmdOpenLink）がクリックされたときに実行されるイベントハンドラ'
Private Sub cmdOpenLink_Click()
' ファイルダイアログを表示して、ユーザーが選択したExcelファイルのパスを FileName 変数に格納'
Dim FileName As Variant
FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
' ファイルが選択されなかった場合、プログラムを終了'
If FileName = False Then
Exit Sub
End If
' 選択されたExcelファイルを開く'
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(FileName)
' アクティブなワークブックの"生技_作業手順"シートのA2セルを基準に、A列をフィルタリングし、値が "〇" である行のみを表示'
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("生技_作業手順")
' 保存先のフォルダを設定（日付と選択したExcelのファイル名を結合してフォルダ名を作成）'
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
' 生技_作業手順シートのA列（1列目）の12行目から、データが入力されている最後の行までを走査'
For i = 12 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' i行目のA列の値が "〇" であるかどうかをチェックして、条件に合致する場合、ファイルをダウンロード'
If ws.Cells(i, 1).Value Like "〇*" Then
' ファイルパスを構成し、ダウンロードするファイルのURLと保存先を指定'
strPath = strFolder & ws.Cells(i, 4) & ".pdf"
strURL = ws.Cells(i, 5).Value
' URLDownloadToFile関数を使用してファイルをダウンロード'
lngRes = URLDownloadToFile(0, strURL, strPath, 0, 0)
' ダウンロードに失敗した場合、エラーメッセージを表示'
If lngRes <> 0 Then
MsgBox i & "行目のファイルをダウンロードできませんでした", vbCritical
Else
' ダウンロードが成功したら、そのPDFのパスをCollectionに追加'
pdfPaths.Add strPath
End If
End If
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
