Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppresexternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token 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 GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Const CF_BITMAP = 2
Public Sub SavePictures()
Call ConvertShapeToInline
Call SavePictureByApi
End Sub
Private Sub SavePictureByApi()
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim hBitmap As Long
Dim FileName As String
Dim inSh As InlineShape, N As Long
N = 0
'Documents.Open ("C:\Brildo\Test.docx")
ReDim PicName(1 To 1) As String
For Each inSh In ActiveDocument.InlineShapes
'如果是shape，此处改为activedocument.Shapes，当然inSh的声明也要改
N = N + 1
ReDim Preserve PicName(1 To N)
PicName(N) = FirstName & Format(N, "0000") & ".jpg"
Debug.Print N
FileName = ActiveDocument.Path & "\" & PicName(N)
If Dir(FileName) <> "" Then Kill FileName
inSh.Range.CopyAsPicture
'如果为shape，CopyAsPicture方法无效，可能因为shape本身就是pic，
'所以对于shape直接select，再copy，即以图片形式装入了粘贴板，
'后续操作相同。
OpenClipboard 0&
hBitmap = GetClipboardData(CF_BITMAP)
CloseClipboard
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
lRes = GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.Count = 1
With tParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(100)
End With
lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, tParams)
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If
Next inSh
End Sub
Private Sub ConvertShapeToInline()
Dim shp As Shape
Dim N As Long
If ActiveDocument.Shapes.Count = 0 Then Exit Sub
On Error Resume Next '防止一些转化失败
For Each shp In ActiveDocument.Shapes
Debug.Print "正在转换"; N
N = N + 1
shp.ConvertToInlineShape
Next shp
On Error GoTo 0
End Sub
