求MS Access 2016中剪贴板截图存JPG的VBA代码或BMP转JPG方法

我来帮你解决MS Access 2016里直接处理剪贴板截图存为JPG的问题——不用绕Excel，速度能提升很多！下面给你两个实用的方案，都是纯VBA调用Windows底层API实现的，完全满足你的需求：

这个方法能跳过BMP中间步骤，直接把剪贴板里的截图转成JPG保存，效率最高。你需要把代码放到Access的标准模块里（别放到窗体/报表模块）：

' 适配32/64位Access的API声明
#If VBA7 Then
    Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal uFormat As Long) As LongPtr
    Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
    Declare PtrSafe Function CopyImage Lib "user32.dll" (ByVal hImage As LongPtr, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuFlags As Long) As LongPtr
    Declare PtrSafe Function GdiplusStartup Lib "gdiplus.dll" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, ByVal outputbuf As LongPtr) As Long
    Declare PtrSafe Function GdiplusShutdown Lib "gdiplus.dll" (ByVal token As LongPtr) As Long
    Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As LongPtr, ByVal hpal As LongPtr, ByRef bitmap As LongPtr) As Long
    Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus.dll" (ByVal image As LongPtr, ByVal filename As LongPtr, ByRef clsidEncoder As GUID, ByRef encoderParams As EncoderParameters) As Long
    Declare PtrSafe Function GdipDisposeImage Lib "gdiplus.dll" (ByVal image As LongPtr) As Long
    Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long
    Declare PtrSafe Function GdipGetImageEncodersSize Lib "gdiplus.dll" (ByRef numEncoders As LongPtr, ByRef size As LongPtr) As Long
    Declare PtrSafe Function GdipGetImageEncoders Lib "gdiplus.dll" (ByVal numEncoders As LongPtr, ByVal size As LongPtr, ByVal encoders As LongPtr) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal bytes As LongPtr)
    Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalFree Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
#Else
    Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
    Declare Function GetClipboardData Lib "user32.dll" (ByVal uFormat As Long) As Long
    Declare Function CloseClipboard Lib "user32.dll" () As Long
    Declare Function CopyImage Lib "user32.dll" (ByVal hImage As Long, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuFlags As Long) As Long
    Declare Function GdiplusStartup Lib "gdiplus.dll" (ByRef token As Long, ByRef inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    Declare Function GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long) As Long
    Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As Long
    Declare Function GdipSaveImageToFile Lib "gdiplus.dll" (ByVal image As Long, ByVal filename As String, ByRef clsidEncoder As GUID, ByRef encoderParams As EncoderParameters) As Long
    Declare Function GdipDisposeImage Lib "gdiplus.dll" (ByVal image As Long) As Long
    Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As String, ByRef pclsid As GUID) As Long
    Declare Function GdipGetImageEncodersSize Lib "gdiplus.dll" (ByRef numEncoders As Long, ByRef size As Long) As Long
    Declare Function GdipGetImageEncoders Lib "gdiplus.dll" (ByVal numEncoders As Long, ByVal size As Long, ByVal encoders As Long) As Long
    Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (dst As Any, src As Any, ByVal bytes As Long)
    Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
#End If

' 常量定义
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const GMEM_ZEROINIT = &H40

' 自定义类型
Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Type EncoderParameters
    Count As Long
    Parameter(0) As EncoderParameter
End Type

Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    Type As Long
    Value As LongPtr
End Type

Type PICTDESC
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
End Type

