为Word右键增加“图片另存为选项”

zhanglei1371

近日看了怎么用ＶＢＡ把ＷＯＲＤ里的所有图片另存成文件？？的帖子，心有所悟，于是便花了些时间来做了这个很久前就像实现的目标，近日终于做成功了，其实主要的代码还是来自于网络，我的工作就是将他们整合在了一起，并添加入右键，实现一键保存图片的目的。
本代码可达到：
1.保存浮动式图形；
2.保存嵌入式图形；
3.保存文本框
4.保存艺术字
如下：

代码及测试文档见2楼。

zhanglei1371

'Thisdocument中：
Private Sub Document_Open()
    Dim cbn
    For Each cbn In Array("Inline Picture", "Floating Picture", "Shapes", "WordArt Context Menu")
        CommandBars(cbn).Reset
        With CommandBars(cbn).Controls.Add(msoControlButton, Before:=4)
            .Caption = "图片另存为"
            .FaceId = 307
            .OnAction = "图片另存为"
            .Style = msoButtonIconAndCaption
        End With
    Next
End Sub

'标准模块中：
Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public iClipBoardFormatNumber As Long
Enum picFormat
    pic_GIFformat = 1
    pic_jpgformat = 2
    pic_pngformat = 3
End Enum

Sub savePic(shp As Shape, picFormat As picFormat, sFileName As String)
'这个过程把工作表中的shape对象另存为图像文件，需要指定要导出的shape对象 - shp
'导出文件格式 - picFormat（有1,2,3三种选择，分别代表gif，jpg和png格式），目标文件名 - sFileName

    Set fs = Nothing
    Dim nClipsize As Long
    Dim hMem As Long
    Dim lpData As Long
    Dim sdata() As Byte
    shp.Select
    Selection.Copy
   
    OpenClipboard 0&
    If iClipBoardFormatNumber = 0 Then
        For i = 40000 To 60000
            If IsClipboardFormatAvailable(i) And IsClipboardFormatAvailable(i + 1) And IsClipboardFormatAvailable(i + 2) And IsClipboardFormatAvailable(i + 3) Then
                iClipBoardFormatNumber = i
                Exit For
            End If
        Next
    End If
On Error GoTo myError:
    hMem = GetClipboardData(iClipBoardFormatNumber + picFormat)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            ReDim sdata(0 To nClipsize) As Byte
            CopyMemory sdata(0), ByVal lpData, nClipsize
            Set fs = CreateObject("Scripting.FileSystemObject")
            If fs.fileExists(sFileName) Then
                Kill sFileName
            End If

            Open sFileName For Binary As #1
                Put #1, , sdata
            Close #1
        End If
        GlobalUnlock hMem
    Else
        GoTo myError
    End If

    EmptyClipboard
    CloseClipboard
    Exit Sub
myError:
    GlobalUnlock hMem
    EmptyClipboard
    CloseClipboard
    MsgBox "export failed!"
End Sub
Function 文件另存()
Dim i As Integer
Dim kuang As OPENFILENAME
Dim filename As String
kuang.lStructSize = Len(kuang)
kuang.hwndOwner = 0& 'ThisDocument.hwnd
kuang.hInstance = 0& 'App.hInstance
kuang.lpstrFile = Space(254)
kuang.nMaxFile = 255
kuang.lpstrFileTitle = Space(254)
kuang.nMaxFileTitle = 255
'kuang.lpstrInitialDir = App.Path
kuang.flags = 6148
'过虑对话框文件类型
kuang.lpstrFilter = "图像1(*.jpg)" & Chr$(0) & "*.jpg" & Chr$(0) & "图像2(*.bmp)" & Chr$(0) & "*.bmp" & Chr$(0) & "图像3(*.gif)" & Chr$(0) & "*.gif" & Chr$(0) & "所有文件(*.*)" & Chr$(0) & "*.*" & Chr$(0)
'对话框标题栏文字
kuang.lpstrTitle = "保存文件的路径及文件名..."
kuang.lpstrDefExt = kuang.lpstrFilter
kuang.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT
i = GetSaveFileName(kuang) '显示保存文件对话框
If i >= 1 Then '取得对话中用户选择输入的文件名及路径
filename = kuang.lpstrFile
filename = Left(filename, InStr(filename, Chr(0)) - 1)
End If
If Len(filename) = 0 Then Exit Function
'保存代码
文件另存 = filename
End Function
Sub 图片另存为()
    Dim fn As String, pic As Long
    CloseClipboard
    fn = 文件另存
    If fn = "" Then Exit Sub
    If Split(fn, ".")(UBound(Split(fn, "."))) = "gif" Then
        pic = pic_jpgformat
    ElseIf Split(fn, ".")(UBound(Split(fn, "."))) = "jpg" Then
        pic = pic_jpgformat
    ElseIf Split(fn, ".")(UBound(Split(fn, "."))) = "png" Then
        pic = pic_pngformat
    End If
    If Selection.Type = wdSelectionInlineShape Then
        With Selection.InlineShapes(1).ConvertToShape
            .Select
            savePic Selection.ShapeRange(1), pic, fn
            .ConvertToInlineShape
        End With
    Else
        savePic Selection.ShapeRange(1), pic, fn
    End If
