小张完成了数据库系统的开发，看着自动运行的员工管理系统，又想到了一个新问题：“老王，我们的系统现在能管理本地数据了，但很多实时信息都在网上，比如天气、汇率、股票行情，Excel能获取这些信息吗？”
老王眼睛一亮：“问得好！这就是最后一天要学的终极技能——API调用。让Excel不仅能处理本地数据，还能连接整个互联网！”小张兴奋地问：“我们真的能让Excel访问网站、获取实时数据吗？能自动发邮件、查天气吗？”“不仅能，而且比你想象的更简单。”老王打开VBA编辑器，“今天，我教你让Excel变身‘互联网客户端’，获取全世界的实时信息。”
01 准备工作：添加API调用引用
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里1. 创建请求 → 2. 设置参数 → 3. 发送请求 → 4. 接收响应 → 5. 解析数据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：获取实时天气信息
获取指定城市的天气信息
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：发送电子邮件
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工具箱
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学习之旅总结
天数 | 学习内容 | 核心技能 | 实战项目 |
|---|
第1天 | VBA基础入门 | 宏录制、基本语法 | 年度报告生成器 |
第2天 | 流程控制 | 条件判断、循环 | 智能数据处理 |
第3天 | 数组与函数 | 数组操作、自定义函数 | 批量文件处理 |
第4天 | 错误处理 | On Error、调试工具 | 容错性程序 |
第5天 | 用户窗体 | 界面设计、控件使用 | 员工信息录入系统 |
第6天 | 数据库操作 | ADO连接、SQL操作 | 员工管理系统 |
第7天 | API调用 | HTTP请求、数据解析 | API工具箱 |
🌐Web技术- 网页抓取、JSON解析、REST API📊数据分析- 结合Power Query、Power Pivot🌐 网站：ExcelHome、Stack Overflow🎥 视频：YouTube上的Excel VBA教程
最后的寄语
"经过7天的学习，你已经从VBA的'门外汉'，成长为能够独立开发完整系统的'程序员'了。""记住，编程不仅仅是写代码，更是解决问题的思维方式。你现在掌握的VBA技能，已经能够解决工作中80%的自动化需求。""技术的道路没有终点，但你已经有了坚实的起点。保持好奇心，持续学习，你会发现编程的世界越来越精彩。""📝 简单的表格工具 → 🧠 智能的数据处理器 → 🛡️ 稳定的工作助手 → 🎨 友好的用户界面 → 🗃️ 专业的数据系统 → 🌐 连接世界的工具""恭喜你，完成了VBA的入门之旅！现在，去创造属于你自己的自动化工具吧！"记住：最好的学习，就是开始动手做项目。选择一个你工作中最头疼的重复性任务，用这7天学到的技能去自动化它。每解决一个问题，你的技能就会提升一级。
