Code: Select all
#Include Once "windows.bi"
#Include Once "win/ocidl.bi"
#Include Once "win/olectl.bi"
Type CPicture extends object
public:
Declare Constructor()
Declare Constructor(ByVal opic As IPicture Ptr)
Declare Constructor (ByRef opic As Const CPicture)
Declare virtual Destructor()
Declare Operator let(ByVal opic As IPicture Ptr)
Declare Operator let(ByRef opic As Const CPicture)
Declare Operator cast() As IPicture Ptr
Declare Function Clone()ByRef As CPicture
Declare Static Function FromIPicture(ByVal opic As IPicture Ptr) ByRef As CPicture
Declare Function FromHandle(ByVal oHandle As LPVOID, ByVal PicType As Short) As BOOLEAN 'PicType== PICTYPE_UNINITIALIZED = -1 ,PICTYPE_NONE=0,PICTYPE_BITMAP=1,PICTYPE_METAFILE=2,PICTYPE_ICON = 3,PICTYPE_ENHMETAFILE=4
Declare Function LoadFromRes(sResourceType As LPCTSTR , sResource As LPCTSTR ) As BOOLEAN
Declare Function LoadFromRes(sResourceType As LPCTSTR , ByVal IDRes As Integer) As BOOLEAN
Declare Function LoadFromFile(sFileName As String ) As BOOLEAN
Declare Function Draw(pDC As HDC) As BOOLEAN
Declare Function Draw(pDC As HDC, Posi As POINT) As BOOLEAN
Declare Function Draw(pDC As HDC, Posi As POINT,oSize as SIZE ) As BOOLEAN
Declare Function Draw(pDC As HDC,nSizeRatio As double ) As BOOLEAN
Declare Function Draw(pDC As HDC, Posi As POINT ,nSizeRatio As double ) As BOOLEAN
Declare Function Render(pDC As HDC, x As Integer, y As Integer, cx As Integer, cy As Integer) As BOOLEAN
Declare Property type_() As Long ' PICTYPE_UNINITIALIZED = -1 ,PICTYPE_NONE=0,PICTYPE_BITMAP=1,PICTYPE_METAFILE=2,PICTYPE_ICON = 3,PICTYPE_ENHMETAFILE=4
Declare Property Width() As Long ' in pixels
Declare Property Height() As Long ' in pixels
Declare Property Handle() As LPVOID ' Can be hbitmap,hIcon,hmetafile or HenhMetafile
Declare Property Attributes() As ULong ' can be PICTURE_TRANSPARENT
Declare Sub Save(ByVal FileName As String) ' .bmp, .wmf, .ico, .emf
private:
Declare Static Function GetResource(lpName As LPCTSTR ,lpType As LPCTSTR ,pResource As Any Ptr , ByRef nBufSize As Integer) As BOOLEAN
Declare Sub UnLoad()
Declare Function LoadFromBuffer(pBuff As Byte Ptr , nSize As Integer) As BOOLEAN
Declare Function Draw(pDC As HDC, x As Integer, y As Integer, cx As Integer, cy As Integer) As BOOLEAN
Declare Function CHimetricToPixel_X(ByVal nWidth As Long) As Long
Declare Function CHimetricToPixel_Y(ByVal nHeight As Long) As Long
As IPicture Ptr m_pPicture
enum
HIMETRIC_PER_INCH = 2540
End Enum
End Type
'''''''''''''''''''''''''''''''''''
' Construction/Destruction
'''''''''''''''''''''''''''''''''''
Constructor CPicture()
m_pPicture = NULL
End Constructor
Constructor CPicture(ByVal opic As IPicture Ptr)
If m_pPicture Then
m_pPicture->lpvtbl->Release(m_pPicture)
EndIf
m_pPicture=opic
End Constructor
Constructor CPicture(ByRef opic As Const CPicture)
If m_pPicture Then
m_pPicture->lpvtbl->Release(m_pPicture)
EndIf
m_pPicture=opic.m_pPicture
If m_pPicture then m_pPicture->lpvtbl->AddRef(m_pPicture)
End Constructor
Destructor CPicture()
UnLoad()
End Destructor
Operator CPicture.let(ByVal opic As IPicture Ptr)
If m_pPicture Then
m_pPicture->lpvtbl->Release(m_pPicture)
EndIf
m_pPicture=opic
End Operator
Operator CPicture.let(ByRef opic As Const CPicture)
If m_pPicture Then
m_pPicture->lpvtbl->Release(m_pPicture)
EndIf
m_pPicture=opic.m_pPicture
If m_pPicture then m_pPicture->lpvtbl->AddRef(m_pPicture)
End Operator
Operator CPicture.cast() As IPicture Ptr
Return m_pPicture
End Operator
Function CPicture.Clone()ByRef As CPicture
Dim As CPicture Ptr pClone = new CPicture(This)
return ByVal pClone
End Function
Function CPicture.FromIPicture(ByVal opic As IPicture Ptr) ByRef As CPicture
Return ByVal (New CPicture(opic))
End Function
Function CPicture.FromHandle(ByVal oHandle As LPVOID, ByVal PicType As Short) As BOOLEAN
UnLoad()
'm_pPicture=PictureFromHandle(oHandle,PicType)
Return TRUE
End Function
Function CPicture.LoadFromRes(sResourceType As LPCTSTR , sResource As LPCTSTR ) As BOOLEAN
Dim As boolean bResult = false
if (m_pPicture <> NULL) Then
UnLoad()
End If
if (m_pPicture = NULL) Then
Dim As BYTE Ptr pBuff = NULL
Dim As Integer nSize = 0
if (GetResource(sResource , sResourceType , pBuff, nSize)) Then
if (nSize > 0) Then
pBuff = new BYTE[nSize]
if (GetResource(sResource, sResourceType ,pBuff, nSize)) Then
if (LoadFromBuffer(pBuff, nSize)) Then
bResult = true
End If
End If
delete [] pBuff
End If
End If
End If
return bResult
End Function
Function CPicture.LoadFromRes(sResourceType As LPCTSTR,ByVal IDRes As Integer ) As BOOLEAN
Dim As boolean bResult = false
if (m_pPicture <> NULL) Then
UnLoad()
End If
if (m_pPicture = NULL) Then
Dim As BYTE Ptr pBuff = NULL
Dim As Integer nSize = 0
if (GetResource(MAKEINTRESOURCE(IDRes) , sResourceType , pBuff, nSize)) Then
if (nSize > 0) Then
pBuff = new BYTE[nSize]
if (GetResource(MAKEINTRESOURCE(IDRes), sResourceType ,pBuff, nSize)) Then
if (LoadFromBuffer(pBuff, nSize)) Then
bResult = true
End If
End If
delete [] pBuff
End If
End If
End If
return bResult
End Function
'Open FileName For Binary Access Read As #FileNo
' ReDim B(0 To LOF(FileNo) - 1)
' Get #FileNo, , B()
' Close #FileNo
Function CPicture.LoadFromFile(sFileName As String ) As BOOLEAN
'OleLoadPictureFile(byval varFileName as VARIANT, byval lplpdisp
Dim As boolean bResult = false
if (m_pPicture <> NULL) Then
UnLoad()
End If
if (m_pPicture = NULL) Then
Dim As Integer BSize
Dim ff As Integer = FreeFile
Open sFileName For Binary Access Read As #ff
BSize=LOF(ff)
Dim As Byte Ptr pBuff = new BYTE[LOF(ff)]
Get #ff,,pBuff[0],BSize
Close #ff
If LoadFromBuffer(pBuff,BSize) Then
bResult = true
End If
Delete pBuff
End If
return bResult
End Function
Sub CPicture.UnLoad()
If m_pPicture Then
m_pPicture->lpvtbl->Release(m_pPicture)
m_pPicture = NULL
EndIf
End Sub
Function CPicture.Draw(pDC As HDC) As BOOLEAN
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Dim As Integer nWidth = CHimetricToPixel_X(hmWidth)
Dim As Integer nHeight = CHimetricToPixel_Y(hmHeight)
return Draw(pDC, 0, 0, nWidth, nHeight)
End If
return false
End Function
Function CPicture.Draw(pDC As HDC, Posi As Point) As BOOLEAN
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Dim As Integer nWidth = CHimetricToPixel_X(hmWidth)
Dim As Integer nHeight = CHimetricToPixel_Y(hmHeight)
return Draw(pDC, Posi.x, Posi.y, nWidth, nHeight)
End If
return false
End Function
Function CPicture.Draw(pDC As HDC, Posi As Point,oSize as Size ) As BOOLEAN
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Dim As Integer nWidth = oSize.cx
Dim As Integer nHeight = oSize.cy
return Draw(pDC, Posi.x, Posi.y, nWidth, nHeight)
End If
return false
End Function
Function CPicture.Draw(pDC As HDC,nSizeRatio As double ) As BOOLEAN
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Dim As Integer nWidth = CHimetricToPixel_X(hmWidth * nSizeRatio)
Dim As Integer nHeight = CHimetricToPixel_Y(hmHeight * nSizeRatio)
return Draw(pDC, 0, 0, nWidth, nHeight)
End If
return false
End Function
Function CPicture.Draw(pDC As HDC, Posi As Point ,nSizeRatio As double ) As BOOLEAN
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Dim As Integer nWidth = CHimetricToPixel_X(hmWidth * nSizeRatio)
Dim As Integer nHeight = CHimetricToPixel_Y(hmHeight * nSizeRatio)
return Draw(pDC, Posi.x, Posi.y, nWidth, nHeight)
End If
return false
End Function
Function CPicture.Render(pDC As HDC, x As Integer, y As Integer, cx As Integer, cy As Integer) As BOOLEAN
Return this.Draw(pDC, x, y, cx, cy)
End Function
Function CPicture.Draw(pDC As HDC, x As Integer, y As Integer, cx As Integer, cy As Integer) As BOOLEAN
Dim As Long hmWidth
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
If (m_pPicture->lpvtbl->Render(m_pPicture,pDC, x, y, cx, cy, 0, hmHeight, hmWidth, -hmHeight, NULL) = S_OK) Then
Return true
End If
return false
End Function
Function CPicture.LoadFromBuffer(pBuff As Byte Ptr , nSize As Integer) As BOOLEAN
Dim As boolean bResult = false
Dim As HGLOBAL hGlobal = GlobalAlloc(GMEM_MOVEABLE, nSize)
Dim As LPVOID pData = GlobalLock(hGlobal)
memcpy(pData, pBuff, nSize)
GlobalUnlock(hGlobal)
Dim As IStream ptr pStream = NULL
if (CreateStreamOnHGlobal(hGlobal, TRUE, @pStream) = S_OK) Then
Dim As HRESULT hr
hr = OleLoadPicture(pStream, nSize, FALSE, @IID_IPicture, cast(LPVOID Ptr,@m_pPicture))
if ( hr= S_OK) Then
bResult = true
End If
pStream->lpvtbl->Release(pStream)
End If
return bResult
End Function
Function CPicture.GetResource(lpName As LPCTSTR ,lpType As LPCTSTR ,pResource As Any Ptr , ByRef nBufSize As Integer) As BOOLEAN
Dim As HRSRC hResInfo
Dim As ..HANDLE hRes
Dim As HMODULE hInst = NULL
Dim As LPSTR lpRes = NULL
Dim As Integer nLen = 0
Dim As boolean bResult = FALSE
' Find the resource
hResInfo = FindResource(hInst, lpName, lpType)
if (hResInfo = NULL) Then
return false
End If
' Load the resource
hRes = LoadResource(hInst, hResInfo)
if (hRes = NULL) Then
return false
End If
' Lock the resource
lpRes = cast(ZString Ptr,LockResource(hRes))
if (lpRes <> NULL) Then
if (pResource = NULL) Then
nBufSize = SizeofResource(hInst, hResInfo)
bResult = true
else
if (nBufSize >= SizeofResource(hInst, hResInfo)) Then
memcpy(pResource, lpRes, nBufSize)
bResult = true
End If
End If
'UnlockResource(hRes)
End If
' Free the resource
FreeResource(hRes)
return bResult
End Function
Property CPicture.type_() As Long
if (m_pPicture <> NULL) Then
Dim As Short typ
m_pPicture->lpvtbl->get_type(m_pPicture,@typ)
Return typ
End If
End Property
Property CPicture.Width() As Long
if (m_pPicture <> NULL) Then
Dim As Long hmWidth
m_pPicture->lpvtbl->get_Width(m_pPicture,@hmWidth)
Return CHimetricToPixel_X(hmWidth) 'MulDiv(hmHeight,GetDeviceCaps(pDC,LOGPIXELSY), HIMETRIC_PER_INCH)
End If
End Property
Property CPicture.Height() As Long
if (m_pPicture <> NULL) Then
Dim As Long hmHeight
m_pPicture->lpvtbl->get_Height(m_pPicture,@hmHeight)
Return CHimetricToPixel_X(hmHeight) 'MulDiv(hmWidth, GetDeviceCaps(pDC,LOGPIXELSX), HIMETRIC_PER_INCH)
End If
End Property
Property CPicture.Handle() As LPVOID
If (m_pPicture <> NULL) Then
Dim As OLE_HANDLE picHandle
m_pPicture->lpvtbl->get_Handle(m_pPicture,@picHandle)
Return Cast(..HANDLE,picHandle)
End If
End Property
Property CPicture.Attributes() As ULong
If (m_pPicture <> NULL) Then
Dim As ULong Picture_Attributes
m_pPicture->lpvtbl->get_Attributes(m_pPicture,@Picture_Attributes)
Return Picture_Attributes
End If
End Property
Sub CPicture.save(ByVal FileName As String)
if (m_pPicture <> NULL) Then
Dim As WString*256 wfilename=FileName
OleSavePictureFile(Cast(LPDISPATCH,Cast(LPUNKNOWN,m_pPicture)), @wfilename)
EndIf
End Sub
Function CPicture.CHimetricToPixel_X(ByVal nWidth As Long) As Long
Dim hDCScreen As HDC , DPIX As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
DPIX = GetDeviceCaps(hDCScreen, LOGPIXELSX)
ReleaseDC 0, hDCScreen
End If
Return (nWidth * DPIX) / HIMETRIC_PER_INCH
End Function
Function CPicture.CHimetricToPixel_Y(ByVal nHeight As Long) As Long
Dim hDCScreen As HDC,DPIY As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
DPIY = GetDeviceCaps(hDCScreen, LOGPIXELSY)
ReleaseDC 0, hDCScreen
End If
Return (nHeight * DPIY) / HIMETRIC_PER_INCH
End Function
'Je constate que dans les deux As ci-dessous Delete n'est pas permis. mais pourtant dans l'implementation de CPicture.FromIPicture
'On a utilisé New dans ce cas New n'est pas suivi de delete?
'En fait les objets sont-t-ils libérés normalement?
/'
dim pic1 as Cpicture
dim ByRef pic2 as Cpicture =*Cast(Cpicture Ptr,NULL)
pic1.loadfromfile("C:\Users\Administrateur\Desktop\126_glyphspro\24x24\accounts.bmp")
print pic1.Width, pic1.height
@pic2=@(CPicture.FromIPicture(pic1))
print pic2.Width, pic2.height
' pic1 will be destroyed automatically
' for pic2 .
sleep
Delete @(pic2)
'/
dim pic1 as Cpicture
Dim pic2 as Cpicture
pic1.loadfromfile("C:\Users\Administrateur\Desktop\126_glyphspro\24x24\accounts.bmp")
print pic1.Width, pic1.height
pic2=CPicture.FromIPicture(pic1)
print pic2.Width, pic2.height
' pic1 will be destroyed automatically
' for pic2 .
sleep
' Delete @(pic2)