欧美一区二区三区,国内熟女精品熟女A片视频小说,日本av网,小鲜肉男男GAY做受XXX网站

如何用VBA代碼來提取word中的圖片

林玟書2年前41瀏覽0評論

如何用VBA代碼來提取word中的圖片?

使用Range.EnhMetaFileBits

來獲取圖片的EMF格式數組

然后用一系列API,轉換成常規的jpg/png/gif/bmp格式

本方法不占用剪貼板

GDI+ 保存圖片的函數改自這里:

https://www.cnblogs.com/Imageshop/archive/2012/03/02/2377871.html

略作調整如下:

'*************************************************************************

'** 作 者 : laviewpbt

'** 函 數 名 : SavehBitmapToFile

'** 輸 入 : Stdpic(StdPicture) - 圖象句柄

'** : FileName(String) - 保存路徑

'** : FileFormat(ImageFileFormat) - 保存格式,默認jpg

'** : JpgQuality(Long) - JPG圖象質量

'** : Resolution(Single) - 設置分辨率

'** 輸 出 : 無

'** 功能描述 : 把圖象保存為JPG、PNG、GIF、BMP格式

'** 修 改 人 : laviewpbt

'** 日 期 : 2012-03-02 22:56

'** 版 本 : 終結版

'** 修 改 人 : loquat 20190401

'*************************************************************************

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 GpStatus

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 GpStatus

Ok = 0

GenericError = 1

InvalidParameter = 2

OutOfMemory = 3

ObjectBusy = 4

InsufficientBuffer = 5

NotImplemented = 6

Win32Error = 7

WrongState = 8

Aborted = 9

FileNotFound = 10

ValueOverflow = 11

AccessDenied = 12

UnknownImageFormat = 13

FontFamilyNotFound = 14

FontStyleNotFound = 15

NotTrueTypeFont = 16

UnsupportedGdiplusVersion = 17

GdiplusNotInitialized = 18

PropertyNotFound = 19

PropertyNotSupported = 20

ProfileNotFound = 21

End Enum

Public Enum ImageFileFormat

bmp = 1

jpg = 2

png = 3

gif = 4

End Enum

Public Function SavehBitmapToFile(hBitmap As Long, 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+

Debug.Print GdipCreateBitmapFromHBITMAP(hBitmap, 0, bitmap)

If bitmap <> 0 Then '如果成功的將hBitmap句柄代表的stdPic對象轉換為GDI+的Bitmap對象了

GdipBitmapSetResolution bitmap, Resolution, Resolution

Select Case FileFormat

Case ImageFileFormat.bmp

If Not GetEncoderCLSID("Image/bmp", CLSID) = -1 Then

SavehBitmapToFile = (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)

SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), aEncParams(1)) = 0)

End If

Case ImageFileFormat.png

If Not GetEncoderCLSID("Image/png", CLSID) = -1 Then

SavehBitmapToFile = (GdipSaveImageToFile(bitmap, StrPtr(FileName), CLSID(0), ByVal 0) = 0)

End If

Case ImageFileFormat.gif

If Not GetEncoderCLSID("Image/gif", CLSID) = -1 Then '如果原始的圖像是24位,則這個函數會調用系統的調色板來將圖像轉換為8位,轉換的效果會不盡人意,但也有可能系統不自動轉換,保存失敗

SavehBitmapToFile = (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

以下是我封裝的代碼:

當然我偷懶,沒有使用GDI+,又選用了GDI,實際可以都用GDI+

Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function SetEnhMetaFileBits& Lib "gdi32.dll" (ByVal DataLen&, pData As Any)

Private Declare Function PlayEnhMetaFile& Lib "gdi32" (ByVal hdc&, ByVal hEMF&, pRect As Any)

Private Declare Function DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hEMF As Long)

Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any, ByVal hBrush As Long) As Long

Private Declare Function InvertRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As Any) As Long

Function ImageExtract(obj As Object, ByVal FileName As String, _

Optional ByVal FileFormat As ImageFileFormat = jpg, _

Optional ByVal JpgQuality As Long = 80, _

Optional Resolution As Single) As Boolean

Dim n! '放大倍數

Dim aRECT(0 To 3) As Long

Dim hScreenDC&

Dim hMemDC&

Dim hBitmap&, hBitTemp&

Dim arr() As Byte, hEMF&

n = 4

Select Case TypeName(obj) '獲取圖像數組

Case "InlineShape"

arr = obj.Range.EnhMetaFileBits

aRECT(2) = PointsToPixels(obj.Width, False) '寬度

aRECT(3) = PointsToPixels(obj.Height, True) '高度

Case "Shape"

arr = obj.Anchor.EnhMetaFileBits

aRECT(2) = PointsToPixels(obj.Width, False) '寬度

aRECT(3) = PointsToPixels(obj.Height, True) '高度

End Select

hEMF = SetEnhMetaFileBits(UBound(arr) + 1, arr(0))

hScreenDC = GetDC(0&)

hMemDC = CreateCompatibleDC(hScreenDC)

hBitmap = CreateCompatibleBitmap(hScreenDC, aRECT(2), aRECT(3))

hBitTemp = SelectObject(hMemDC, hBitmap)

InvertRect hMemDC, aRECT(0)

If hEMF Then

PlayEnhMetaFile hMemDC, hEMF, aRECT(0)

DeleteEnhMetaFile hEMF '銷毀EMF

End If

hBitmap = SelectObject(hMemDC, hBitTemp)

ImageExtract = SavehBitmapToFile(hBitmap, FileName, FileFormat, JpgQuality, Resolution)

DeleteObject hBitmap

DeleteDC hMemDC

DeleteDC hScreenDC

End Function

調用示例:

Dim oInlineShape As InlineShapeDim oShape As ShapeSet oInlineShape = oDocument.InlineShapes(1)Set oShape = oDocument.Shapes(2)If ImageExtract(oInlineShape, "c:\1.jpg",jpg, 100,600) thenmsgbox "保存成功"End IfIf ImageExtract(oShape, "c:\2.jpg",jpg, 100,600) thenmsgbox "保存成功"End If