End Sub
test.rar (100.64 KB, 下载次数: 270)

2013-8-19 23:04 上传

点击文件名下载附件

dajiahaoxinku12

感谢楼主分享，学习了      

回忆那时

zhanglei1371 发表于 2013-8-19 23:04
'Thisdocument中：
Private Sub Document_Open()
    Dim cbn

怎么用，复制文本到哪，怎么添加

雨泥鳅

怎么调整图片的大小和文字对应

loquat

代码占用了剪贴板啊。
可否使用GDI+做到呢？

zhanglei1371

loquat 发表于 2014-12-26 17:31
代码占用了剪贴板啊。
可否使用GDI+做到呢？

我的水平你有不是不知道。菜鸟的本质一个。连GDI+的边缘都没到呢.....

loquat

zhanglei1371 发表于 2014-12-26 21:02
我的水平你有不是不知道。菜鸟的本质一个。连GDI+的边缘都没到呢.....

Sub 图片导出0()
    Set imagestream = CreateObject("ADODB.Stream")
    With imagestream
        .Type = 1
        .Open
        .Write ActiveDocument.InlineShapes(1).Range.EnhMetaFileBits
        .SaveToFile "C:\图片导出0.jpg", 2
        .Close
    End With
    Set imagestream = Nothing
End Sub

loquat

这两部分内容加到一起应该就可以释放剪贴板了。擦版主把我的帖子删掉了，是因为有外链？

1. 
   
2. '*************************************************************************
   
3. '**    作    者 ：    laviewpbt
   
4. '**    函 数 名 ：    SaveStdPicToFile
   
5. '**    输    入 ：    Stdpic(StdPicture)        -   图象句柄
   
6. '**             ：    FileName(String)       -   保存路径
   
7. '**             ：    FileFormat(ImageFileFormat)       -   保存格式，默认jpg
   
8. '**             ：    JpgQuality(Long)          -   JPG图象质量
   
9. '**             ：    Resolution(Single)  -   设置分辨率
   
10. '**    输    出 ：    无
    
11. '**    功能描述 ：    把图象保存为JPG、PNG、GIF、BMP格式
    
12. '**    修 改 人 ：   laviewpbt
    
13. '**    日    期 ：    2012-03-02 22:56
    
14. '**    版    本 ：    终结版
    
15. '*************************************************************************
    
16. Option Explicit
    
17. 
    
18. Private Const UnitPixel                  As Long = 2
    
19. Private Const EncoderQuality             As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
    
20. 
    
21. Private Type GdiplusStartupInput
    
22.     GdiplusVersion           As Long
    
23.     DebugEventCallback       As Long
    
24.     SuppressBackgroundThread As Long
    
25.     SuppressExternalCodecs   As Long
    
26. End Type
    
27. 
    
28. Private Enum EncoderParameterValueType
    
29.     EncoderParameterValueTypeByte = 1
    
30.     EncoderParameterValueTypeASCII = 2
    
31.     EncoderParameterValueTypeShort = 3
    
32.     EncoderParameterValueTypeLong = 4
    
33.     EncoderParameterValueTypeRational = 5
    
34.     EncoderParameterValueTypeLongRange = 6
    
35.     EncoderParameterValueTypeUndefined = 7
    
36.     EncoderParameterValueTypeRationalRange = 8
    
37. End Enum
    
38. 
    
39. Private Type EncoderParameter
    
40.     GUID(0 To 3)        As Long
    
41.     NumberOfValues      As Long
    
42.     Type                As EncoderParameterValueType
    
43.     Value               As Long
    
44. End Type
    
45. 
    
46. Private Type EncoderParameters
    
47.     Count               As Long
    
48.     Parameter           As EncoderParameter
    
49. End Type
    
50. 
    
51. Private Type ImageCodecInfo
    
52.     ClassID(0 To 3)     As Long
    
53.     FormatID(0 To 3)    As Long
    
54.     CodecName           As Long
    
55.     DllName             As Long
    
56.     FormatDescription   As Long
    
57.     FilenameExtension   As Long
    
58.     MimeType            As Long
    
59.     Flags               As Long
    
60.     Version             As Long
    
61.     SigCount            As Long
    
62.     SigSize             As Long
    
63.     SigPattern          As Long
    
64.     SigMask             As Long
    
65. End Type
    
66. 
    
67. Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    
68. Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
    
69. Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long
    
70. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
    
71. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
    
72. Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
    
73. Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
    
74. 
    
75. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
76. Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
    
77. Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
    
78. Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal Bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
    
79. 
    
80. 
    
81. Public Enum ImageFileFormat
    
82.     Bmp = 1
    
83.     Jpg = 2
    
84.     Png = 3
    
85.     Gif = 4
    
86. End Enum
    
87. 
    
88. Public Function SaveStdPicToFile(Stdpic As StdPicture, ByVal FileName As String, _
    
89.                               Optional ByVal FileFormat As ImageFileFormat = Jpg, _
    
90.                               Optional ByVal JpgQuality As Long = 80, _
    
91.                               Optional Resolution As Single) As Boolean
    