' 获取JPG编码器的CLSID
Private Function GetEncoderClsid(ByVal format As String, ByRef pClsid As GUID) As Long
    #If VBA7 Then
        Dim bufferSize As LongPtr
        Dim numEncoders As LongPtr
        Dim encoders As LongPtr
    #Else
        Dim bufferSize As Long
        Dim numEncoders As Long
        Dim encoders As Long
    #End If
    Dim status As Long
    
    status = GdipGetImageEncodersSize(numEncoders, bufferSize)
    If status <> 0 Then GoTo ErrorHandler
    
    encoders = GlobalAlloc(GMEM_ZEROINIT, bufferSize)
    If encoders = 0 Then GoTo ErrorHandler
    
    status = GdipGetImageEncoders(numEncoders, bufferSize, encoders)
    If status <> 0 Then GoTo Cleanup
    
    Dim i As Long
    #If VBA7 Then
        Dim pEncoder As LongPtr
        pEncoder = encoders
    #Else
        Dim pEncoder As Long
        pEncoder = encoders
    #End If
    For i = 0 To numEncoders - 1
        Dim encoderName As String
        encoderName = String$(255, Chr(0))
        #If VBA7 Then
            CopyMemory ByVal StrPtr(encoderName), ByVal pEncoder + 16, 255
        #Else
            CopyMemory ByVal encoderName, ByVal pEncoder + 16, 255
        #End If
        encoderName = Left$(encoderName, InStr(encoderName, Chr(0)) - 1)
        If LCase(encoderName) = LCase(format) Then
            #If VBA7 Then
                CopyMemory pClsid, ByVal pEncoder, Len(pClsid)
            #Else
                CopyMemory pClsid, ByVal pEncoder, Len(pClsid)
            #End If
            GetEncoderClsid = 0
            Exit Function
        End If
        #If VBA7 Then
            pEncoder = pEncoder + 40 + 255 * 2
        #Else
            pEncoder = pEncoder + 40 + 255 * 2
        #End If
    Next i
    
    status = -1 ' 未找到编码器
    
Cleanup:
    GlobalFree encoders
ErrorHandler:
    GetEncoderClsid = status
End Function

' 从剪贴板获取位图句柄
Private Function GetClipboardBitmap() As LongPtr
    Dim hBitmap As LongPtr
    If OpenClipboard(0&) Then
        hBitmap = GetClipboardData(CF_BITMAP)
        If hBitmap <> 0 Then
            GetClipboardBitmap = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        End If
        CloseClipboard
    End If
End Function

' 主过程：保存剪贴板截图为JPG
Sub CopyScreenshotToJPG(savePath As String, Optional quality As Long = 80)
    Dim gdiToken As LongPtr
    Dim gdiInput As GdiplusStartupInput
    Dim hBitmap As LongPtr
    Dim gdiBitmap As LongPtr
    Dim jpgClsid As GUID
    Dim encoderParams As EncoderParameters
    Dim qualityValue As Long
    
    ' 初始化GDI+
    gdiInput.GdiplusVersion = 1
    If GdiplusStartup(gdiToken, gdiInput, 0&) <> 0 Then
        MsgBox "GDI+初始化失败！", vbCritical
        Exit Sub
    End If
    
    ' 获取剪贴板中的位图
    hBitmap = GetClipboardBitmap()
    If hBitmap = 0 Then
        MsgBox "剪贴板中没有截图数据！", vbExclamation
        GdiplusShutdown gdiToken
        Exit Sub
    End If
    
    ' 将HBITMAP转换为GDI+ Bitmap
    If GdipCreateBitmapFromHBITMAP(hBitmap, 0&, gdiBitmap) <> 0 Then
        MsgBox "转换为GDI+位图失败！", vbCritical
        GdiplusShutdown gdiToken
        Exit Sub
    End If
    
    ' 获取JPG编码器的CLSID
    If GetEncoderClsid("image/jpeg", jpgClsid) <> 0 Then
        MsgBox "找不到JPG编码器！", vbCritical
        GdipDisposeImage gdiBitmap
        GdiplusShutdown gdiToken
        Exit Sub
    End If
    
    ' 设置JPG质量参数（0-100，数值越高画质越好）
    qualityValue = quality
    encoderParams.Count = 1
    encoderParams.Parameter(0).NumberOfValues = 1
    encoderParams.Parameter(0).Type = 4 ' 长整型
    encoderParams.Parameter(0).Value = VarPtr(qualityValue)
    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), encoderParams.Parameter(0).GUID
    
    ' 保存为JPG文件
    #If VBA7 Then
        If GdipSaveImageToFile(gdiBitmap, StrPtr(savePath), jpgClsid, encoderParams) <> 0 Then
            MsgBox "保存JPG文件失败！", vbCritical
        Else
            MsgBox "截图已成功保存为：" & savePath, vbInformation
        End If
    #Else
        If GdipSaveImageToFile(gdiBitmap, savePath, jpgClsid, encoderParams) <> 0 Then
            MsgBox "保存JPG文件失败！", vbCritical
        Else
            MsgBox "截图已成功保存为：" & savePath, vbInformation
        End If
    #End If
    
    ' 清理资源
    GdipDisposeImage gdiBitmap
    GdiplusShutdown gdiToken
