word右键怎么增加图片另存为
发布时间:2023-11-25 13:26:00
如果我们想把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
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 Long
End Type
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
Bmp = 1
Jpg = 2
Png = 3
Gif = 4
End Enum
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
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)
SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0)
End If
Case ImageFileFormat.Png
If Not GetEncoderClsID("Image/png", CLSID) = -1 Then
SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
End If
Case ImageFileFormat.Gif
If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then '如果原始的图像是24位,则这个函数会调用系统的调色板来将图像转换为8位,转换的效果会不尽人意,但也有可能系统不自动转换,保存失败
SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
End If
End Select
End If
GdipDisposeImage Bitmap '注意释放资源
GdiplusShutdown Token '关闭GDI+。
End Function
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")
猜你喜欢
- 现在已经有很多人都开始使用Win10系统,Win10系统也经常进行更新,有些用户更新了去年推出的Win10 20H2版本后不知道该如何查看电
- office365怎么卸载干净?当我们长时间不使用软件时,为了避免软件占用大量的内存空间,有用户就会直接将其卸载,但是难免会出现卸载不干净的
- win10作为目前还是推送更新的系统,版本很多,但是功能各有不同,有偏向企业办公的,有家庭自用的,目前一共有家庭版、专业版、企业版、教育版、
- 我们最常用到的office办公软件就是Word和Excel了,Word用来输入文字、Excel用来做表格。有时我们也会在Word中使用一些表
- 系统文件夹保护win10自带的一些关键文件,正常情况下需要很高的管理权限才能访问操作。如果用户想要访问却提示访问被拒绝的话,要怎么处理解决呢
- 最近有用户反映说自己电脑更新win10 20H2系统之后出现网络无法连接的情况,影响了他们的正常生活和工作,不知道怎么处理这个问题令他们很苦
- Win10电脑在使用过程当中会自动产生一些缓存,日积月累下会占用非常多的存储空间,最终将影响电脑的正常运行速度,初次使用win10电脑的用户
- Word是工作人员每天必须接触的软件,为了能够提高办公效率,今天分享3年办公人员老司机总结出的7个Word技巧,简单实用,提高工作效率。1、
- 我们在使用Win10系统的时候,电脑经常会弹出一些无用的任务消息显示,每次都需要自己手动关闭,让人很烦。那么我们要怎么关闭呢?下面小编就带着
- 很多时候电脑系统使用久了就会出现卡顿、死机等问题,这个时候我们会自己重新装系统,但是最近有用户反映重新安装系统后,每次打开计算机时,都会有两
- Win10X电脑操作系统需要安装杀毒软件吗?Win10X系统最近在网络上可以说非常受大众喜爱,而许多用户在使用电脑的时候经常会安装一些奇奇怪
- SharePoint Designer2007怎么改变热点图热区颜色?网页的热点图想要在鼠标经过的时候改变热区颜色,该怎么实现呢?下面我们就
- 一千个win10用户就有一千种使用爱好,有的就不喜欢设置登陆密码,觉得太繁琐。要是忘记密码就更麻烦,他们觉得开机直接进去系统界面不是很香吗,
- ABBYY FineReader怎么将gd格式转换为word文件?gd格式的文件想要转换为word文件,该怎么转换格式呢?下面我们就来看看详
- 靠高考练就的题海战术和突击能力,一次就把计算机二级给过了。但到了毕业写论文,工作写方案、做策划的时候,才发现,好多小细节根本没弄明白!为了解
- 苹果 于 8 月 17 日给大家发布了iOS 15.6.1正式版,修复了整体错误 Bug 并改进了性能。苹果还通过更新修复了两个主要的安全漏
- 在安装了win10操作系统后,我们的电脑上的一些小伙伴可能在某些情况下需要打开我们系统的本地组策略编辑器进行相关操作。所以对于这个问题小编觉
- 别看记事本在输入文字的时候貌似简单,其实有些用户还不大懂怎么在记事本里换行以及去设置换行。这个换行没设置好的话,文字会一直延长下去,显得很不
- 有些用户从win7系统升级到win10系统后,觉得很多方面用起来都不习惯,想要降级回win7系统,要怎么操作呢?针对这一问题,小编带来了两个
- PDF文档怎么将背景色设置成护眼色?经常需要制作讲解pdf课件,长时间对着白色感觉眼睛很干涩疼痛,香江pdf设置成保护眼睛的背景色,该怎么设