来源: 最后更新:23-03-11 12:19:07
如果我们想把word中的图片保存下来,苦恼word无法使用右键图片另存为,接下来小编就为大家介绍一下如何使用VBA代码增加图片另存为
代码如下:
Option Explicit
Private Const UnitPixel As Long = 2
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Enum EncoderParameterValueType
EncoderParameterValueTypeByte = 1
EncoderParameterValueTypeASCII = 2
EncoderParameterValueTypeShort = 3
EncoderParameterValueTypeLong = 4
EncoderParameterValueTypeRational = 5
EncoderParameterValueTypeLongRange = 6
EncoderParameterValueTypeUndefined = 7
EncoderParameterValueTypeRationalRange = 8
End Enum
Private Type EncoderParameter
GUID(0 To 3) As Long
NumberOfValues As Long
Type As EncoderParameterValueType
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Type ImageCodecInfo
ClassID(0 To 3) As Long
FormatID(0 To 3) As Long
CodecName As Long
DllName As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private 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 Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
Private 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 Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal Bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Public Enum ImageFileFormat
Public Function SaveStdPicToFile(Stdpic As StdPicture, 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+
GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap
If Bitmap <> 0 Then '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
GdipBitmapSetResolution Bitmap, Resolution, Resolution
Select Case FileFormat
Case ImageFileFormat.Bmp
If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then
SaveStdPicToFile = (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
Private 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(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then '必须把指针转换成可用的字符
CopyMemory ClassID(0), Info(I).ClassID(0), 16'保存类的ID
GetEncoderClsID = I '返回成功的索引值
Exit For
End If
Next
End If
End Function
Private Function PtrToStrW(ByVal lpsz As Long) As String
Dim Out As String
Dim Length As Long
Length = lstrlenW(lpsz)
If Length > 0 Then
Out = StrConv(String$(Length, vbNullChar), vbUnicode)
CopyMemory ByVal Out, ByVal lpsz, Length * 2
PtrToStrW = StrConv(Out, vbFromUnicode)
End If
End Function
For Each cbn In Array("AutoText", "Drawing Canvas", "Organization Chart", "Diagram", "Frames", "Flowchart", "Inline Picture", "Floating Picture", "Shapes", "Inline Canvas", "Table Pictures", "AutoShapes", "Basic Shapes", "Insert Shape", "Picture", "WordArt Context Menu", "WordArt")
美国众议院民主党人考虑要求拜登退出竞选
曾以“天降富二代”走红的麻辣王子工厂因汛情停工 所在园区工厂全面复工预计需一周
2024海盐消费券活动 海盐消费者协会电话是多少
海盐第六届膳博士年猪文化节暨膳博士腌腊季
桐乡免费停车的地方有哪些?(桐乡免费停车的地方有哪些好玩的)
温州瓯海区2024年春节期间烟花爆竹临时零售点
2024宁波中国银行甲辰龙年贵金属纪念币预约指南
2024宁波中行圆形金银纪念币图案+类型 宁波2021年纪念币哪里预约
2024宁波中国银行龙年梅花金银纪念币发行规格一览
2024宁波中行梅花形银纪念币多少钱 2021年30克梅花形精致银质纪念币
推荐十部国产盗墓题材电影(推荐十部国产盗墓题材电影有哪些)盗墓电影大全(推荐十部国产盗墓题材电影)1.《寻龙诀》由乌尔善执导
消息人士:若拜登退选,首选替代者可能是她 以色列游说美国调查阿迈勒·克鲁尼:她协助起诉内塔尼亚胡 推荐的6种自我缓解焦虑方法 如何自我缓解焦虑 三十而已王漫妮卖珠宝是哪一集 三十而已王漫妮卖珠宝是第几集