1. 首頁 > 生活百科 > >

word右鍵怎么增加圖片另存為 word右鍵怎么增加圖片另存為文件

知識經驗


word右鍵怎么增加圖片另存為 word右鍵怎么增加圖片另存為文件

文章插圖
如果我們想把word中的圖片保存下來 ， 苦惱word無法使用右鍵圖片另存為 ， 接下來小編就為大家介紹一下如何使用VBA代碼增加圖片另存為
word右鍵怎么增加圖片另存為 word右鍵怎么增加圖片另存為文件

文章插圖
代碼如下：
Option Explicit
Private Const UnitPixelAs Long = 2
Private Const EncoderQualityAs String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Type GdiplusStartupInput
GdiplusVersionAs Long
DebugEventCallbackAs 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
NumberOfValuesAs Long
TypeAs EncoderParameterValueType
ValueAs Long
End Type
Private Type EncoderParameters
CountAs Long
ParameterAs EncoderParameter
End Type
Private Type ImageCodecInfo
ClassID(0 To 3) As Long
FormatID(0 To 3)As Long
CodecNameAs Long
DllNameAs Long
FormatDescription As Long
FilenameExtension As Long
MimeTypeAs Long
FlagsAs Long
VersionAs Long
SigCountAs Long
SigSizeAs Long
SigPatternAs Long
SigMaskAs 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
【word右鍵怎么增加圖片另存為 word右鍵怎么增加圖片另存為文件】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 BitmapAs Long
Dim TokenAs Long
Dim GspAs 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 uEncParamsAs 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 = http://www.baikeg.com/ng/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 NumAs Long
Dim SizeAs Long
Dim IAs 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 OutAs String
Dim LengthAs 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")

    推薦閱讀