Option Explicit
Rem. Conventions API (Application Programming Interface)
Type BITMAP
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Declare Function GetObjectType Lib "gdi32.dll" (ByVal hgdiobj As Long) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" _
(ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" _
(ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDIBColorTable Lib "gdi32.dll" _
(ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pRGBQuad As RGBQUAD) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal L As Long)
Dim ChNomF As String, LgL As Long, NbCoul As Long, LgE As Long, LgM As Long, LgF As Long
Dim Oct As Byte, BitPx As Integer, Succès As Boolean
'
Sub ChargerImage()
ChNomF = Replace(Images.[RéfFicEnt].Value, vbLf, "\")
If Dir(ChNomF) = "" Then
MsgBox ChNomF & " inexistant", vbCritical, "Chargement de l'image": Exit Sub: End If
With Images.Image1
.Left = Images.[PlgImg1].Left: .Width = Images.[PlgImg1].Width: .Top = Images.[PlgImg1].Top: .Height = Images.[PlgImg1].Height
On Error Resume Next
.Picture = LoadPicture(ChNomF)
If Err Then MsgBox Err.Description, vbCritical, "Chargement de l'image": Exit Sub
On Error GoTo 0: End With
Succès = ImageChargéeParAPI
If Not Succès Then ChargerImageBMP
If Succès Then
Réglage.[XbmMax].Value = XbmMax
Réglage.[YbmMax].Value = YbmMax: End If
OnAÉRVB = False: OnAEHJ = False
End Sub
'
Sub ÉcritureImage()
ChNomF = Replace(Images.[RéfFicSor].Value, vbLf, "\")
Succès = FichierProduitParAPI
If Not Succès Then ÉcrireFichierBMP
If Succès Then
With Images.Image2
.Left = Images.[PlgImg2].Left: .Width = Images.[PlgImg2].Width: .Top = Images.[PlgImg2].Top: .Height = Images.[PlgImg2].Height
.Picture = LoadPicture(ChNomF)
End With
End If
End Sub
'
Function ImageChargéeParAPI() As Boolean
Dim bmAPI As BITMAP, AdresseMap As Long, TbOct() As Byte, Planes As Integer
Dim hDC As Long, NbCoul As Integer, Pal(0 To 255) As RGBQUAD, hObjectOld As Long, N°Coul As Integer
Tâche "Chargement de l'image (plan A)"
hDC = GetObjectType(Images.Image1.Picture)
If hDC <> 7 Then
AbandonTâche "type d'image inapproprié"
MsgBox "L'objet de type " & Array("nul", "PEN", "BRUSH", "DC", "METADC", "PAL", "FONT", "BITMAP", "REGION", _
"METAFILE", "MEMDC", "EXTPEN", "ENHMETADC", "ENHMETAFILE", "COLORSPACE")(hDC) & " ne peut être traité.", _
vbExclamation, NomTâche
ImageChargéeParAPI = False: Exit Function: End If
If GetObject(Images.Image1.Picture, Len(bmAPI), bmAPI) = 0 Then
AbandonTâche "information d'image non disponible"
MsgBox "Impossible d'analyser cette image", vbExclamation, NomTâche
ImageChargéeParAPI = False: Exit Function: End If
With bmAPI
XbmMax = .bmWidth: YbmMax = .bmHeight: LgL = .bmWidthBytes
Planes = .bmPlanes: BitPx = .bmBitsPixel: AdresseMap = .bmBits: End With
ReDim PxBrut(1 To 3, 1 To XbmMax, 1 To YbmMax) As Byte
ReDim TbOct(1 To LgL * YbmMax) As Byte
MoveMemory TbOct(1), ByVal AdresseMap, UBound(TbOct)
Tâche , XbmMax * YbmMax
If BitPx = 24 Then
For X = 1 To XbmMax: For Y = 1 To YbmMax
For C = 1 To 3: PxBrut(C, X, Y) = TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + C): Next C
Call OùÇaEnEst: Next Y: Next X
ImageChargéeParAPI = True
ElseIf BitPx = 8 Or BitPx = 4 Then
hDC = CreateCompatibleDC(0)
hObjectOld = SelectObject(hDC, Images.Image1.Picture)
If GetDIBColorTable(hDC, 0, 256, Pal(0)) = 0 Then
AbandonTâche "palette inaccessible"
MsgBox "La palette de couleur de cette image " & BitPx & " bits / pixel est inaccessible", _
vbExclamation, NomTâche
ImageChargéeParAPI = False: Exit Function: End If
For X = 1 To XbmMax: For Y = 1 To YbmMax
If BitPx = 8 Then
N°Coul = TbOct(X + LgL * (YbmMax - Y))
Else
N°Coul = TbOct((X + 1) \ 2 + LgL * (YbmMax - Y))
If X And &H1 Then N°Coul = N°Coul \ 16 Else N°Coul = N°Coul And &HF
End If
With Pal(N°Coul)
PxBrut(1, X, Y) = .rgbBlue
PxBrut(2, X, Y) = .rgbGreen
PxBrut(3, X, Y) = .rgbRed: End With
Call OùÇaEnEst: Next Y: Next X
SelectObject hDC, hObjectOld 'Obligatoire parce que c'est comme ça.
DeleteDC hDC
ImageChargéeParAPI = True
ElseIf BitPx = 16 Then
AbandonTâche "format non supporté"
MsgBox "Image 16 bits / pixel non supportée." & vbLf _
& "Remarque: Vérifiez les paramètres de l'affichage Windows.", vbExclamation, NomTâche
ImageChargéeParAPI = False
Else
AbandonTâche "format non supporté"
MsgBox "Image " & BitPx & " bits / pixel non supportée.", vbExclamation, NomTâche
ImageChargéeParAPI = False: End If
End Function