End Sub

怎么用？ #

比如你要把剪贴板截图存到C:\temp\my_screenshot.jpg，直接调用：

CopyScreenshotToJPG "C:\temp\my_screenshot.jpg", 90 ' 90是质量参数，可选

如果你已经有了BMP格式的截图文件，用这个函数直接转成JPG：

' 补充API声明（如果已经加了方案1的声明，这部分可以跳过）
#If VBA7 Then
    Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus.dll" (ByVal filename As LongPtr, ByRef image As LongPtr) As Long
#Else
    Declare Function GdipLoadImageFromFile Lib "gdiplus.dll" (ByVal filename As String, ByRef image As Long) As Long
#End If

' BMP转JPG主过程
Sub ConvertBMPtoJPG(bmpPath As String, jpgPath As String, Optional quality As Long = 80)
    Dim gdiToken As LongPtr
    Dim gdiInput As GdiplusStartupInput
    Dim gdiBitmap As LongPtr
    Dim jpgClsid As GUID
    Dim encoderParams As EncoderParameters
    Dim qualityValue As Long
    
    ' 初始化GDI+
    gdiInput.GdiplusVersion = 1
    If GdiplusStartup(gdiToken, gdiInput, 0&) <> 0 Then
        MsgBox "GDI+初始化失败！", vbCritical
        Exit Sub
    End If
    
    ' 加载BMP文件
    #If VBA7 Then
        If GdipLoadImageFromFile(StrPtr(bmpPath), gdiBitmap) <> 0 Then
    #Else
        If GdipLoadImageFromFile(bmpPath, gdiBitmap) <> 0 Then
    #End If
        MsgBox "加载BMP文件失败！", vbCritical
        GdiplusShutdown gdiToken
        Exit Sub
    End If
    
    ' 获取JPG编码器CLSID
    If GetEncoderClsid("image/jpeg", jpgClsid) <> 0 Then
        MsgBox "找不到JPG编码器！", vbCritical
        GdipDisposeImage gdiBitmap
        GdiplusShutdown gdiToken
        Exit Sub
    End If
    
    ' 设置质量参数
    qualityValue = quality
    encoderParams.Count = 1
    encoderParams.Parameter(0).NumberOfValues = 1
    encoderParams.Parameter(0).Type = 4
    encoderParams.Parameter(0).Value = VarPtr(qualityValue)
    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), encoderParams.Parameter(0).GUID
    
    ' 保存为JPG
    #If VBA7 Then
        If GdipSaveImageToFile(gdiBitmap, StrPtr(jpgPath), jpgClsid, encoderParams) <> 0 Then
            MsgBox "转换保存失败！", vbCritical
        Else
            MsgBox "BMP已成功转换为JPG：" & jpgPath, vbInformation
        End If
    #Else
        If GdipSaveImageToFile(gdiBitmap, jpgPath, jpgClsid, encoderParams) <> 0 Then
            MsgBox "转换保存失败！", vbCritical
        Else
            MsgBox "BMP已成功转换为JPG：" & jpgPath, vbInformation
        End If
    #End If
    
    ' 清理资源
    GdipDisposeImage gdiBitmap
    GdiplusShutdown gdiToken
End Sub

怎么用？ #

比如把C:\temp\old.bmp转成C:\temp\new.jpg：

ConvertBMPtoJPG "C:\temp\old.bmp", "C:\temp\new.jpg", 85

1. 确保保存路径的文件夹已经存在（比如C:\temp要先创建），否则会保存失败
2. 质量参数范围是0-100，数值越高画质越好，文件体积也越大
3. 代码适配32位和64位的MS Access 2016，不用额外修改

这个方法比你之前用Excel中转快太多——因为直接调用Windows的GDI+库，不需要启动Excel进程，避免了大量耗时的初始化操作。

内容的提问来源于stack exchange，提问作者Krzysztof Drabik