使用到的代码包括2个：

1、lionking1990的Class_DC.cls

略有微调，我也不知道改了啥

Option Explicit '创建字体Private Const LF_FACESIZE = 32Private Const DEFAULT_CHARSET = 1Private Const LOGPIXELSY = 90 ' Logical pixels/inch in YPrivate Const FW_NORMAL = 400Private Const FW_HEAVY = 900Private Const OUT_DEFAULT_PRECIS = 0Private Const CLIP_DEFAULT_PRECIS = 0Private Const PROOF_QUALITY = 2Private Const DEFAULT_PITCH = 0 '文本输出时背景属性Private Const OPAQUE = 2Private Const TRANSPARENT = 1 '使用BackMode时枚举Public Enum BKMode BKM_Transparent = TRANSPARENT BKM_UnTransparent = OPAQUEEnd Enum 'DrawText的绘制属性Private Const DT_BOTTOM = &H8 '正文调整到矩形底部,必须和DT_SINGLELINE组合Private Const DT_CALCRECT = &H400 '使用后返回正文字符实际大小而不是写正文Private Const DT_CENTER = &H1 '正文在矩形中水平居中Private Const DT_CHARSTREAM = 4 '字符流Private Const DT_DISPFILE = 6 '显示器文件Private Const DT_EXPANDTABS = &H40 '扩展制表符，每个制表符的缺省字符数是8Private Const DT_EXTERNALLEADING = &H200 '在行的高度里包含字体的外部标头，通常，外部标头不被包含在正文行的高度里Private Const DT_END_ELLIPSIS& = &H8000& '大小不够时缩略号显示尾部Private Const DT_INTERNAL = &H1000 '用系统字体来计算正文度量Private Const DT_LEFT = &H0 '正文左对齐Private Const DT_METAFILE = 5 '图元文件Private Const DT_NOCLIP = &H100 '不受RECT限制,无裁剪绘制当DT_NOCLIP使用时DrawText的使用会有所加快Private Const DT_NOPREFIX = &H800 '关闭前缀字符的处理，通常DrawText解释助记前缀字符，&为给其后的字符加下划线，解释&&为显示单个&。指定DT_NOPREFIX，这种处理被关闭Private Const DT_PLOTTER = 0 '矢量绘图仪Private Const DT_RASCAMERA = 3 '光栅照相机Private Const DT_RASDISPLAY = 1 '光栅显示器Private Const DT_RASPRINTER = 2 '光栅打印机Private Const DT_RIGHT = &H2 '正文右对齐Private Const DT_SINGLELINE = &H20 '显示正文的同一行，回车和换行符都不能折行Private Const DT_TABSTOP = &H80 '设置制表，参数uFormat的15~C8位（低位字中的高位字节）指定每个制表符的字符数，每个制表符的缺省字符数是8。Private Const DT_TOP = &H0 '正文顶端对齐（仅对单行）Private Const DT_VCENTER = &H4 '正文水平居中（仅对单行）Private Const DT_WORDBREAK = &H10 '自动回车,当一行中的字符将会延伸到由lpRect指定的矩形的边框时，此行自动换行。一个回车一换行也能使行折断 '使用DrawText时枚举Public Enum DrawTextMode DTM_Top = DT_TOP Or DT_SINGLELINE DTM_Bottom = DT_BOTTOM Or DT_SINGLELINE DTM_left = DT_LEFT DTM_Right = DT_RIGHT  DTM_Center = DT_CENTER DTM_vCenter = DT_VCENTER Or DT_SINGLELINE  DTM_NoPreFix = DT_NOPREFIX DTM_WordBreak = DT_WORDBREAKEnd Enum  '位图结构Private Type bitmap bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As LongEnd Type'对象设置Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As LongPrivate Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As LongPrivate Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As LongPrivate Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long '创建字体Private Declare Function ApiCreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPrivate Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As LongPrivate Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long  '创建DCPrivate Declare Function ApiCreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hDC As Long) As LongPrivate Declare Function ApiCreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function ApiCreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As LongPrivate Declare Function ApiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPrivate Declare Function ApiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hDC As Long) As LongPrivate Declare Function ApiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As LongPrivate Declare Function ApiSelectObject Lib "gdi32" Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long '复制Private Declare Function ApiBitBlt Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, Optional ByVal dwRop As Long = vbSrcCopy) As LongPrivate Declare Function ApiStretchBlt Lib "gdi32" Alias "StretchBlt" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, Optional ByVal dwRop As Long = vbSrcCopy) As Long '绘图Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPrivate Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function FrameRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function ApiDrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As LongPrivate Declare Function InvertRect Lib "user32.dll" (ByVal hDC As Long, ByRef lpRect As Any) As Long'载入图像Private Const LR_LOADFROMFILE = &H10Private Const IMAGE_BITMAP = 0Private Const IMAGE_ICON = 1Private Const IMAGE_CURSOR = 2Private Const IMAGE_ENHMETAFILE = 3Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long '保持属性值的局部变量Private hBitmap As Long '创建DC必须Private hBitTemp As Long '创建DC必须Private mDC_DCC As Long '创建DC必须Private hMemDC As Long '设备场景句柄Private mvarDC_nWidth As Long '设备场景宽度Private mvarDC_nHeight As Long '设备场景高度 Private mvarBackMode As Long '背景模式:透明/不透明Private mvarBackColor As Long '背景色,每次设置时用背景色填充设备场景Private mvarTextColor As Long '文本颜色 Private mvarOldFont As Long '原字体句柄Private mvarNewFont As Long '新字体句柄 Private FontSize As Integer '字号Private FontName As String '字体Private FontHeavy As Boolean '粗体Private FontItalic As Boolean '斜体Private FontUnderline As Boolean '下划线Private FontStrikethrough As Boolean '删除线 ' ******************** 对象初始化及清除开始 ********************' ** 对象初始化 **Private Sub Class_Initialize() mvarDC_nWidth = 1 mvarDC_nHeight = 1End Sub' ** 对象清除 **Private Sub Class_Terminate() ApiSelectObject Me.hDC, mvarOldFont ApiDeleteObject mvarNewFont Call DeleteDCEnd Sub' ******************** 对象初始化及清除结束 ********************' ******************** 设置属性开始 ********************' ** 设备句柄 **Public Property Let hDC(ByVal vData As Long) Err.Clear Err.Description = "设备场景句柄只读!"End PropertyPublic Property Get hDC() As Long If hMemDC <> 0 Then hDC = hMemDC Else hDC = 0 Err.Clear Err.Description = "未初始化设备场景,请先使用CreateDC初始化!" End IfEnd Property' ** 设置背景色 **Public Property Let BackColor(ByVal vData As Long) If mvarBackColor = vData Then Exit Property mvarBackColor = vData  Dim Rt As Boolean Dim Rct As RECT Dim hBr As Long  '使用画刷填充背景色 SetRect Rct, 0, 0, mvarDC_nWidth, mvarDC_nHeight hBr = CreateSolidBrush(mvarBackColor) Rt = FillRect(Me.hDC, Rct, hBr) ApiDeleteObject hBr  '设置背景色,绘制文本时以若以OPAQUE模式绘制,则系统将先用背景色填充文本背景 SetBkColor Me.hDC, mvarBackColor  If Not Rt Then Err.Clear: Err.Description = "设置背景色失败!"End Property' ** 返回背景色 **Public Property Get BackColor() As Long BackColor = mvarBackColorEnd Property' ** 设置背景模式 **Public Sub BackMode(ByVal vData As BKMode) mvarBackMode = vData SetBkMode Me.hDC, vDataEnd Sub' ** 设置文本颜色 **Public Property Let TextColor(ByVal vData As Long) mvarTextColor = vData SetTextColor Me.hDC, mvarTextColorEnd PropertyPublic Property Get TextColor() As Long TextColor = mvarTextColorEnd Property' ** 字体 **Public Function Font(ByVal nSize As Integer, _ Optional FontNameA As String = "宋体", _ Optional FontHeavyA As Boolean = False, _ Optional FontItalicA As Boolean = False, _ Optional FontUnderlineA As Boolean = False, _ Optional Strikethrough As Boolean = False) As Long  FontSize = nSize FontName = FontNameA FontHeavy = FontHeavyA FontItalic = FontItalicA FontUnderline = FontUnderlineA FontStrikethrough = Strikethrough  '如果原先改过,先恢复字体 If mvarNewFont <> 0 Then ApiSelectObject Me.hDC, mvarOldFont ApiDeleteObject mvarNewFont End If  mvarNewFont = ApiCreateFont(-MulDiv(FontSize, GetDeviceCaps(Me.hDC, LOGPIXELSY), 72), 0, 0, 0, IIf(FontHeavy, FW_HEAVY, FW_NORMAL), FontItalic, FontUnderline, FontStrikethrough, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, FontName) mvarOldFont = ApiSelectObject(Me.hDC, mvarNewFont) End Function' ** 设备宽度 **Private Property Let Width(ByVal vData As Long) If vData > 0 Then mvarDC_nWidth = vData Else Err.Clear Err.Description = "无法设置无效值!" End IfEnd PropertyPublic Property Get Width() As Long Width = mvarDC_nWidthEnd Property' ** 设备高度 **Private Property Let Height(ByVal vData As Long) If vData > 0 Then mvarDC_nHeight = vData Else Err.Clear Err.Description = "无法设置无效值!" End IfEnd PropertyPublic Property Get Height() As Long Height = mvarDC_nHeightEnd Property' ******************** 设置属性结束 ********************' ******************** 过程及函数空开始 ********************'初始化设备场景Public Function CreateDC(ByVal nWidth As Long, ByVal nHeight As Long) As Boolean Dim Rt As Long CreateDC = False  If hMemDC <> 0 Then '清除内存 Rt = DeleteDC If Not Rt Then Debug.Print Err.Description: Exit Function End If  '先保存DC尺寸 Width = nWidth Height = nHeight  '创建变量 mDC_DCC = ApiCreateDC("DisPlay", vbNullString, vbNullString, ByVal 0&) hMemDC = ApiCreateCompatibleDC(mDC_DCC) hBitmap = ApiCreateCompatibleBitmap(mDC_DCC, mvarDC_nWidth, mvarDC_nHeight) hBitTemp = ApiSelectObject(hMemDC, hBitmap) If hMemDC = 0 Or mDC_DCC = 0 Or hBitmap = 0 Then Err.Clear: Err.Description = "创建设备场景失败!": Exit Function  '默认字体,字号 Font 9, "宋体"  CreateDC = True End Function' ** 清除变量 **Private Function DeleteDC() As Boolean Dim Rt As Boolean DeleteDC = False  Rt = ApiDeleteDC(hMemDC) If Not Rt Then Err.Clear: Err.Description = "清除设备场景失败!": Exit Function  Rt = ApiDeleteDC(mDC_DCC) If Not Rt Then Err.Clear: Err.Description = "清除设备场景失败!": Exit Function  Rt = ApiDeleteObject(hBitmap) If Not Rt Then Err.Clear: Err.Description = "清除设备场景失败!": Exit Function DeleteDC = TrueEnd Function' ** 缩放模式取得图像 **Public Function GetPicture_Stretch(ByVal SrcDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal To_x As Long, ByVal To_y As Long, ByVal nWidth_2 As Long, ByVal nHeight_2 As Long) As Boolean GetPicture_Stretch = CBool(ApiStretchBlt(hMemDC, To_x, To_y, nWidth_2, nHeight_2, SrcDC, x, y, nWidth, nHeight)) If Not GetPicture_Stretch Then Err.Clear: Err.Description = "缩放图像至设备场景失败!"End Function' ** 原尺寸取得图像 **Public Function GetPicture(ByVal SrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal To_x As Long, ByVal To_y As Long) As Boolean GetPicture = ApiBitBlt(hMemDC, To_x, To_y, nWidth, nHeight, SrcDC, xSrc, ySrc) If Not GetPicture Then Err.Clear: Err.Description = "复制图像至设备场景失败!"End Function' ** 缩放模式输出图像 **Public Function StretchBlt(ByVal ToDC As Long, ByVal To_x As Long, ByVal To_y As Long, ByVal ToWidth As Long, ByVal ToHeight As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, Optional ByVal dwRop As Long = vbSrcCopy) As Boolean StretchBlt = ApiStretchBlt(ToDC, To_x, To_y, ToWidth, ToHeight, hMemDC, xSrc, ySrc, nWidthSrc, nHeightSrc, dwRop) If Not StretchBlt Then Err.Clear: Err.Description = "缩放图像至目标场景失败!"End Function' ** 原尺寸输出图像 **Public Function BitBlt(ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, Optional ByVal xSre As Long, Optional ByVal ySre As Long, Optional ByVal dwRop As Long = vbSrcCopy) As Boolean BitBlt = CBool(ApiBitBlt(hDestDC, x, y, nWidth, nHeight, hMemDC, xSre, ySre, dwRop)) If Not BitBlt Then Err.Clear: Err.Description = "复制图像至目标场景失败!"End Function'绘制文本Public Sub DrawText(ByVal hDestDC As Long, ByVal lpStr As String, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal wFormat As DrawTextMode) Dim Rct As RECT SetRect Rct, X1, Y1, X2, Y2 ApiDrawText hDestDC, lpStr, -1, Rct, wFormat Or DT_END_ELLIPSISEnd Sub' ** 更改设备场景尺寸 **Public Function ChangeSize(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Boolean Dim NewWidth As Long Dim NewHeight As Long  Dim Temp_Bmp As Long Dim Temp_DCC As Long Dim Temp_DC As Long  Dim Rct As RECT Dim hBr As Long  Dim x As Long Dim y As Long  Dim Rt As Boolean  If hMemDC = 0 Then Err.Clear: Err.Description = "场景未初始化!"  '新宽度 NewWidth = X2 - X1 NewHeight = Y2 - Y1  '更新尺寸 If NewWidth > 0 Then mvarDC_nWidth = NewWidth Else Err.Clear Err.Description = "无法设置无效值!" Exit Function End If  If NewHeight > 0 Then mvarDC_nHeight = NewHeight Else Err.Clear Err.Description = "无法设置无效值!" Exit Function End If  '创建变量 Temp_DC = ApiCreateCompatibleDC(0) Temp_DCC = ApiCreateDC("DisPlay", vbNullString, vbNullString, ByVal 0&) Temp_Bmp = ApiCreateCompatibleBitmap(Temp_DCC, mvarDC_nWidth, mvarDC_nHeight) Call ApiSelectObject(Temp_DC, Temp_Bmp) If Temp_DC = 0 Or Temp_DCC = 0 Or Temp_Bmp = 0 Then Err.Clear: Err.Description = "更改设备场景尺寸失败!": Exit Function  If X1 < 0 Then x = Abs(X1): X1 = 0 Else x = 0 If Y1 < 0 Then y = Abs(Y1): Y1 = 0 Else y = 0  '填充背景色 SetRect Rct, 0, 0, mvarDC_nWidth, mvarDC_nHeight hBr = CreateSolidBrush(mvarBackColor) Rt = FillRect(Temp_DC, Rct, hBr) ApiDeleteObject hBr  '复制原图至新区 Me.BitBlt Temp_DC, x, y, NewWidth, NewHeight, Abs(X1), Abs(Y1)  '清除内存 Call DeleteDC  '新区赋值给原值 hBitmap = Temp_Bmp mDC_DCC = Temp_DCC hMemDC = Temp_DC  Me.TextColor = mvarTextColor Call BackMode(mvarBackMode) Font FontSize, FontName, FontHeavy, FontItalic, FontUnderline, FontStrikethroughEnd Function' ** 返回图片长宽 **Public Sub GetPictureFileSize(ByVal sFileNameA As String, ByRef nWidth As Long, ByRef nHeight As Long) Dim Rt As Boolean Dim bmp As bitmap Rt = ApiGetObject(LoadPicture(sFileNameA).Handle, Len(bmp), bmp) '取得BITMAP的结构 nWidth = bmp.bmWidth nHeight = bmp.bmHeight '释放内存' Call ApiDeleteObject(hBitmap)End SubPrivate Function LoadImageFromFile(ByVal FileNameA) As Long If Len(Dir(FileNameA)) = 0 Then Err.Clear: Err.Description = "载入失败:文件不存在!": Exit Function Dim hBitmap As Long Dim W As Long Dim H As Long Me.GetPictureFileSize FileNameA, W, H '载入文件 hBitmap = LoadImage(App.hInstance, FileNameA, IMAGE_BITMAP, W, H, LR_LOADFROMFILE) If hBitmap = 0 Then Err.Clear Err.Description = "载入图片失败!" Exit Function End If  LoadImageFromFile = hBitmap  '释放内存 'Call ApiDeleteObject(hBitmap)End FunctionPublic Function LoadPictureFormFile(ByVal aFileName, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal nWidth As Long = 0, Optional ByVal nHeight As Long = 0, Optional ByVal To_x As Long = 0, Optional ByVal To_y As Long = 0) As Boolean Dim Bi As bitmap Dim Rt As Boolean Dim Temp_DC As Long Dim hBitmap As Long Dim InPutWid As Long Dim InPutHei As Long  '图片载入内存 hBitmap = LoadImageFromFile(aFileName) '获取图片信息 ApiGetObject hBitmap, Len(Bi), Bi '创建临时DC Temp_DC = ApiCreateCompatibleDC(0) '将内存图片与DC关联 Call ApiSelectObject(Temp_DC, hBitmap)  '获取图片尺寸 InPutWid = Bi.bmWidth InPutHei = Bi.bmHeight If nWidth = 0 Then nWidth = InPutWid If nHeight = 0 Then nHeight = InPutHei  '将内存图片按参数输出到设备上 Rt = CBool(Me.GetPicture_Stretch(Temp_DC, x, y, InPutWid, InPutHei, To_x, To_y, nWidth, nHeight)) If Not Rt Then Err.Clear: Err.Description = "从文件获取图像失败,原因:复制图像失败!"  '释放内存 Call ApiDeleteObject(hBitmap) Call ApiDeleteDC(Temp_DC)End FunctionPublic Function SaveFileFromDC(ByVal FileName As String, _ Optional ByVal FileFormat As ImageFileFormat = jpg, _ Optional ByVal JpgQuality As Long = 80, _ Optional Resolution As Single) SaveFileFromDC = SavehBitmapToFile(hBitmap, FileName, FileFormat, JpgQuality, Resolution)End Function

2、laviewpbt的存储图片

进行了微调，提高从BSTR指针获取字符串的效率

'*************************************************************************'** 作 者 ： laviewpbt'** 函 数 名 ： SavehBitmapToFile'** 输 入 ： Stdpic(StdPicture) - 图象句柄'** ： FileName(String) - 保存路径'** ： FileFormat(ImageFileFormat) - 保存格式，默认jpg'** ： JpgQuality(Long) - JPG图象质量'** ： Resolution(Single) - 设置分辨率'** 输 出 ： 无'** 功能描述 ： 把图象保存为JPG、PNG、GIF、BMP格式'** 修 改 人 ： laviewpbt'** 日 期 ： 2012-03-02 22:56'** 版 本 ： 终结版'*************************************************************************Option ExplicitPrivate Const UnitPixel As Long = 2Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"Private Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As LongEnd TypePrivate Enum EncoderParameterValueType EncoderParameterValueTypeByte = 1 EncoderParameterValueTypeASCII = 2 EncoderParameterValueTypeShort = 3 EncoderParameterValueTypeLong = 4 EncoderParameterValueTypeRational = 5 EncoderParameterValueTypeLongRange = 6 EncoderParameterValueTypeUndefined = 7 EncoderParameterValueTypeRationalRange = 8End EnumPrivate Type EncoderParameter GUID(0 To 3) As Long NumberOfValues As Long type As EncoderParameterValueType Value As LongEnd TypePrivate Type EncoderParameters count As Long Parameter As EncoderParameterEnd TypePrivate Type ImageCodecInfo ClassID(0 To 3) As Long FormatID(0 To 3) As Long CodecName As Long DllName As Long FormatDescription As Long FilenameExtension As Long MimeType As Long Flags As Long Version As Long SigCount As Long SigSize As Long SigPattern As Long SigMask As LongEnd TypePrivate Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As LongPrivate Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As LongPrivate Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As LongPrivate Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, bitmap As Long) As GpStatusPrivate Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As LongPrivate Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As LongPrivate Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pclsid As Any) As LongPrivate Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As LongPrivate Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)Private Declare Function SysAllocString Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long) As LongPublic Enum GpStatus Ok = 0 GenericError = 1 InvalidParameter = 2 OutOfMemory = 3 ObjectBusy = 4 InsufficientBuffer = 5 NotImplemented = 6 Win32Error = 7 WrongState = 8 Aborted = 9 FileNotFound = 10 ValueOverflow = 11 AccessDenied = 12 UnknownImageFormat = 13 FontFamilyNotFound = 14 FontStyleNotFound = 15 NotTrueTypeFont = 16 UnsupportedGdiplusVersion = 17 GdiplusNotInitialized = 18 PropertyNotFound = 19 PropertyNotSupported = 20 ProfileNotFound = 21End EnumPublic Enum ImageFileFormat bmp = 1 jpg = 2 png = 3 gif = 4End EnumPublic Function SavehBitmapToFile(hBitmap As Long, ByVal FileName As String, _ Optional ByVal FileFormat As ImageFileFormat = jpg, _ Optional ByVal JpgQuality As Long = 80, _ Optional Resolution As Single) As Boolean Dim CLSID(3) As Long Dim bitmap As Long Dim token As Long Dim Gsp As GdiplusStartupInput Gsp.GdiplusVersion = 1 'GDI+ 1.0版本 GdiplusStartup token, Gsp '初始化GDI+ Debug.Print GdipCreateBitmapFromHBITMAP(hBitmap, 0, bitmap) If bitmap <> 0 Then '如果成功的将hBitmap句柄代表的stdPic对象转换为GDI+的Bitmap对象了 GdipBitmapSetResolution bitmap, Resolution, Resolution Select Case FileFormat Case ImageFileFormat.bmp If Not GetEncoderCLSID("Image/bmp", CLSID) = -1 Then SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) End If Case ImageFileFormat.jpg 'JPG格式可以设置保存的质量 Dim aEncParams() As Byte Dim uEncParams As EncoderParameters If GetEncoderCLSID("Image/jpeg", CLSID) <> -1 Then uEncParams.count = 1 ' 设置自定义的编码参数，这里为1个参数 If JpgQuality < 0 Then JpgQuality = 0 ElseIf JpgQuality > 100 Then JpgQuality = 100 End If ReDim aEncParams(1 To Len(uEncParams)) With uEncParams.Parameter .NumberOfValues = 1 .type = EncoderParameterValueTypeLong ' 设置参数值的数据类型为长整型 Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0)) ' 设置参数唯一标志的GUID，这里为编码品质 .Value = VarPtr(JpgQuality) ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比 End With CopyMemory aEncParams(1), uEncParams, Len(uEncParams) SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0) End If Case ImageFileFormat.png If Not GetEncoderCLSID("Image/png", CLSID) = -1 Then SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) End If Case ImageFileFormat.gif If Not GetEncoderCLSID("Image/gif", CLSID) = -1 Then '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败 SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0) End If End Select End If GdipDisposeImage bitmap '注意释放资源 GdiplusShutdown token '关闭GDI+。End FunctionPrivate Function GetEncoderCLSID(strMimeType As String, ClassID() As Long) As Long Dim num As Long Dim Size As Long Dim i As Long Dim Info() As ImageCodecInfo Dim Buffer() As Byte GetEncoderCLSID = -1 GdipGetImageEncodersSize num, Size '得到解码器数组的大小 If Size <> 0 Then ReDim Info(1 To num) As ImageCodecInfo '给数组动态分配内存 ReDim Buffer(1 To Size) As Byte GdipGetImageEncoders num, Size, Buffer(1) '得到数组和字符数据 CopyMemory Info(1), Buffer(1), (Len(Info(1)) * num) '复制类头 For i = 1 To num '循环检测所有解码 If (StrComp(GetStrFromPtrW(Info(i).MimeType), strMimeType, vbTextCompare) = 0) Then '必须把指针转换成可用的字符 CopyMemory ClassID(0), Info(i).ClassID(0), 16 '保存类的ID GetEncoderCLSID = i '返回成功的索引值 Exit For End If Next End IfEnd FunctionPublic Function GetStrFromPtrW(ByVal Ptr As Long) As String PutMem4 VarPtr(GetStrFromPtrW), SysAllocString(Ptr)End Function

调用的代码如下：

Option ExplicitPrivate Declare Function ApiDrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long'结构矩形Public Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypeSub Main() '主函数 Dim W&, H&, Rt&, strText$ Dim cDC As Class_DC Set cDC = New Class_DC Dim Rct As RECT With Clipboard If .GetFormat(1) = True Then strText = .GetText End With  If strText = "" Then MsgBox "剪贴板没有文字！" Exit Sub End If  W = 5: H = 5 '动态 Rt = cDC.CreateDC(W, H) '动态创建 cDC.Font 18, , True '设置字体 ApiDrawText cDC.hDC, strText, -1, Rct, &H400 '试画 '重画 Set cDC = Nothing Set cDC = New Class_DC Rt = cDC.CreateDC(Rct.Right - Rct.Left + 40, Rct.Bottom - Rct.Top + 10) cDC.BackColor = vbWhite '设置背景色,并填充设备场景 cDC.BackMode BKM_Transparent '文本背景设置为透明 cDC.TextColor = vbBlack '设置文本颜色 cDC.Font 18, , True '设置字体  cDC.DrawText cDC.hDC, strText, 10, 10, cDC.Width, cDC.Height, DTM_left Or DTM_NoPreFix Or DTM_WordBreak MsgBox cDC.SaveFileFromDC(App.Path & "\1.png", png)End Sub