【vba源码】哪吒2火出圈，DeepSeek接入Access也来抢镜啦!

hi，大家好呀！

最近，哪吒太火了，票房还在持续增长，大家来猜猜看，最终哪吒的票房能有多高！

那今天我们是要来分享哪吒相关的内容吗？当然不是了！今天我们还是来讲DeepSeek，上周我们发了一个Access接入DeepSeek的视频，大家都在等我的源码文章，今天，源码就来啦，各位来跟我一起开发吧。

来吧，大家跟着我一起来做吧！开始前，各位客官老爺不要忘记给一键三连哦！

1

申请APIKeys

在开发之前，我们先要打开官网，在官网申请一个APIKeys，具体的入口如图：

在接口的申请页面，找到创建API key，点击输入一个名称，系统会自动给你生成一个key，生成的Key一定要复制保存，如果没有复制保存，那就只能重新操作一下了。

注意，这个API Key是关键哦！

2

创建窗体

在生成API key之后，我们就可以在Access中进行操作了，我们需要先创建一个窗体，在窗体上放几个控件，具体的如图：

3

添加代码

窗体做好了，我们就可以来写代码了，我们先来添加按钮的单击事件，具体的代码如下：

Private Function DeepSeekAI()
On Error GoTo ErrorHandler
Dim url As String
Dim xmlhttp As Object
Dim Response As String
Dim requestBody As String
Dim apiKey As String
Dim statusCode As String
' 设置接口URL
url = "https://api.deepseek.com/chat/completions"
apiKey =“你自己申请的API Key”
' 构建请求体（根据DeepSeek API要求调整）
requestBody = "{""model"": ""deepseek-chat"", ""messages"": [{""role"": ""user"", ""content"": """ & Me.txtQ & """}], ""temperature"": 0.7,""max_tokens"":8192}"
DoCmd.Hourglass True
Me.lblMsg.Caption = "正在思考，请等待……"
Me.Requery
Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
' Debug.Print token, url
xmlhttp.Open "POST", url, False
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.setRequestHeader "Authorization", "Bearer " & apiKey
xmlhttp.send requestBody
statusCode = xmlhttp.Status
Response = xmlhttp.responseText
' Debug.Print Response
xmlhttp.abort
' 检查HTTP状态码
If statusCode <> 200 Then
GoTo HttpError
End If
DeepSeekAI = Response
Me.lblMsg.Caption = "问题回答结束。"
Me.Requery
'======================== 错误处理模块 ========================
ExitHere:
DoCmd.Hourglass False
Exit Function
HttpError:
MsgBox "HTTP请求失败：" & vbCrLf & _
"状态码：" & statusCode & vbCrLf & _
"响应内容：" & Response
Resume ExitHere
ApiError:
MsgBox "API返回错误：" & vbCrLf & _
ParseApiErrorMessage(Response) ' 解析错误消息
Resume ExitHere
ErrorHandler:
MsgBox "错误：" & vbCrLf & _
"错误号：" & Err.Number & vbCrLf & _
"描述：" & Err.Description
Resume ExitHere
End Function

Function ParseApiErrorMessage(json As String) As String
On Error GoTo ParseError
Dim jsonObj As Object
Set jsonObj = JsonConverter.ParseJson(json)
ParseApiErrorMessage = jsonObj("error")("message")
Exit Function
ParseError:
ParseApiErrorMessage = "无法解析错误信息"
End Function
Private Sub btnOK_Click()
On Error GoTo ErrorHandler
Dim json As Object
Dim jsonObject As Object
Dim strSQL As String
If IsNull(Me.txtQ) Then
MsgBox "请输入你的问题", vbExclamation
Me.txtQ.SetFocus
Exit Sub
End If
Set json = JsonConverter.ParseJson(DeepSeekAI())
Me.txtMsg = json("choices")(1)("message")("content")
MsgBox "生成成功。", vbInformation
ExitHere:
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "#错误"
Resume ExitHere
End Sub

Private Sub Form_Load()
Me.lblMsg.Caption = "请输入你的问题"
End Sub

注意替换自己申请的API Key

另外，我们这里还用到了一个JSon的解析库，具体的地址：
https://github.com/VBA-tools/VBA-JSON

通过github下载下来后，我们只需要其中的“JsonConverter.bas” 这个模块

4

运行测试

最后，就是测试了，我们就可以直接在Access中与AI沟通了。因为DeepSeek的知识库截止日期是2024年7月，所以我们现在问哪吒2的问题，全出现这样的回答。

不管它回答的怎么样，但至少我们的功能成功了，大家快去试一下吧！

如果看到这里了，还不给我一键三连！谢谢大家！