1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
| Public Function CallBack_ENumMetafile(ByVal hdc As Long, _
ByVal lpHtable As Long, _
ByVal lpMFR As Long, _
ByVal nObj As Long, _
ByVal lpClientData As Long) As Long
Dim PEnhEMR As EMR
Dim PEnhStrecthDiBits As EMRSTRETCHDIBITS
Dim tmpDc As Long
Dim hBitmap As Long
Dim lRet As Long
Dim BITMAPINFO As BITMAPINFO
Dim pBitsMem As Long
Dim pBitmapInfo As Long
Static RecordCount As Long
lRet = PlayEnhMetaFileRecord(hdc, ByVal lpHtable, ByVal lpMFR, ByVal nObj)
RecordCount = RecordCount + 1
CopyMemory PEnhEMR, ByVal lpMFR, Len(PEnhEMR)
Select Case PEnhEMR.iType
Case 1 'header
RecordCount = 1
Case EMR_STRETCHDIBITS
CopyMemory PEnhStrecthDiBits, ByVal lpMFR, Len(PEnhStrecthDiBits)
pBitmapInfo = lpMFR + PEnhStrecthDiBits.offBmiSrc
CopyMemory BITMAPINFO, ByVal pBitmapInfo, Len(BITMAPINFO)
pBitsMem = lpMFR + PEnhStrecthDiBits.offBitsSrc
tmpDc = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
hBitmap = CreateDIBitmap(tmpDc, _
BITMAPINFO.bmiHeader, _
CBM_INIT, _
ByVal pBitsMem, _
BITMAPINFO, _
DIB_RGB_COLORS)
lRet = DeleteDC(tmpDc)
If hBitmap Then
'init du pcturebox qui va recevoir le bitmap
frmExtractImgFromEmf.pctExport.Cls
frmExtractImgFromEmf.pctExport.Picture = LoadPicture("")
frmExtractImgFromEmf.pctExport.Width = BITMAPINFO.bmiHeader.biWidth
frmExtractImgFromEmf.pctExport.Height = BITMAPINFO.bmiHeader.biHeight
tmpDc = CreateCompatibleDC(frmExtractImgFromEmf.hdc)
lRet = SelectObject(tmpDc, hBitmap)
lRet = BitBlt(frmExtractImgFromEmf.pctExport.hdc, _
0, 0, _
frmExtractImgFromEmf.pctExport.Width, _
frmExtractImgFromEmf.pctExport.Height, _
tmpDc, _
0, 0, _
vbSrcCopy)
DeleteDC tmpDc
Set frmExtractImgFromEmf.pctExport.Picture = frmExtractImgFromEmf.pctExport.Image
SavePicture frmExtractImgFromEmf.pctExport.Picture, App.Path & "\temp" & CStr(RecordCount) & ".bmp"
MsgBox "la creation du bitmap a réussi"
DeleteObject hBitmap
Else
MsgBox "la création du bitmap a échoué"
End If
End Select
CallBack_ENumMetafile = True
End Function |
Partager