Option Explicit

' 全局基础域名，用于补全相对链接

Const BASE_DOMAIN As String = "https://www.nhsa.gov.cn"

Sub BatchExtractDrugLinksCompatibleNoCode()

Dim targetUrl As String

Dim http As Object, dom As Object, allP As Object, pTag As Object

Dim logRow As Long

Dim aTags As Object, aItem As Object

Dim fileName As String, fileFullUrl As String

Dim medCode As String, medName As String

Dim pdfName As String, pdfUrl As String

Dim pptName As String, pptUrl As String

'==================== 1. 运行时手动输入网页地址 ====================

targetUrl = InputBox( _

prompt:="请输入目标网页的完整URL地址：", _

Title:="批量提取药品文件链接（兼容无编码行）", _

Default:="https://www.nhsa.gov.cn/art/2022/9/6/art_152_8853.html" _

)

' 校验用户输入

If Trim(targetUrl) = "" Then

MsgBox "未输入网页地址，程序终止", vbCritical

Exit Sub

End If

If Left(LCase(Trim(targetUrl)), 4) <> "http" Then

MsgBox "请输入以http/https开头的完整URL地址", vbCritical

Exit Sub

End If

'==================== 2. 初始化Excel表格 ====================

logRow = 2

' 固定表头（完全按你的要求）

Sheet1.Range("A1:F1").Value = Array( _

"药品编码", _

"药品名称", _

"药品信息.pdf", _

"药品信息.pdf文件网址", _

"信息摘要.ppt", _

"信息摘要.ppt文件网址" _

)

' 清空原有数据

Sheet1.Rows(2 & ":" & Sheet1.Rows.Count).ClearContents

' 自动调整列宽

Sheet1.UsedRange.EntireColumn.AutoFit

'==================== 3. 读取网页源码 ====================

Set http = CreateObject("MSXML2.XMLHTTP")

Set dom = CreateObject("htmlfile")

With http

.Open "GET", targetUrl, False

.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) Excel VBA"

.send

' 校验网页访问是否成功

If .Status <> 200 Then

MsgBox "网页访问失败，状态码：" & .Status & vbCrLf & "请检查URL是否正确、网络是否正常", vbCritical

Exit Sub

End If

dom.body.innerHTML = .responseText

End With

'==================== 4. 按网页顺序逐行解析，兼容有/无编码行 ====================

' 获取网页中所有段落标签（按网页从上到下的顺序）

Set allP = dom.getElementsByTagName("p")

' 遍历每一个段落（每一行药品），完全按网页顺序处理

For Each pTag In allP

' 重置当前行的所有信息

medCode = ""

medName = ""

pdfName = ""

pdfUrl = ""

pptName = ""

pptUrl = ""

' 提取当前行的药品编码+药品名称（兼容有/无编码两种格式）

On Error Resume Next

Call GetCodeAndDrugNameCompatible(CStr(pTag.innerText), medCode, medName)

On Error GoTo 0

' 跳过无有效药品名称的行（无编码但有药品名的行正常处理）

If Trim(medName) = "" Then GoTo NextParagraph

' 遍历当前行内所有文件超链接，区分PDF和PPT

Set aTags = pTag.getElementsByTagName("a")

For Each aItem In aTags

fileName = Trim(CStr(aItem.innerText))

fileFullUrl = GetAbsoluteUrl(Trim(CStr(aItem.href)))

If Trim(fileFullUrl) = "" Then GoTo NextLink

' 区分PDF和PPT，分别存储

If LCase(Right(fileName, 4)) = ".pdf" Then

pdfName = fileName

pdfUrl = fileFullUrl

ElseIf LCase(Right(fileName, 4)) = ".ppt" Then

pptName = fileName

pptUrl = fileFullUrl

End If

NextLink:

Next aItem

' 直接写入Excel当前行，完全按网页顺序，重复药品也单独成行

Sheet1.Cells(logRow, 1) = medCode

Sheet1.Cells(logRow, 2) = medName

Sheet1.Cells(logRow, 3) = pdfName

Sheet1.Cells(logRow, 4) = pdfUrl

Sheet1.Cells(logRow, 5) = pptName

Sheet1.Cells(logRow, 6) = pptUrl

' 行号递增，下一行药品对应Excel下一行

logRow = logRow + 1

NextParagraph:

Next pTag

'==================== 5. 完成提示 ====================

If logRow = 2 Then

MsgBox "未在网页中提取到有效药品文件链接，请检查网页结构是否匹配", vbExclamation

Else

