如何通过Access VBA调用Facebook Graph API上传本地图片至Facebook主页

单张本地图片上传实现 #

原代码通过url参数上传网络图片，本地图片需要通过source参数传递二进制文件内容。以下是修改后的完整代码：

Sub UploadLocalImageToFacebook()
    Dim httpRequest As Object
    Dim boundary As String
    Dim postStream As Object 'ADODB.Stream用于拼接二进制请求体
    Dim pageID As String, accessToken As String, localFilePath As String, message As String
    Dim fileStream As Object
    Dim fileBytes() As Byte
    
    '配置参数
    pageID = "[My Page ID]"
    accessToken = "[My long-lived Access Token]"
    localFilePath = "C:\path\to\your\image.jpg" '替换为本地图片实际路径
    message = "本地图片测试"
    
    '验证文件存在
    If Dir(localFilePath) = "" Then
        Debug.Print "错误：文件不存在"
        Exit Sub
    End If
    
    '生成随机边界符
    boundary = "----------------------------" & Format(Now, "ddmmyyyyhhmmss")
    
    '初始化流对象
    Set postStream = CreateObject("ADODB.Stream")
    postStream.Charset = "UTF-8"
    postStream.Mode = 3 '读写模式
    postStream.Open
    
    '写入message部分
    postStream.WriteText "--" & boundary & vbCrLf
    postStream.WriteText "Content-Disposition: form-data; name=""message""" & vbCrLf
    postStream.WriteText "Content-Type: text/plain; charset=UTF-8" & vbCrLf & vbCrLf
    postStream.WriteText message & vbCrLf
    
    '写入图片二进制部分
    postStream.WriteText "--" & boundary & vbCrLf
    postStream.WriteText "Content-Disposition: form-data; name=""source""; filename=""" & Dir(localFilePath) & """" & vbCrLf
    postStream.WriteText "Content-Type: image/jpeg" & vbCrLf & vbCrLf 'PNG图片请改为image/png
    postStream.Position = postStream.Size '切换到二进制模式前先定位到流末尾
    
    '读取本地图片二进制数据
    Set fileStream = CreateObject("ADODB.Stream")
    fileStream.Type = 1 '二进制模式
    fileStream.Open
    fileStream.LoadFromFile localFilePath
    fileBytes = fileStream.Read
    fileStream.Close
    Set fileStream = Nothing
    
    '将图片二进制写入请求流
    postStream.Write fileBytes
    postStream.WriteText vbCrLf
    
    '写入结束边界
    postStream.WriteText "--" & boundary & "--" & vbCrLf
    
    '发送请求
    Set httpRequest = CreateObject("MSXML2.XMLHTTP")
    With httpRequest
        .Open "POST", "https://graph.facebook.com/" & pageID & "/photos?access_token=" & accessToken, False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
        postStream.Position = 0 '定位到流开头
        .send postStream.Read
        postStream.Close
        Set postStream = Nothing
        
        If .status = 200 Then
            Debug.Print "上传成功：" & .responseText
        Else
            Debug.Print "错误：" & .status & " - " & .statusText & vbCrLf & .responseText
        End If
    End With
    Set httpRequest = Nothing
End Sub

关键修改说明 #

• 改用ADODB.Stream拼接二进制请求体，本地图片需以二进制形式传递，而非文本路径
• 将原url参数替换为Facebook API指定的source参数
• 添加文件存在校验，避免路径错误导致的失败
• 为图片部分设置对应Content-Type（JPG用image/jpeg，PNG用image/png）

多张图片上传实现 #

推荐使用「先上传单图获取ID，再关联到同一条帖子」的方式，稳定性更高：

步骤1：批量上传图片获取ID #

Function UploadMultipleImages(imagePaths As Variant) As Collection
    Dim colImageIDs As New Collection
    Dim httpRequest As Object
    Dim boundary As String
    Dim postStream As Object
    Dim fileStream As Object
    Dim fileBytes() As Byte
    Dim imgPath As Variant
    Dim pageID As String, accessToken As String
    
    pageID = "[My Page ID]"
    accessToken = "[My long-lived Access Token]"
    
    For Each imgPath In imagePaths
        If Dir(imgPath) = "" Then
            Debug.Print "跳过不存在的文件：" & imgPath
            GoTo NextImage
        End If
        
        boundary = "----------------------------" & Format(Now, "ddmmyyyyhhmmss")
        Set postStream = CreateObject("ADODB.Stream")
        postStream.Charset = "UTF-8"
        postStream.Mode = 3
        postStream.Open
        
        '仅上传图片（不带message，避免自动生成单图帖子）
        postStream.WriteText "--" & boundary & vbCrLf
        postStream.WriteText "Content-Disposition: form-data; name=""source""; filename=""" & Dir(imgPath) & """" & vbCrLf
        postStream.WriteText IIf(LCase(Right(imgPath, 3)) = "png", "image/png", "image/jpeg") & vbCrLf & vbCrLf
        postStream.Position = postStream.Size
        
        Set fileStream = CreateObject("ADODB.Stream")
        fileStream.Type = 1
        fileStream.Open
        fileStream.LoadFromFile imgPath
        fileBytes = fileStream.Read
        fileStream.Close
        Set fileStream = Nothing
        
        postStream.Write fileBytes
        postStream.WriteText vbCrLf & "--" & boundary & "--" & vbCrLf
        
        Set httpRequest = CreateObject("MSXML2.XMLHTTP")
        With httpRequest
            .Open "POST", "https://graph.facebook.com/" & pageID & "/photos?access_token=" & accessToken & "&published=false", False
            'published=false：图片仅上传到相册，不自动发布帖子
            .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
            postStream.Position = 0
            .send postStream.Read
            postStream.Close
            Set postStream = Nothing
            
            If .status = 200 Then
                '解析返回的图片ID
                colImageIDs.Add Split(Split(.responseText, """id"":""")(1), """")(0)
            Else
                Debug.Print "上传失败：" & imgPath & vbCrLf & .status & " - " & .statusText
            End If
        End With
        Set httpRequest = Nothing
        
