当前位置：首页>Excel>第7天实战:VBA与API交互,让Excel连接互联网世界

第7天实战:VBA与API交互,让Excel连接互联网世界

2026-11-02 03:08:07

小张完成了数据库系统的开发，看着自动运行的员工管理系统，又想到了一个新问题：“老王，我们的系统现在能管理本地数据了，但很多实时信息都在网上，比如天气、汇率、股票行情，Excel能获取这些信息吗？”

老王眼睛一亮：“问得好！这就是最后一天要学的终极技能——API调用。让Excel不仅能处理本地数据，还能连接整个互联网！”

小张兴奋地问：“我们真的能让Excel访问网站、获取实时数据吗？能自动发邮件、查天气吗？”

“不仅能，而且比你想象的更简单。”老王打开VBA编辑器，“今天，我教你让Excel变身‘互联网客户端’，获取全世界的实时信息。”

01 准备工作：添加API调用引用

第一步：添加必要的引用

在VBA编辑器中：

按 Alt + F11打开VBA编辑器

点击菜单栏：工具 → 引用

勾选"Microsoft XML, v6.0"

第二步：检查引用是否成功

Sub 检查API引用()OnErrorResumeNextDim 引用 AsObjectForEach 引用 In ThisWorkbook.VBProject.ReferencesIf 引用.Name = "MSXML2"ThenMsgBox "✅ XML引用已成功添加！", vbInformationExitSubEndIfNextMsgBox "请先添加引用：" & vbCrLf & _"1. 工具 → 引用" & vbCrLf & _"2. 勾选 Microsoft XML, v6.0", vbExclamationEndSub

02 基础概念：什么是API？

老王在白板上画图解释：

API（Application Programming Interface）就像：

餐厅的点菜单- 你告诉服务员要什么菜（发送请求），厨房做好后送过来（返回响应）

网站的"后门"- 不通过浏览器界面，直接获取数据

数据的"快递员"- 把网上的数据"快递"到你的Excel里

API调用的基本流程：

1. 创建请求 → 2. 设置参数 → 3. 发送请求 → 4. 接收响应 → 5. 解析数据

基础API调用模板

最简单的API调用示例

Sub 调用简单API()OnErrorGoTo 错误处理' 1. 创建XMLHTTP对象Dim 请求 AsObjectSet 请求 = CreateObject("MSXML2.XMLHTTP")' 2. API地址（这里用一个免费的测试API）Dim API地址 AsStringAPI地址 = "https://jsonplaceholder.typicode.com/posts/1"' 3. 发送GET请求With 请求.Open "GET", API地址, False' False表示同步请求.sendEndWith' 4. 检查响应状态If 请求.Status = 200Then' 成功获取数据Dim 响应文本 AsString响应文本 = 请求.responseText' 5. 显示结果MsgBox "✅ API调用成功！" & vbCrLf & _"返回数据：" & vbCrLf & 响应文本, vbInformationElseMsgBox "❌ 请求失败，状态码：" & 请求.Status, vbExclamationEndIfExitSub错误处理:MsgBox "API调用失败：" & Err.Description, vbCriticalEndSub

03 实战1：获取实时天气信息

使用免费的天气API

获取指定城市的天气信息

