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
'
Function FichierProduitParAPI() As Boolean
Dim bmAPI As BITMAP, AdresseMap As Long, TbOct() As Byte
Tâche "Production de l'image (plan A)", XbmMax * YbmMax
'Images.Image2.Picture = LoadPicture("")
'Images.Image2.Picture = ImageVide(XbmMax, YbmMax) ' L'IMAGE VIDE EST BIEN CRÉÉE MAIS RESTE HÉLAS INUTILISABLE !
If GetObject(Images.Image2.Picture, Len(bmAPI), bmAPI) = 0 Then
AbandonTâche "ancienne image non utilisable"
FichierProduitParAPI = False: Exit Function: End If
With bmAPI
If .bmWidth <> XbmMax Or .bmHeight <> YbmMax Or .bmBitsPixel <> 24 Then
AbandonTâche "les caractéristiques de la nouvelle image ont trop changé"
FichierProduitParAPI = False: Exit Function: End If
LgL = .bmWidthBytes: AdresseMap = .bmBits: End With
ReDim TbOct(1 To LgL * YbmMax) As Byte
If OnAÉRVB Then
For X = 1 To XbmMax: For Y = 1 To YbmMax
EngR = ÉR(X, Y): EngV = ÉV(X, Y): EngB = ÉB(X, Y): CalcRVBÉLi
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 1) = Round(Bleu)
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 2) = Round(Vert)
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 3) = Round(Roug)
Call OùÇaEnEst: Next Y: Next X
ElseIf OnAEHJ Then
For X = 1 To XbmMax: For Y = 1 To YbmMax
CalcÉngpEHJ tE(X, Y), tH(X, Y), tJ(X, Y): CalcRVBÉLi
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 1) = Round(Bleu)
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 2) = Round(Vert)
TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 3) = Round(Roug)
Call OùÇaEnEst: Next Y: Next X
Else
For X = 1 To XbmMax: For Y = 1 To YbmMax
For C = 1 To 3: TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + C) = PxBrut(C, X, Y): Next C
Call OùÇaEnEst: Next Y: Next X
End If
MoveMemory ByVal AdresseMap, TbOct(1), UBound(TbOct)
On Error Resume Next
SavePicture Images.Image2.Picture, ChNomF
If Err Then
AbandonTâche "plantage méthode savepicture"
MsgBox "La méthode SavePicture plante :" & vbLf & Err.Description, vbExclamation, NomTâche
FichierProduitParAPI = False
Else
FichierProduitParAPI = True: End If
End Function
'
'Function FichierProduitParAPI() As Boolean
'Dim bmAPI As BITMAP, TbOct() As Byte
'LgL = 4 * ((XbmMax * 24 + 31) \ 32)
'ReDim TbOct(1 To LgL * YbmMax) As Byte
'Tâche "Production de l'image (plan A)", XbmMax * YbmMax
'If OnAÉRVB Then
' For X = 1 To XbmMax: For Y = 1 To YbmMax
' EngR = ÉR(X, Y): EngV = ÉV(X, Y): EngB = ÉB(X, Y): CalcRVBÉLi
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 1) = Round(Bleu)
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 2) = Round(Vert)
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 3) = Round(Roug)
' Call OùÇaEnEst: Next Y: Next X
'ElseIf OnAEHJ Then
' For X = 1 To XbmMax: For Y = 1 To YbmMax
' CalcÉngpEHJ tE(X, Y), tH(X, Y), tJ(X, Y): CalcRVBÉLi
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 1) = Round(Bleu)
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 2) = Round(Vert)
' TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + 3) = Round(Roug)
' Call OùÇaEnEst: Next Y: Next X
'Else
' For X = 1 To XbmMax: For Y = 1 To YbmMax
' For C = 1 To 3: TbOct(3 * (X - 1) + LgL * (YbmMax - Y) + C) = PxBrut(C, X, Y): Next C
' Call OùÇaEnEst: Next Y: Next X
' End If
'With bmAPI
' .bmType = 0
' .bmWidth = XbmMax
' .bmHeight = YbmMax
' .bmWidthBytes = LgL
' .bmPlanes = 1
' .bmBitsPixel = 24
' .bmBits = VarPtr(TbOct(1))
' End With
'Images.Image2.Picture = LoadPicture("")
'Images.Image2.Picture = ImageCréée(bmAPI) ' UNE IMAGE NOIRE EST CRÉÉE !
'On Error Resume Next
'SavePicture Images.Image2.Picture, ChNomF
'If Err Then
' AbandonTâche "plantage méthode savepicture"
' MsgBox "La méthode SavePicture plante :" & vbLf & Err.Description, vbExclamation, NomTâche
' FichierProduitParAPI = False
'Else
' FichierProduitParAPI = True: End If
'End Function
''
Sub ChargerImageBMP()
Tâche "Chargement de l'image (plan B)"
If UCase(Right(ChNomF, 4)) <> ".BMP" Then
AbandonTâche "ce n'est pas un fichier "".bmp"""
MsgBox "Seuls des "".bmp"" peuvent être chargés par le plan de secours", vbCritical, NomTâche
Exit Sub: End If
Open ChNomF For Binary Access Read As #1 Len = 1
Dim BM As String * 2: Get #1, 1, BM
If BM <> "BM" Then AbandonTâche "fichier "".Bmp"" non valide": MsgBox "Ce n'est pas un fichier ""Bmp"" valide.", _
vbCritical, NomTâche: Close #1: Exit Sub
Get #1, 11, LgE: Get #1, 19, XbmMax: Get #1, 23, YbmMax: Get #1, 29, BitPx
LgL = 4 * ((XbmMax * BitPx + 31) \ 32)
ReDim PxBrut(1 To 3, 1 To XbmMax, 1 To YbmMax) As Byte
Tâche , XbmMax * YbmMax
If BitPx = 24 Then
For Y = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Y) + 1
For X = 1 To XbmMax
For C = 1 To 3: Get #1, , PxBrut(C, X, Y): Next C
Call OùÇaEnEst: Next X
Next Y
Succès = True
ElseIf BitPx = 8 Then
ReDim Pal(0 To 255, 1 To 3) As Byte
For C = 0 To 255
Get #1, 4 * C + 55, Pal(C, 1): Get #1, , Pal(C, 2): Get #1, , Pal(C, 3)
Next C
For Y = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Y) + 1
For X = 1 To XbmMax
Get #1, , Oct
For C = 1 To 3: PxBrut(C, X, Y) = Pal(Oct, C): Next C
Call OùÇaEnEst: Next X
Next Y
Succès = True
Else
AbandonTâche "format non supporté"
MsgBox "Image à " & BitPx & " bits / pixel non supporté", vbCritical, NomTâche
End If
Close #1
End Sub
'
Sub ÉcrireFichierBMP()
Close #1
Tâche "Production de l'image (plan B)", XbmMax * YbmMax
If UCase(Right(ChNomF, 4)) <> ".BMP" Then
Dim Va As Variant
Va = Application.GetSaveAsFilename(Left$(ChNomF, DernierDans(ChNomF, ".") - 1), _
"BitMaps,*.bmp", Title:=NomTâche)
If Va = False Then AbandonTâche "nom de fichier .bmp non fourni": Succès = False: Exit Sub
ChNomF = Va
Images.[RéfFicSor].Value = Replace(ChNomF, "\", vbLf, DernierDans(ChNomF, "\"), 1): End If
Open ChNomF For Binary Access Write As #1 Len = 1
Const BM As String * 2 = "BM": Put #1, 1, BM
BitPx = 24: NbCoul = 0
LgL = 4 * ((XbmMax * BitPx + 31) \ 32): LgM = LgL * YbmMax
LgE = 4 * NbCoul + 54: LgF = LgE + LgM
Put #1, 3, LgF: Put #1, 7, 0&: Put #1, 11, LgE: Put #1, 15, 40&
Put #1, 19, XbmMax: Put #1, 23, YbmMax
Put #1, 27, 1: Put #1, 29, BitPx: Put #1, 31, 0&
Put #1, 35, LgM: Put #1, 39, 0&: Put #1, 43, 0&: Put #1, 47, NbCoul: Put #1, 51, 0&
Dim XRempliss As Long: XRempliss = LgL - 3 * XbmMax
If OnAÉRVB Then
For Y = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Y) + 1
For X = 1 To XbmMax
EngR = ÉR(X, Y): EngV = ÉV(X, Y): EngB = ÉB(X, Y): CalcRVBÉLi
Oct = Round(Bleu): Put #1, , Oct
Oct = Round(Vert): Put #1, , Oct
Oct = Round(Roug): Put #1, , Oct
Call OùÇaEnEst: Next X
Oct = 0: For X = 1 To XRempliss: Put #1, , Oct: Next X
Next Y
ElseIf OnAEHJ Then
For Y = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Y) + 1
For X = 1 To XbmMax
CalcÉngpEHJ tE(X, Y), tH(X, Y), tJ(X, Y): CalcRVBÉLi
Oct = Round(Bleu): Put #1, , Oct
Oct = Round(Vert): Put #1, , Oct
Oct = Round(Roug): Put #1, , Oct
Call OùÇaEnEst: Next X
Oct = 0: For X = 1 To XRempliss: Put #1, , Oct: Next X
Next Y
Else
For Y = 1 To YbmMax
Seek #1, LgE + LgL * (YbmMax - Y) + 1
For X = 1 To XbmMax
Put #1, , PxBrut(1, X, Y)
Put #1, , PxBrut(2, X, Y)
Put #1, , PxBrut(3, X, Y)
Call OùÇaEnEst: Next X
Oct = 0: For X = 1 To XRempliss: Put #1, , Oct: Next X
Next Y
End If
Close #1
Succès = True
End Sub
'
Sub ShellPhotoEd()
ChNomF = Replace(Images.[RéfFicSor].Value, vbLf, "\")
Shell "C:\Program Files\Fichiers communs\Microsoft Shared\PhotoEd\PHOTOED.EXE """ & ChNomF & """", vbNormalNoFocus
End Sub
