Comment modifier la palette d'une image affichée en VB6 ?
Domi Meyer
dans un objet Image. Je cherche aussi à modifier l'image. Rien de plus
facile en C/C++, mais malheureusement, en VB6, je ne sais pas comment avoir
l'adresse de l'image. Qui peut m'aider ?
Dim pic As Picture
Set pic = LoadPicture("photo.gif")
'ima est l'objet Image
ima.Stretch = True
Set ima.Picture = pic
DUPUY Jean-Sébastien
L'API LoadBitmap permet de charger une image bitmap en mémoire et renvoie
son handle. A partir de cet handle, vous pouvez récupérer les informations
que vous souhaitez sur l'image et les modifier.
Pour ensuite afficher celle-ci dans un contrôle Picture, il est souhaitable
de convertir votre image en objet de type IPicture. Affecter ensuite
directement cet objet au contrôle pour afficher la bitmap.
Bon courage !
Jean-Sébastien DUPUY.
Option Explicit
Const IMAGE_BITMAP = &O0 ' used with LoadImage to load
' a bitmapPrivate Type BITMAP '14 bytes
Const LR_LOADFROMFILE = &H10
Const LR_DEFAULTSIZE = &H40
Const LR_CREATEDIBSECTION = &H2000
Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type BITMAP '14 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type DIBSECTION
dsBm As BITMAP
dsBmih As BITMAPINFOHEADER
dsBitfields(0 To 2) As Long
dshSection As Long
dsOffset As Integer
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function DSStoreDIBSectionInBMPFile _
Lib "c:\mono\dibsectn.dll" _
(ByVal nszFileName As String, ByVal hBitmap As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) _
As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, _
ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Sub Command1_Click()
Dim sFileName As String
Dim i As Integer
Dim hBitmap As Long, hOldBMP As Long, lbmDC As Long
Dim sBitmapInfo As BITMAP
Dim bmi As BITMAPINFO
' set the bitmap that will be used in the sample
sFileName = "c:\mono\24.bmp" ' sample is 600*386*1 BPP
' load the bitmap into memory
hBitmap = LoadImage(0, sFileName, IMAGE_BITMAP, 0, 0, _
LR_LOADFROMFILE Or LR_CREATEDIBSECTION Or LR_DEFAULTSIZE)
' make sure the call succeeded
If (hBitmap = 0) Then
MsgBox "Error, Unable To Load Bitmap", vbOKOnly, _
"Bitmap Load Error"
End
End If
' create a device context to use when blitting the loaded bitmap
lbmDC = CreateCompatibleDC(0)
' make sure our call succeeded
If (lbmDC = 0) Then
MsgBox "Error, Unable To Create Device Context", _
vbOKOnly, "Device Context Error"
Exit Sub
End If
Call GetBMPinfo(hBitmap, bmi)
End Sub
Private Sub GetBMPinfo(hBitmap As Long, bmi As BITMAPINFO)
Dim ds As DIBSECTION
Dim rowWidth As Long
Dim i As Long
Dim row() As Byte, lpBits As Long, pt As Long, rgb As RGBQUAD
pt = Picture1.Point(0, 0)
Call CopyMemory(rgb, pt, 4)
Call GetObject(hBitmap, Len(ds), ds)
rowWidth = ds.dsBm.bmWidthBytes
rowWidth = rowWidth + (4 - (rowWidth Mod 4))
ReDim row(1 To rowWidth)
lpBits = ds.dsBm.bmBits
For i = 1 To ds.dsBm.bmHeight
Call CopyMemory(row(1), ByVal lpBits, rowWidth)
row(1) = 255
Call CopyMemory(ByVal lpBits, row(1), rowWidth)
lpBits = lpBits + rowWidth
Next i
Set Picture1.Picture = CreateBitmapPicture(hBitmap, 0)
End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
' - Creates a bitmap type Picture object from a bitmap and
' palette.
'
' hBmp
' - Handle to a bitmap.
'
' hPal
' - Handle to a Palette.
' - Can be null if the bitmap doesn't use a palette.
'
' Returns
' - Returns a Picture object containing the bitmap.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As IPicture
Dim IID_IDispatch As GUID
' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts.
With Pic
.Size = Len(Pic) ' Length of structure.
.Type = vbPicTypeBitmap ' Type of Picture (bitmap).
.hBmp = hBmp ' Handle to bitmap.
.hPal = hPal ' Handle to palette (may be null).
End With
' Create Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
' Return the new Picture object.
Set CreateBitmapPicture = IPic
End Function
"Domi Meyer" <domi...@hotmail.com> wrote in message
news:uZHGZokWAHA.277@cppssbbsa05...
Domi Meyer
plusieurs fois que je posais la question.
Slide
"Domi Meyer" <domi...@hotmail.com> a écrit dans le message news:
euQwKZuWAHA.286@cppssbbsa04...