Sub 获取天气信息()    On Error GoTo 错误处理    ' 1. 获取城市名称    Dim 城市 As String    城市 = InputBox("请输入城市名称（如：北京）：", "查询天气")    If 城市 = "" Then Exit Sub    ' 2. 创建请求对象    Dim 请求 As Object    Set 请求 = CreateObject("MSXML2.XMLHTTP")    ' 3. 使用和风天气API（需要申请免费API密钥）    ' 注册地址：https://dev.qweather.com/    Dim API密钥 As String    API密钥 = "你的API密钥"  ' 替换为你的实际密钥    Dim API地址 As String    API地址 = "https://devapi.qweather.com/v7/weather/now?" & _              "key=" & API密钥 & "&location=" & 城市 & "&lang=zh"    ' 4. 发送请求    With 请求        .Open "GET", API地址, False        .send    End With    ' 5. 处理响应    If 请求.Status = 200 Then        Dim 响应文本 As String        响应文本 = 请求.responseText        ' 6. 解析JSON数据        Call 解析天气数据(响应文本, 城市)    Else        MsgBox "获取天气失败，状态码：" & 请求.Status, vbExclamation    End If    Exit Sub错误处理:    MsgBox "获取天气失败：" & Err.Description, vbCriticalEnd Sub' 解析天气JSON数据Private Sub 解析天气数据(JSON文本 As String, 城市 As String)    ' 简单解析JSON（实际项目中建议使用JSON解析器）    Dim 温度 As String, 天气 As String, 湿度 As String, 风向 As String    ' 查找温度字段    Dim 位置 As Long    位置 = InStr(1, JSON文本, "temp"":""")    If 位置 > 0 Then        温度 = Mid(JSON文本, 位置 + 6)        温度 = Split(温度, """)(0)    End If    ' 查找天气描述    位置 = InStr(1, JSON文本, "text"":""")    If 位置 > 0 Then        天气 = Mid(JSON文本, 位置 + 6)        天气 = Split(天气, """)(0)    End If    ' 查找湿度    位置 = InStr(1, JSON文本, "humidity"":""")    If 位置 > 0 Then        湿度 = Mid(JSON文本, 位置 + 10)        湿度 = Split(湿度, """)(0)    End If    ' 查找风向    位置 = InStr(1, JSON文本, "windDir"":""")    If 位置 > 0 Then        风向 = Mid(JSON文本, 位置 + 9)        风向 = Split(风向, """)(0)    End If    ' 显示结果    Dim 结果 As String    结果 = "🌤️ " & 城市 & " 当前天气" & vbCrLf & vbCrLf    结果 = 结果 & "📊 温度：" & 温度 & "°C" & vbCrLf    结果 = 结果 & "🌦️ 天气：" & 天气 & vbCrLf    结果 = 结果 & "💧 湿度：" & 湿度 & "%" & vbCrLf    结果 = 结果 & "🌬️ 风向：" & 风向 & vbCrLf & vbCrLf    结果 = 结果 & "⏰ 更新时间：" & Format(Now, "hh:nn:ss")    MsgBox 结果, vbInformation, "天气信息"    ' 保存到Excel    Call 保存天气到Excel(城市, 温度, 天气, 湿度, 风向)End Sub' 保存天气数据到ExcelPrivate Sub 保存天气到Excel(城市 As String, 温度 As String, 天气 As String, 湿度 As String, 风向 As String)    Dim ws As Worksheet    ' 检查是否存在天气记录表    On Error Resume Next    Set ws = ThisWorkbook.Sheets("天气记录")    On Error GoTo 0    If ws Is Nothing Then        ' 创建新工作表        Set ws = ThisWorkbook.Sheets.Add        ws.Name = "天气记录"        ' 设置表头        ws.Range("A1").Value = "查询时间"        ws.Range("B1").Value = "城市"        ws.Range("C1").Value = "温度(°C)"        ws.Range("D1").Value = "天气"        ws.Range("E1").Value = "湿度(%)"        ws.Range("F1").Value = "风向"        ' 设置格式        With ws.Range("A1:F1")            .Font.Bold = True            .Interior.Color = RGB(31, 78, 120)            .Font.Color = RGB(255, 255, 255)        End With    End If    ' 找到第一个空行    Dim 最后行 As Long    最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1    ' 写入数据    ws.Cells(最后行, 1).Value = Now    ws.Cells(最后行, 2).Value = 城市    ws.Cells(最后行, 3).Value = 温度    ws.Cells(最后行, 4).Value = 天气    ws.Cells(最后行, 5).Value = 湿度    ws.Cells(最后行, 6).Value = 风向    ' 自动调整列宽    ws.Columns.AutoFit    ' 添加边框    With ws.UsedRange        .Borders.LineStyle = xlContinuous        .Borders.Color = RGB(200, 200, 200)    End WithEnd Sub

04 实战2：获取实时汇率信息

'获取美元兑人民币汇率