NextImage:
    Next imgPath
    
    Set UploadMultipleImages = colImageIDs
End Function

步骤2：创建关联多图的帖子 #

Sub CreateMultiImagePost(imagePaths As Variant, postMessage As String)
    Dim imgIDs As Collection
    Dim attachedMedia As String
    Dim httpRequest As Object
    Dim pageID As String, accessToken As String
    
    pageID = "[My Page ID]"
    accessToken = "[My long-lived Access Token]"
    
    '先上传所有图片获取ID
    Set imgIDs = UploadMultipleImages(imagePaths)
    If imgIDs.Count = 0 Then
        Debug.Print "无有效图片可发布"
        Exit Sub
    End If
    
    '构建attached_media JSON数组
    attachedMedia = "["
    Dim i As Integer
    For i = 1 To imgIDs.Count
        attachedMedia = attachedMedia & "{""media_fbid"":""" & imgIDs(i) & """}"
        If i < imgIDs.Count Then attachedMedia = attachedMedia & ","
    Next i
    attachedMedia = attachedMedia & "]"
    
    '发送帖子请求
    Set httpRequest = CreateObject("MSXML2.XMLHTTP")
    With httpRequest
        .Open "POST", "https://graph.facebook.com/" & pageID & "/feed?access_token=" & accessToken, False
        .setRequestHeader "Content-Type", "application/json"
        .send "{""message"":""" & postMessage & """,""attached_media"":" & attachedMedia & "}"
        
        If .status = 200 Then
            Debug.Print "多图帖子发布成功：" & .responseText
        Else
            Debug.Print "帖子发布失败：" & .status & " - " & .statusText & vbCrLf & .responseText
        End If
    End With
    Set httpRequest = Nothing
End Sub

调用示例 #

Sub TestMultiUpload()
    Dim imgPaths As Variant
    imgPaths = Array("C:\img1.jpg", "C:\img2.png", "C:\img3.jpg")
    CreateMultiImagePost imgPaths, "多图测试帖子"
End Sub

多图上传说明 #

• 使用published=false参数避免上传图片时自动生成单图帖子
• 通过attached_media参数将多个图片ID关联到同一条帖子
• 自动识别图片格式并设置对应Content-Type

内容的提问来源于stack exchange，提问作者Chris Lydon