MsgBox "提取完成！共提取到 " & logRow - 2 & " 条药品数据" & vbCrLf & "已兼容无编码行，数据完全按网页原顺序存入Sheet1", vbInformation

End If

' 释放对象

Set http = Nothing

Set dom = Nothing

Set allP = Nothing

Set aTags = Nothing

End Sub

' 辅助函数1：兼容有/无编码行，提取药品编码+药品名称

' 适配格式1：YPSW202200123-环孢素滴眼液(Ⅲ)：xxx.pdf xxx.ppt → 有编码

' 适配格式2：环孢素滴眼液(Ⅲ)：xxx.pdf xxx.ppt → 无编码，编码列留空

Sub GetCodeAndDrugNameCompatible(ByVal txt As String, ByRef outCode As String, ByRef outName As String)

Dim arrSplit1, arrSplit2

txt = Trim(txt)

outCode = ""

outName = ""

' 核心校验：必须包含中文冒号"："，否则不是有效药品行

If InStr(txt, "：") = 0 Then Exit Sub

' 情况1：包含横杠"-"，按有编码格式拆分

If InStr(txt, "-") > 0 Then

arrSplit1 = Split(txt, "-")

If UBound(arrSplit1) < 1 Then Exit Sub

' 横杠前面是编码

outCode = Trim(arrSplit1(0))

' 横杠后面到冒号前面是药品名

arrSplit2 = Split(arrSplit1(1), "：")

If UBound(arrSplit2) < 0 Then Exit Sub

outName = Trim(arrSplit2(0))

Else

' 情况2：不包含横杠"-"，按无编码格式拆分

arrSplit2 = Split(txt, "：")

If UBound(arrSplit2) < 0 Then Exit Sub

' 冒号前面是药品名，编码留空

outName = Trim(arrSplit2(0))

outCode = ""

End If

End Sub

' 辅助函数2：相对路径转为完整绝对网址

Function GetAbsoluteUrl(ByVal relUrl As String) As String

relUrl = Trim(relUrl)

GetAbsoluteUrl = ""

If relUrl = "" Then Exit Function

' 本身是完整http链接直接返回

If Left(LCase(relUrl), 4) = "http" Then

GetAbsoluteUrl = relUrl

Exit Function

End If

' 拼接基础域名

If Left(relUrl, 1) = "/" Then

GetAbsoluteUrl = BASE_DOMAIN & relUrl

Else

GetAbsoluteUrl = BASE_DOMAIN & "/" & relUrl

End If

End Function

Option Explicit

#If VBA7 Then

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _

ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _

ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long

#Else

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

#End If

' 可自行修改的配置项

Const ROOT_SAVE_PATH As String = "D:\医保药品批量下载\" ' 文件总保存根目录

Const BASE_DOMAIN As String = "https://www.nhsa.gov.cn" ' 网址基础域名，用于补全相对链接

Const TARGET_WORKSHEET_NAME As String = "2020年" ' 目标工作表名称

Sub BatchDownloadWithSerialFolder()

Dim fso As Object

Dim nameCountDict As Object

Dim ws As Worksheet

Dim lastRow As Long

Dim i As Long

Dim medCode As String, medName As String

Dim f1Name As String, f1Url As String

Dim f2Name As String, f2Url As String

Dim baseFolderName As String, serialFolderName As String

Dim fullFolderPath As String

Dim ret As Long

Dim statusTxt As String

Dim nameCount As Long ' 新增：记录当前名称出现的次数

' 安全获取工作表，增加存在性校验

On Error Resume Next

Set ws = ThisWorkbook.Worksheets(TARGET_WORKSHEET_NAME)

On Error GoTo 0

' 若工作表不存在，弹出明确提示，直接退出

If ws Is Nothing Then

MsgBox "错误：未找到名称为【" & TARGET_WORKSHEET_NAME & "】的工作表！" & vbCrLf & _

"请检查：1. 工作表名称是否正确；2. 工作表是否已被删除", vbCritical

Exit Sub

End If

' 初始化其他对象

Set fso = CreateObject("Scripting.FileSystemObject")

Set nameCountDict = CreateObject("Scripting.Dictionary")

' 创建总保存根目录

If Not fso.FolderExists(ROOT_SAVE_PATH) Then

fso.CreateFolder ROOT_SAVE_PATH

End If

' 获取工作表中的最大数据行

lastRow = ws.UsedRange.Rows.Count

If lastRow < 2 Then

MsgBox "工作表【" & TARGET_WORKSHEET_NAME & "】中无有效数据行，请检查后重试", vbCritical

