教大家word右鍵怎么增加圖片另存為

近日有關(guān)于word右鍵怎么增加圖片另存為的問題受到了很多網(wǎng)友們的關(guān)注，大多數(shù)網(wǎng)友都想要知道word右鍵怎么增加圖片另存為的具體情況，那么關(guān)于到word右鍵怎么增加圖片另存為的相關(guān)信息，小編也是在網(wǎng)上進行了一系列的信息，那么接下來就由小編來給大家分享下小編所收集到與word右鍵怎么增加圖片另存為相關(guān)的信息吧(以下內(nèi)容來自于網(wǎng)絡(luò)非小編所寫，如有侵權(quán)請與站長聯(lián)系刪除)

如果我們想把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對象轉(zhuǎn)換為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格式可以設(shè)置保存的質(zhì)量

Dim aEncParams() As Byte

Dim uEncParams As EncoderParameters

If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then

uEncParams.Count = 1 ' 設(shè)置自定義的編碼參數(shù)，這里為1個參數(shù)

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 ' 設(shè)置參數(shù)值的數(shù)據(jù)類型為長整型

Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))' 設(shè)置參數(shù)唯一標志的GUID，這里為編碼品質(zhì)

.Value = VarPtr(JpgQuality) ' 設(shè)置參數(shù)的值：品質(zhì)等級，最高為100，圖像文件大小與品質(zhì)成正比

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位，則這個函數(shù)會調(diào)用系統(tǒng)的調(diào)色板來將圖像轉(zhuǎn)換為8位，轉(zhuǎn)換的效果會不盡人意,但也有可能系統(tǒng)不自動轉(zhuǎn)換，保存失敗

SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)

End If

End Select

End If

GdipDisposeImage Bitmap '注意釋放資源

GdiplusShutdown Token '關(guān)閉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 '得到解碼器數(shù)組的大小

If Size <> 0 Then

ReDim Info(1 To Num) As ImageCodecInfo '給數(shù)組動態(tài)分配內(nèi)存

ReDim Buffer(1 To Size) As Byte

GdipGetImageEncoders Num, Size, Buffer(1) '得到數(shù)組和字符數(shù)據(jù)

CopyMemory Info(1), Buffer(1), (Len(Info(1)) * Num) '復(fù)制類頭

For I = 1 To Num '循環(huán)檢測所有解碼

If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then '必須把指針轉(zhuǎn)換成可用的字符

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")