- 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