Transformer une image en un tableau .xls pixelisé

[Claudy]

Bonjour à tous,
Ai vu y a quelque temps la possibilité de pixeliser une image dans un tableau excel...
Si une bonne âme pouvait me donner un lien?
Merci d'avance,
Claudy

 

[Dranreb]

Re : Transformer une image en un tableau .xls pixelisé

Bonjour.

Je sais le faire de deux manières. Celle qui a ma préférence c'est la lecture directe d'un fichier .bmp
Mais j'ai aussi des routines plus obscures pour lire une propriété Picture de contrôle Image.
Je vous livre un bon bout de code :

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
'

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

Il travaille avec un objet Worksheet nommé Images contenant deux Controles Image1 et Image2
et des plages nommées RéfFicEnt et RéfFicSor pour les références fichier, le dernier "\" y étant remplacé par un retour à la ligne.
Il y a un bout de temps que je n'y ai plus replongé.

 

[Claudy]

Re : Transformer une image en un tableau .xls pixelisé

Bonjour et merci....
Pas possible d'avoir un classeur tout fait?
Car ça bugge chez moi!
Merci
Claudy

 

[Dranreb]

Re : Transformer une image en un tableau .xls pixelisé

Normal que ça bogue, c'est extrait d'un contexte, je n'ai jamais dit que c'était à exécuter tel quel, c'est à reprendre instruction par instruction. Je sais c'est compliqué, ce n'est pas de ma faute, les API sont comme ça. Il n'y a que la lecture d'un .bmp qui est relativement simple. Je ne saurais vous écrire un classeur adapté à vos besoins avec si peu d'information.

 

[roro69]

Re : Transformer une image en un tableau .xls pixelisé

Bonsoir
Tiens un lien qui devrait t'interesser:
http://www.andypope.info/fun/bmp2cells.zip
A++