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

猜你喜歡

  1. Word中巧妙插入圖片和表格序號

    寫長文檔的時候最害怕遇到什么?假設寫了一篇300頁的文檔,里面的各種插圖也超過100張了,在寫的時候,插圖已經被標上了“圖1”、“圖2”之類的標號。但BOSS看過后告訴你,有兩張圖之間還需要插入一張圖 ...

  2. eDiary電子日記本:增加圖片對齊功能

    eDiary電子日記本主要特點: 1.界面簡單清新,支持皮膚切換; 2.嚴格的數據加密機制,充分保護用戶隱私; 3.強大的編輯功能,編輯器體驗和 Word 一致; 4.支持日記模板功能,并預置常用模板 ...

  3. Word如何設置插入圖片

    在Word文檔中插入幾張適宜的圖片,無疑使得古板枯燥的文檔變得活潑,正所以"圖文并茂".但是有的時候,這些嵌入文檔的圖片,卻不是那么聽話,讓我們欲動不能.有什么辦法,能夠拯救這些嵌 ...

  4. Word 2007中解決圖片不能層疊的問題

    Word 2007中解決圖片不能層疊的問題 在Word2007中當不使用繪圖畫布時,在同一個位置插入的兩張以上的圖片,是不能直接將兩張圖片進行疊加或重疊的,必須執行以下操作才能實現。 選擇其中一張圖片 ...

  5. Word XP中的圖片也能隨意旋轉

    首先在工具欄上點擊右鍵,然后在彈出的快捷菜單中選擇"自定義",打開"自定義"對話框,點擊其中的"命令"選項卡(如圖1).在"類別& ...

  6. 動態圖片另存為后不動了怎么辦

    就在網上搜索一些動態的圖片,就以這個吃胡蘿卜的小白免為例來進行操作.當我們選中圖片,然后在圖片上點擊右鍵,在它的下拉列表中可以看到它有一個圖片另存為. 然后在打開的另存為的界面中,可以看到這張圖片它默 ...

  7. WORD中插入的圖片打印出來不清晰

    通過以下2個方法去調整: 1.圖片的像素過低,調高圖片的像素. 方法一.在Word中設置圖片格式 首先查看你要插入圖片的分辨率,具體查看圖片分辨率方法:選中圖像文件,點擊鼠標右鍵→屬性,在彈出的窗口中 ...

  8. word怎么給花瓶圖片添加陶瓷紋理效果?

    word插入的圖片,想要制作一些特效,該怎么添加陶瓷紋理的效果呢?主要使用藝術效果選項,現下面我們就來看看詳細的教程. 1.首先啟動word2010,執行美化大師-圖片命令,調出對話框. 2.選擇自己 ...