word右键怎么增加图片另存为

如果我们想把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")