92.                               
    
93.     Dim CLSID(3)        As Long
    
94.     Dim Bitmap          As Long
    
95.     Dim Token           As Long
    
96.     Dim Gsp             As GdiplusStartupInput
    
97. 
    
98.     Gsp.GdiplusVersion = 1                      'GDI+ 1.0版本
    
99.     GdiplusStartup Token, Gsp                   '初始化GDI+
    
100.     GdipCreateBitmapFromHBITMAP Stdpic.Handle, Stdpic.hPal, Bitmap
     
101.     If Bitmap <> 0 Then                          '说明我们成功的将StdPic对象转换为GDI+的Bitmap对象了
     
102.         GdipBitmapSetResolution Bitmap, Resolution, Resolution
     
103.         Select Case FileFormat
     
104.         Case ImageFileFormat.Bmp
     
105.             If Not GetEncoderClsID("Image/bmp", CLSID) = -1 Then
     
106.                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
     
107.             End If
     
108.         Case ImageFileFormat.Jpg                    'JPG格式可以设置保存的质量
     
109.             Dim aEncParams()        As Byte
     
110.             Dim uEncParams          As EncoderParameters
     
111.             If GetEncoderClsID("Image/jpeg", CLSID) <> -1 Then
     
112.                 uEncParams.Count = 1                                        ' 设置自定义的编码参数，这里为1个参数
     
113.                 If JpgQuality < 0 Then
     
114.                     JpgQuality = 0
     
115.                 ElseIf JpgQuality > 100 Then
     
116.                     JpgQuality = 100
     
117.                 End If
     
118.                 ReDim aEncParams(1 To Len(uEncParams))
     
119.                 With uEncParams.Parameter
     
120.                     .NumberOfValues = 1
     
121.                     .Type = EncoderParameterValueTypeLong                   ' 设置参数值的数据类型为长整型
     
122.                     Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID，这里为编码品质
     
123.                     .Value = VarPtr(JpgQuality)                                ' 设置参数的值：品质等级，最高为100，图像文件大小与品质成正比
     
124.                 End With
     
125.                 CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
     
126.                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0)
     
127.             End If
     
128.         Case ImageFileFormat.Png
     
129.             If Not GetEncoderClsID("Image/png", CLSID) = -1 Then
     
130.                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
     
131.             End If
     
132.         Case ImageFileFormat.Gif
     
133.             If Not GetEncoderClsID("Image/gif", CLSID) = -1 Then                '如果原始的图像是24位，则这个函数会调用系统的调色板来将图像转换为8位，转换的效果会不尽人意,但也有可能系统不自动转换，保存失败
     
134.                 SaveStdPicToFile = (GdipSaveImageToFile(Bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)
     
135.             End If
     
136.         End Select
     
137.     End If
     
138.     GdipDisposeImage Bitmap      '注意释放资源
     
139.     GdiplusShutdown Token       '关闭GDI+。
     
140. End Function
     
141. 
     
142. 
     
143. Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long
     
144.     Dim Num         As Long
     
145.     Dim Size        As Long
     
146.     Dim I           As Long
     
147.     Dim Info()      As ImageCodecInfo
     
148.     Dim Buffer()    As Byte
     
149.     GetEncoderClsID = -1
     
150.     GdipGetImageEncodersSize Num, Size               '得到解码器数组的大小
     
151.     If Size <> 0 Then
     
152.        ReDim Info(1 To Num) As ImageCodecInfo       '给数组动态分配内存
     
153.        ReDim Buffer(1 To Size) As Byte
     
154.        GdipGetImageEncoders Num, Size, Buffer(1)            '得到数组和字符数据
     
155.        CopyMemory Info(1), Buffer(1), (Len(Info(1)) * Num)     '复制类头
     
156.        For I = 1 To Num             '循环检测所有解码
     
157.            If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then         '必须把指针转换成可用的字符
     
158.                CopyMemory ClassID(0), Info(I).ClassID(0), 16  '保存类的ID
     
159.                GetEncoderClsID = I      '返回成功的索引值
     
160.                Exit For
     
161.            End If
     
162.        Next
     
163.     End If
     
164. End Function
     
165. 
     
166. Private Function PtrToStrW(ByVal lpsz As Long) As String
     
167.     Dim Out         As String
     
168.     Dim Length      As Long
     
169.     Length = lstrlenW(lpsz)
     
170.     If Length > 0 Then
     
171.         Out = StrConv(String$(Length, vbNullChar), vbUnicode)
     
172.         CopyMemory ByVal Out, ByVal lpsz, Length * 2
     
173.         PtrToStrW = StrConv(Out, vbFromUnicode)
     
174.     End If
     
175. End Function

复制代码

loquat

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

复制代码

稍作完善
原因是之前表格图片中没有右键菜单，顺便将其他内容查找添加了。
不知道是否一定有必要，但是应该很完整了。如果再有不显示右键的图片，请本帖讨论。。。