Exit Sub

End If

' 初始化表头：G列添加下载状态

ws.Range("G1").Value = "下载状态说明"

ws.Range("G2:G" & lastRow).ClearContents

ws.UsedRange.EntireColumn.AutoFit

' 逐行处理数据

For i = 2 To lastRow

' 读取当前行数据

medCode = Trim(ws.Cells(i, 1).Value)

medName = Trim(ws.Cells(i, 2).Value)

f1Name = Trim(ws.Cells(i, 3).Value)

f1Url = GetAbsoluteUrl(Trim(ws.Cells(i, 4).Value))

f2Name = Trim(ws.Cells(i, 5).Value)

f2Url = GetAbsoluteUrl(Trim(ws.Cells(i, 6).Value))

' 无药品名称直接跳过本行

If medName = "" Then

ws.Cells(i, 7).Value = "跳过：无药品名称"

GoTo NextRow

End If

' 生成基础文件夹名

If medCode <> "" Then

baseFolderName = medCode & "-" & medName

Else

baseFolderName = medName

End If

baseFolderName = ReplaceIllegalChar(baseFolderName)

' ========== 核心修改：序号规则适配 ==========

' 统计当前名称出现的次数

If nameCountDict.Exists(baseFolderName) Then

nameCount = nameCountDict(baseFolderName) + 1

Else

nameCount = 1

End If

' 更新字典中的计数

nameCountDict(baseFolderName) = nameCount

' 生成最终文件夹名：第一次无后缀，第二次及以后加对应序号

If nameCount = 1 Then

serialFolderName = baseFolderName

Else

serialFolderName = baseFolderName & CStr(nameCount)

End If

' ==============================================

fullFolderPath = ROOT_SAVE_PATH & serialFolderName & "\"

' 创建当前行专属文件夹

If Not fso.FolderExists(fullFolderPath) Then

fso.CreateFolder fullFolderPath

End If

' 批量下载文件

statusTxt = "文件夹：" & serialFolderName & "；"

' 下载第一个文件（C/D列）

If f1Name <> "" And f1Url <> "" Then

ret = URLDownloadToFile(0, f1Url, fullFolderPath & f1Name, 0, 0)

Application.Wait DateAdd("s", 0.8, Now)

If ret = 0 Then

statusTxt = statusTxt & "文件1下载成功；"

Else

statusTxt = statusTxt & "文件1下载失败(预览中转页)；"

End If

Else

statusTxt = statusTxt & "无文件1；"

End If

' 下载第二个文件（E/F列）

If f2Name <> "" And f2Url <> "" Then

ret = URLDownloadToFile(0, f2Url, fullFolderPath & f2Name, 0, 0)

Application.Wait DateAdd("s", 0.8, Now)

If ret = 0 Then

statusTxt = statusTxt & "文件2下载成功"

Else

statusTxt = statusTxt & "文件2下载失败(预览中转页)"

End If

Else

statusTxt = statusTxt & "无文件2"

End If

' 写入当前行下载状态

ws.Cells(i, 7).Value = statusTxt

NextRow:

Next i

' 处理完成提示

MsgBox "批量处理完成！" & vbCrLf & _

"共处理行数：" & lastRow - 1 & vbCrLf & _

"文件保存根目录：" & ROOT_SAVE_PATH & vbCrLf & _

"序号规则：第一个无后缀，第二个加2，第三个加3，以此类推" & vbCrLf & _

"注：医保PDF为预览中转页，自动下载会失败，可复制链接手动保存", vbInformation

' 释放对象

Set fso = Nothing

Set nameCountDict = Nothing

Set ws = Nothing

End Sub

' 辅助函数：删除文件名/文件夹非法字符

Function ReplaceIllegalChar(ByVal s As String) As String

Dim c As Variant

Dim arr As Variant

arr = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

For Each c In arr

s = Replace(s, c, "")

Next c

ReplaceIllegalChar = Trim(s)

End Function

' 辅助函数：相对路径补全完整网址

Function GetAbsoluteUrl(ByVal relUrl As String) As String

relUrl = Trim(relUrl)

GetAbsoluteUrl = ""

If relUrl = "" Then Exit Function

If Left(LCase(relUrl), 4) = "http" Then

GetAbsoluteUrl = relUrl

Exit Function

End If

If Left(relUrl, 1) = "/" Then

GetAbsoluteUrl = BASE_DOMAIN & relUrl

Else

GetAbsoluteUrl = BASE_DOMAIN & "/" & relUrl

End If

End Function