Sub 获取实时汇率()    On Error GoTo 错误处理    ' 显示提示    Application.StatusBar = "正在获取汇率数据..."    Dim 请求 As Object    Set 请求 = CreateObject("MSXML2.XMLHTTP")    ' 使用免费汇率API    Dim API地址 As String    API地址 = "https://api.exchangerate-api.com/v4/latest/USD"    ' 发送异步请求    With 请求        .Open "GET", API地址, True        .send        ' 等待请求完成        Dim 开始时间 As Double        开始时间 = Timer        Do While .readyState <> 4            DoEvents            ' 超时处理（10秒）            If Timer - 开始时间 > 10 Then                MsgBox "请求超时，请检查网络连接", vbExclamation                Application.StatusBar = False                Exit Sub            End If        Loop    End With    Application.StatusBar = False    ' 处理响应    If 请求.Status = 200 Then        Dim 响应文本 As String        响应文本 = 请求.responseText        ' 解析汇率数据        Call 解析汇率数据(响应文本)    Else        MsgBox "获取汇率失败，状态码：" & 请求.Status, vbExclamation    End If    Exit Sub错误处理:    Application.StatusBar = False    MsgBox "获取汇率失败：" & Err.Description, vbCriticalEnd Sub' 解析汇率数据Private Sub 解析汇率数据(JSON文本 As String)    ' 创建新的工作表    Dim ws As Worksheet    Set ws = ThisWorkbook.Sheets.Add    ws.Name = "汇率数据_" & Format(Date, "mmdd")    ' 设置标题    ws.Range("A1").Value = "货币"    ws.Range("B1").Value = "汇率（1美元兑换）"    ' 设置标题格式    With ws.Range("A1:B1")        .Font.Bold = True        .Interior.Color = RGB(31, 78, 120)        .Font.Color = RGB(255, 255, 255)        .HorizontalAlignment = xlCenter    End With    ' 解析JSON（简单字符串处理）    Dim 开始位置 As Long, 结束位置 As Long    开始位置 = InStr(1, JSON文本, "rates"":{") + Len("rates"":{")    If 开始位置 > 0 Then        ' 提取rates部分        Dim 汇率部分 As String        结束位置 = InStr(开始位置, JSON文本, "}")        汇率部分 = Mid(JSON文本, 开始位置, 结束位置 - 开始位置)        ' 分割为键值对        Dim 汇率数组() As String        汇率数组 = Split(汇率部分, ",")        ' 写入数据        Dim i As Long, 行号 As Long        行号 = 2        ' 常见货币列表        Dim 常见货币 As Variant        常见货币 = Array("CNY", "EUR", "JPY", "GBP", "HKD", "CAD", "AUD")        ' 先写常见货币        Dim 货币代码 As Variant        For Each 货币代码 In 常见货币            For i = 0 To UBound(汇率数组)                If InStr(汇率数组(i), 货币代码) > 0 Then                    Dim 键值对 As String                    键值对 = 汇率数组(i)                    ' 清理字符串                    键值对 = Replace(键值对, """", "")                    键值对 = Replace(键值对, "}", "")                    键值对 = Replace(键值对, "{", "")                    Dim 货币 As String, 汇率 As String                    Dim 冒号位置 As Long                    冒号位置 = InStr(1, 键值对, ":")                    If 冒号位置 > 0 Then                        货币 = Trim(Left(键值对, 冒号位置 - 1))                        汇率 = Trim(Mid(键值对, 冒号位置 + 1))                        ws.Cells(行号, 1).Value = 货币                        ws.Cells(行号, 2).Value = CDbl(汇率)                        ' 高亮人民币                        If 货币 = "CNY" Then                            ws.Cells(行号, 1).Interior.Color = RGB(255, 255, 200)                            ws.Cells(行号, 2).Interior.Color = RGB(255, 255, 200)                        End If                        行号 = 行号 + 1                        Exit For                    End If                End If            Next i        Next 货币代码        ' 添加分隔行        ws.Cells(行号, 1).Value = "--- 其他货币 ---"        ws.Cells(行号, 1).Font.Bold = True        行号 = 行号 + 1        ' 写入其他货币        For i = 0 To UBound(汇率数组)            Dim 已存在 As Boolean            已存在 = False            ' 检查是否已在常见货币中            For Each 货币代码 In 常见货币                If InStr(汇率数组(i), 货币代码) > 0 Then                    已存在 = True                    Exit For                End If            Next 货币代码            If Not 已存在 Then                Dim 其他键值对 As String                其他键值对 = 汇率数组(i)                其他键值对 = Replace(其他键值对, """", "")                其他键值对 = Replace(其他键值对, "}", "")                其他键值对 = Replace(其他键值对, "{", "")                Dim 其他冒号位置 As Long                其他冒号位置 = InStr(1, 其他键值对, ":")                If 其他冒号位置 > 0 Then                    Dim 其他货币 As String, 其他汇率 As String                    其他货币 = Trim(Left(其他键值对, 其他冒号位置 - 1))                    其他汇率 = Trim(Mid(其他键值对, 其他冒号位置 + 1))                    ' 跳过太小的值                    If Len(其他货币) = 3 And IsNumeric(其他汇率) Then                        ws.Cells(行号, 1).Value = 其他货币                        ws.Cells(行号, 2).Value = CDbl(其他汇率)                        行号 = 行号 + 1                    End If                End If            End If        Next i    End If    ' 格式化表格    With ws.UsedRange        .Borders.LineStyle = xlContinuous        .Borders.Color = RGB(200, 200, 200)        .HorizontalAlignment = xlCenter    End With    ' 设置汇率列为数字格式    ws.Columns(2).NumberFormat = "0.0000"    ' 自动调整列宽    ws.Columns.AutoFit    ' 添加标题    Dim 最后行 As Long    最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row    ws.Range("D1").Value = "汇率说明"    ws.Range("D1").Font.Bold = True    ws.Range("D2").Value = "数据来源：exchangerate-api.com"    ws.Range("D3").Value = "基准货币：USD（美元）"    ws.Range("D4").Value = "更新时间：" & Now    ws.Range("D5").Value = "记录条数：" & 最后行 - 1    ' 设置说明列格式    ws.Range("D2:D5").WrapText = True    ws.Columns("D").ColumnWidth = 20    MsgBox "✅ 汇率数据获取完成！" & vbCrLf & _           "已保存到工作表：" & ws.Name, vbInformationEnd Sub

05 实战3：调用快递查询API

查询快递信息

Sub 查询快递信息()    On Error GoTo 错误处理    ' 获取快递单号    Dim 快递单号 As String    快递单号 = InputBox("请输入快递单号：", "快递查询")    If 快递单号 = "" Then Exit Sub    ' 显示进度    Application.StatusBar = "正在查询快递信息..."    Dim 请求 As Object    Set 请求 = CreateObject("MSXML2.XMLHTTP")    ' 使用快递100的API（需要申请密钥）    ' 注册地址：https://www.kuaidi100.com/openapi/    Dim API密钥 As String    API密钥 = "你的API密钥"  ' 替换为你的实际密钥    ' 自动识别快递公司    Dim API地址 As String    API地址 = "https://www.kuaidi100.com/autonumber/auto?" & _              "num=" & 快递单号 & "&key=" & API密钥    With 请求        .Open "GET", API地址, False        .send    End With    If 请求.Status = 200 Then        Dim 公司列表 As String        公司列表 = 请求.responseText        ' 解析可能的快递公司        Dim 快递公司 As String        快递公司 = 识别快递公司(公司列表)        If 快递公司 <> "" Then            ' 查询快递详情            Call 查询快递详情(快递单号, 快递公司, API密钥)        Else            MsgBox "无法识别快递公司，请手动输入", vbExclamation            快递公司 = InputBox("请输入快递公司代码：" & vbCrLf & _                              "如：yunda（韵达）、sto（申通）、zto（中通）", "选择快递公司")            If 快递公司 <> "" Then                Call 查询快递详情(快递单号, 快递公司, API密钥)            End If        End If    Else        MsgBox "查询失败，状态码：" & 请求.Status, vbExclamation    End If    Application.StatusBar = False    Exit Sub错误处理:    Application.StatusBar = False    MsgBox "查询快递失败：" & Err.Description, vbCriticalEnd Sub' 识别快递公司Private Function 识别快递公司(JSON文本 As String) As String    ' 简单解析，返回第一个可能的快递公司    If InStr(JSON文本, "comCode") > 0 Then        Dim 开始位置 As Long, 结束位置 As Long        开始位置 = InStr(JSON文本, "comCode"":""") + Len("comCode"":""")        If 开始位置 > 0 Then            结束位置 = InStr(开始位置, JSON文本, """")            识别快递公司 = Mid(JSON文本, 开始位置, 结束位置 - 开始位置)        End If    End IfEnd Function' 查询快递详情Private Sub 查询快递详情(快递单号 As String, 快递公司 As String, API密钥 As String)    Dim 请求 As Object    Set 请求 = CreateObject("MSXML2.XMLHTTP")    Dim API地址 As String    API地址 = "https://www.kuaidi100.com/query?" & _              "type=" & 快递公司 & "&postid=" & 快递单号 & "&id=1&valicode=&temp=0.123456"    With 请求        .Open "GET", API地址, False        .send    End With    If 请求.Status = 200 Then        Dim 详情JSON As String        详情JSON = 请求.responseText        ' 显示快递信息        Call 显示快递信息(详情JSON, 快递单号, 快递公司)    Else        MsgBox "查询详情失败", vbExclamation    End IfEnd Sub' 显示快递信息Private Sub 显示快递信息(JSON文本 As String, 快递单号 As String, 快递公司 As String)    ' 创建新的工作表    Dim ws As Worksheet    Set ws = ThisWorkbook.Sheets.Add    ws.Name = "快递_" & 快递单号    ' 设置标题    ws.Range("A1").Value = "时间"    ws.Range("B1").Value = "状态"    ' 设置标题格式    With ws.Range("A1:B1")        .Font.Bold = True        .Interior.Color = RGB(31, 78, 120)        .Font.Color = RGB(255, 255, 255)    End With    ' 解析快递跟踪信息    Dim 位置 As Long, 行号 As Long    行号 = 2    ' 查找data数组    位置 = InStr(1, JSON文本, "data"":[{")    If 位置 > 0 Then        Dim 数据部分 As String        数据部分 = Mid(JSON文本, 位置 + 6)  ' 跳过 "data":[{        ' 分割每条记录        Dim 记录数组() As String        记录数组 = Split(数据部分, "},{")        Dim i As Long        For i = 0 To UBound(记录数组)            ' 清理字符串            Dim 记录 As String            记录 = 记录数组(i)            记录 = Replace(记录, "[", "")            记录 = Replace(记录, "]", "")            记录 = Replace(记录, "{", "")            记录 = Replace(记录, "}", "")            记录 = Replace(记录, """", "")            ' 解析时间和状态            Dim 字段数组() As String            字段数组 = Split(记录, ",")            Dim 时间 As String, 状态 As String            Dim 字段 As Variant            For Each 字段 In 字段数组                If InStr(字段, "time:") > 0 Then                    时间 = Split(字段, ":")(1)                ElseIf InStr(字段, "context:") > 0 Then                    状态 = Split(字段, ":")(1)                End If            Next 字段            ' 写入Excel            If 时间 <> "" And 状态 <> "" Then                ws.Cells(行号, 1).Value = 时间                ws.Cells(行号, 2).Value = 状态                行号 = 行号 + 1            End If        Next i    End If    ' 添加快递信息    Dim 最后行 As Long    最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 2    ws.Cells(最后行, 1).Value = "快递单号："    ws.Cells(最后行, 2).Value = 快递单号    ws.Cells(最后行 + 1, 1).Value = "快递公司："    ws.Cells(最后行 + 1, 2).Value = 快递公司    ws.Cells(最后行 + 2, 1).Value = "查询时间："    ws.Cells(最后行 + 2, 2).Value = Now    ' 格式化表格    ws.Columns("A:B").AutoFit    With ws.UsedRange        .Borders.LineStyle = xlContinuous        .Borders.Color = RGB(200, 200, 200)    End With    ' 设置时间列格式    ws.Columns("A").ColumnWidth = 20    MsgBox "✅ 快递信息查询完成！" & vbCrLf & _           "已保存到工作表：" & ws.Name, vbInformationEnd Sub

06 实战4：发送电子邮件

通过VBA发送电子邮件

Sub 发送电子邮件()OnErrorGoTo 错误处理' 检查Outlook是否可用Dim Outlook应用 AsObjectOnErrorResumeNextSet Outlook应用 = GetObject(, "Outlook.Application")If Outlook应用 IsNothingThenSet Outlook应用 = CreateObject("Outlook.Application")EndIfOnErrorGoTo 错误处理' 创建邮件对象Dim 邮件 AsObjectSet 邮件 = Outlook应用.CreateItem(0)  ' 0 = olMailItem' 设置邮件内容With 邮件' 收件人.To = InputBox("请输入收件人邮箱：", "发送邮件")If .To = ""ThenExitSub' 主题.Subject = InputBox("请输入邮件主题：", "发送邮件", "Excel自动发送的邮件")' 正文Dim 正文 AsString正文 = "这是一封由Excel VBA自动发送的测试邮件。" & vbCrLf & vbCrLf正文 = 正文 & "发送时间：" & Now & vbCrLf正文 = 正文 & "发送自：" & Environ("USERNAME") & " 的电脑".Body = 正文' 添加附件（可选）If MsgBox("是否添加附件？", vbYesNo + vbQuestion, "添加附件") = vbYes ThenDim 文件选择 AsObjectSet 文件选择 = Application.FileDialog(1)  ' msoFileDialogFilePickerWith 文件选择.Title = "选择附件".AllowMultiSelect = TrueIf .Show = -1ThenDim i AsLongFor i = 1To .SelectedItems.Count.Attachments.Add .SelectedItems(i)Next iEndIfEndWithEndIf' 发送邮件.SendEndWithMsgBox "✅ 邮件发送成功！", vbInformation' 清理对象Set 邮件 = NothingSet Outlook应用 = NothingExitSub错误处理:MsgBox "发送邮件失败：" & Err.Description, vbCritical' 清理对象OnErrorResumeNextIfNot 邮件 IsNothingThenSet 邮件 = NothingIfNot Outlook应用 IsNothingThenSet Outlook应用 = NothingEndSub

批量发送邮件

Sub 批量发送邮件()OnErrorGoTo 错误处理' 获取收件人列表Dim ws As WorksheetSet ws = ThisWorkbook.Sheets("邮件列表")' 检查工作表是否存在If ws IsNothingThenMsgBox "请先创建'邮件列表'工作表，包含以下列：" & vbCrLf & _"A列：姓名" & vbCrLf & "B列：邮箱" & vbCrLf & "C列：部门", vbExclamationExitSubEndIf' 获取最后一行Dim 最后行 AsLong最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).RowIf 最后行 < 2ThenMsgBox "邮件列表为空，请在A2开始填写数据", vbExclamationExitSubEndIf' 获取邮件模板Dim 主题 AsString, 正文模板 AsString主题 = InputBox("请输入邮件主题：", "批量发送", "月度工作报告")正文模板 = "尊敬的 {姓名}：" & vbCrLf & vbCrLf正文模板 = 正文模板 & "这是您的{部门}月度工作报告。" & vbCrLf & vbCrLf正文模板 = 正文模板 & "请查收附件，如有问题请及时联系。" & vbCrLf & vbCrLf正文模板 = 正文模板 & "发送时间：" & Now & vbCrLf正文模板 = 正文模板 & "发送系统：Excel自动发送系统"' 确认发送If MsgBox("即将向 " & (最后行 - 1) & " 位收件人发送邮件，是否继续？", vbYesNo + vbQuestion) = vbNo ThenExitSubEndIf' 创建Outlook应用Dim Outlook应用 AsObjectSet Outlook应用 = CreateObject("Outlook.Application")' 发送进度Dim 进度 AsDoubleDim 成功数量 AsLong, 失败数量 AsLong成功数量 = 0失败数量 = 0' 遍历每一行Dim i AsLongFor i = 2To 最后行Dim 姓名 AsString, 邮箱 AsString, 部门 AsString姓名 = ws.Cells(i, 1).Value邮箱 = ws.Cells(i, 2).Value部门 = ws.Cells(i, 3).Value' 检查邮箱格式If InStr(邮箱, "@") > 0ThenOnErrorResumeNext' 创建邮件Dim 邮件 AsObjectSet 邮件 = Outlook应用.CreateItem(0)With 邮件.To = 邮箱.Subject = 主题' 替换模板中的变量Dim 正文 AsString正文 = Replace(正文模板, "{姓名}", 姓名)正文 = Replace(正文, "{部门}", 部门).Body = 正文' 发送.SendIf Err.Number = 0Then成功数量 = 成功数量 + 1Else失败数量 = 失败数量 + 1' 记录错误ws.Cells(i, 4).Value = "发送失败：" & Err.DescriptionErr.ClearEndIfEndWithSet 邮件 = NothingOnErrorGoTo0' 更新进度进度 = i / 最后行 * 100Application.StatusBar = "正在发送邮件... " & Round(进度, 1) & "%"Else失败数量 = 失败数量 + 1ws.Cells(i, 4).Value = "邮箱格式错误"EndIf' 暂停一下，避免发送太快DoEventsNext iApplication.StatusBar = False' 显示结果MsgBox "✅ 邮件发送完成！" & vbCrLf & _"成功发送：" & 成功数量 & " 封" & vbCrLf & _"发送失败：" & 失败数量 & " 封", vbInformation' 清理Set Outlook应用 = NothingExitSub错误处理:Application.StatusBar = FalseMsgBox "批量发送失败：" & Err.Description, vbCriticalEndSub

07 创建API工具箱

API工具箱主界面

Sub 显示APIToolbox()' 创建工具箱工作表Dim ws As WorksheetOn Error Resume NextSet ws = ThisWorkbook.Sheets("API工具箱")On Error GoTo 0If ws Is Nothing ThenSet ws = ThisWorkbook.Sheets.Addws.Name = "API工具箱"End Ifws.Cells.Clear' 创建标题With ws.Range("A1").Value = "🔧 VBA API 工具箱".Font.Size = 20.Font.Bold = True.Font.Color = RGB(31, 78, 120)End With' 创建功能列表ws.Range("A3").Value = "🌐 网络API功能"ws.Range("A3").Font.Bold = Truews.Range("A3").Font.Size = 14' 功能说明Dim 功能列表 As Variant功能列表 = Array( _Array("1. 查询天气", "获取指定城市的实时天气信息", "获取天气信息"), _Array("2. 查询汇率", "获取美元兑人民币等实时汇率", "获取实时汇率"), _Array("3. 快递查询", "查询快递物流信息", "查询快递信息"), _Array("4. 发送邮件", "通过Outlook发送电子邮件", "发送电子邮件"), _Array("5. 批量发邮件", "向邮件列表批量发送邮件", "批量发送邮件"), _Array("6. 测试连接", "测试API连接是否正常", "测试API连接") _)Dim i As LongFor i = 0 To UBound(功能列表)ws.Cells(5 + i, 1).Value = 功能列表(i)(0)ws.Cells(5 + i, 2).Value = 功能列表(i)(1)Next i' 添加按钮Call 添加API工具箱按钮(ws, 功能列表)' 添加使用说明Dim 最后行 As Long最后行 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 2ws.Cells(最后行, 1).Value = "📋 使用说明："ws.Cells(最后行, 1).Font.Bold = True最后行 = 最后行 + 1ws.Cells(最后行, 1).Value = "1. 首次使用某些API需要申请API密钥"ws.Cells(最后行 + 1, 1).Value = "2. 天气API：https://dev.qweather.com"ws.Cells(最后行 + 2, 1).Value = "3. 快递API：https://www.kuaidi100.com/openapi"ws.Cells(最后行 + 3, 1).Value = "4. 汇率API：无需密钥，但有限制"' 格式化ws.Columns("A:B").AutoFit' 设置列宽ws.Columns("A").ColumnWidth = 20ws.Columns("B").ColumnWidth = 40' 激活工作表ws.ActivateMsgBox "✅ API工具箱已创建！" & vbCrLf & _"请在'API工具箱'工作表中操作。", vbInformationEnd Sub' 添加工具箱按钮Private Sub 添加API工具箱按钮(ws As Worksheet, 功能列表 As Variant)' 清除旧按钮On Error Resume Nextws.Buttons.Deletews.OLEObjects.DeleteOn Error GoTo 0' 添加按钮Dim i As LongFor i = 0 To UBound(功能列表)Dim 按钮 As ButtonSet 按钮 = ws.Buttons.Add( _Left:=ws.Cells(5 + i, 3).Left, _Top:=ws.Cells(5 + i, 3).Top, _Width:=80, _Height:=25)With 按钮.Caption = "运行".OnAction = 功能列表(i)(2)End WithNext iEnd Sub' 测试API连接Sub 测试API连接()On Error GoTo 错误处理' 测试网络连接Dim 请求 As ObjectSet 请求 = CreateObject("MSXML2.XMLHTTP")' 使用一个可靠的测试地址Dim 测试地址 As String测试地址 = "https://httpbin.org/get"With 请求.Open "GET", 测试地址, False.sendEnd WithIf 请求.Status = 200 Then' 测试天气APIDim 天气请求 As ObjectSet 天气请求 = CreateObject("MSXML2.XMLHTTP")Dim 天气地址 As String天气地址 = "https://devapi.qweather.com/v7/weather/now?key=test&location=beijing"With 天气请求.Open "GET", 天气地址, False.sendEnd WithDim 结果 As String结果 = "✅ 网络连接正常" & vbCrLf & vbCrLf结果 = 结果 & "📡 基础网络测试：" & vbCrLf结果 = 结果 & "  状态码：" & 请求.Status & vbCrLf结果 = 结果 & "  响应时间：正常" & vbCrLf & vbCrLf结果 = 结果 & "🌤️ 天气API测试：" & vbCrLf结果 = 结果 & "  状态码：" & 天气请求.Status & vbCrLfIf 天气请求.Status = 200 Then结果 = 结果 & "  状态：需要有效API密钥" & vbCrLfElseIf 天气请求.Status = 401 Then结果 = 结果 & "  状态：API密钥无效（需要申请）" & vbCrLfElse结果 = 结果 & "  状态：可连接" & vbCrLfEnd If结果 = 结果 & vbCrLf & "💡 建议：" & vbCrLf结果 = 结果 & "1. 确保网络连接正常" & vbCrLf结果 = 结果 & "2. 申请相应API的密钥" & vbCrLf结果 = 结果 & "3. 将密钥填入代码对应位置"MsgBox 结果, vbInformation, "API连接测试"ElseMsgBox "❌ 网络连接失败，请检查网络设置", vbExclamationEnd IfExit Sub错误处理:MsgBox "测试失败：" & Err.Description, vbCriticalEnd Sub

08 7天VBA学习之旅总结

回顾7天的学习成果：

天数	学习内容	核心技能	实战项目
第1天	VBA基础入门	宏录制、基本语法	年度报告生成器
第2天	流程控制	条件判断、循环	智能数据处理
第3天	数组与函数	数组操作、自定义函数	批量文件处理
第4天	错误处理	On Error、调试工具	容错性程序
第5天	用户窗体	界面设计、控件使用	员工信息录入系统
第6天	数据库操作	ADO连接、SQL操作	员工管理系统
第7天	API调用	HTTP请求、数据解析	API工具箱

你现在已经掌握了：

✅基础编程- VBA语法、流程控制、函数编写

✅数据处理- 数组操作、文件处理、批量操作

✅错误处理- 调试技巧、异常处理、日志记录

✅界面设计- 用户窗体、控件使用、交互设计

✅数据库- 连接操作、SQL编程、数据管理

✅网络编程- API调用、HTTP请求、数据解析

✅系统集成- 邮件发送、Office集成、自动化

学习建议和下一步方向：

1. 继续深入的方向：

🔧高级VBA- 类模块、事件编程、自定义对象

🌐Web技术- 网页抓取、JSON解析、REST API

📊数据分析- 结合Power Query、Power Pivot

🤖自动化- 定时任务、工作流自动化

2. 实际应用建议：

从工作中找一个重复性高的任务，用VBA自动化

创建自己的工具库，积累常用代码

参与VBA社区，学习他人经验

尝试将多个技能组合，解决复杂问题

3. 学习资源推荐：

📚 书籍：《Excel VBA编程实战宝典》

🌐 网站：ExcelHome、Stack Overflow

🎥 视频：YouTube上的Excel VBA教程

👥 社区：知乎VBA话题、CSDN VBA专区

最后的寄语

老王看着小张完成的API工具箱，欣慰地说：

"经过7天的学习，你已经从VBA的'门外汉'，成长为能够独立开发完整系统的'程序员'了。"

"记住，编程不仅仅是写代码，更是解决问题的思维方式。你现在掌握的VBA技能，已经能够解决工作中80%的自动化需求。"

"技术的道路没有终点，但你已经有了坚实的起点。保持好奇心，持续学习，你会发现编程的世界越来越精彩。"

"这7天，我们让Excel从："

"📝 简单的表格工具 → 🧠 智能的数据处理器 → 🛡️ 稳定的工作助手 → 🎨 友好的用户界面 → 🗃️ 专业的数据系统 → 🌐 连接世界的工具"

"恭喜你，完成了VBA的入门之旅！现在，去创造属于你自己的自动化工具吧！"

记住：最好的学习，就是开始动手做项目。选择一个你工作中最头疼的重复性任务，用这7天学到的技能去自动化它。每解决一个问题，你的技能就会提升一级。

祝你编程愉快，创造无限！🚀

本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。

第7天实战:VBA与API交互,让Excel连接互联网世界

01 准备工作：添加API调用引用

02 基础概念：什么是API？

03 实战1：获取实时天气信息

04 实战2：获取实时汇率信息

05 实战3：调用快递查询API

06 实战4：发送电子邮件

07 创建API工具箱

08 7天VBA学习之旅总结

最后的寄语

【ppt+讲稿】高中班主任通用中等生动员班会课件:破茧成蝶,飞往下一站春和景明

个靠AI做PPT月入过万的朋友,终于告诉我实话了