[Digressions] Shapes your booty, Fractales et consorts...

Dranreb · 1 Octobre 2022

C'est en effet un ensemble de Julia visualisé sur un plan complexe inversé (les parties au centre sont les plus éloignées du centre dans la vue normale).

Dranreb · 1 Octobre 2022

Bon, je cite provisoirement un bout de module qui fabrique des .bmp :

VB:

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 SetDIBColorTable Lib "gdi32.dll" _
   (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcRGBQuad 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
 
Declare Sub MoveMM Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal L As Long)
Declare Sub MoveAM Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, Source As Any, ByVal L As Long)
Declare Sub MoveMA Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal SrcA As Long, ByVal L As Long)
Declare Sub MoveAA Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, ByVal SrcA As Long, 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, Feui As Worksheet
'
Public XbmMax As Long, Xbm As Long
Public YbmMax As Long, Ybm As Long
Public TE() As Double, TH() As Double, TJ() As Double, TA() As Double
Sub InitCalculImage(Feuille As Worksheet)
Set Feui = Feuille
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
XbmMax = Feui.Range("XbmMax").Value
YbmMax = Feui.Range("YbmMax").Value
Tâche "Calcul image", XbmMax * YbmMax
ReDim TE(1 To XbmMax, 1 To YbmMax) As Double
ReDim TH(1 To XbmMax, 1 To YbmMax) As Double
ReDim TJ(1 To XbmMax, 1 To YbmMax) As Double
ReDim TA(1 To XbmMax, 1 To YbmMax) As Double
End Sub
'

Sub ÉcritureImage(ByVal Img As Image)
Succès = FichierProduitParAPI(Img)
If Not Succès Then ÉcrireFichierBMP
If Succès Then
   MàJImage Img
   On Error Resume Next
   Dim G As Chart: Set G = Feui.ChartObjects("GImage").Chart: If Err Then Exit Sub
   G.Axes(xlCategory).MaximumScale = XbmMax
   G.Axes(xlValue).MaximumScale = YbmMax
   G.Axes(xlCategory).TickLabels.AutoScaleFont = False
   G.Axes(xlValue).TickLabels.AutoScaleFont = False
   Dim Divi As Long: On Error Resume Next: Divi = ActiveSheet.[DivGraph].Value: If Err Then Divi = 1
   On Error GoTo 0
   G.Axes(xlCategory).MajorUnit = Divi
   G.Axes(xlValue).MajorUnit = Divi
   G.PlotArea.Fill.UserPicture PictureFile:=ChNomF
   G.CopyPicture
   GphIsoEchelles G
   End If
End Sub
'

Function FichierProduitParAPI(Img As Image) As Boolean
Dim BmAPI As BITMAP, AdresseMap As Long, TbOct() As Byte
Tâche "Production de l'image (plan A)", XbmMax * YbmMax
On Error Resume Next
Img.Picture = LoadPicture(ChNomF)
If Err Then
    AbandonTâche "nouveau fichier": FichierProduitParAPI = False: Exit Function: End If
On Error GoTo 0
If GetObject(Img.Picture, Len(BmAPI), BmAPI) = 0 Then
    AbandonTâche "objet non obtenu": FichierProduitParAPI = False: Exit Function: End If
With BmAPI
   If .bmWidth <> XbmMax Or .bmHeight <> YbmMax Or .bmBitsPixel <> 24 Then
      AbandonTâche "caractéristiques image trop différentes"
      FichierProduitParAPI = False: Exit Function: End If
   LgL = .bmWidthBytes: AdresseMap = .bmBits: End With
ReDim TbOct(1 To LgL * YbmMax) As Byte
For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
   Enrg = TE(Xbm, Ybm): Chal = TH(Xbm, Ybm): Gaît = TJ(Xbm, Ybm)
   Call CalcÉngEHJ: CalcRVBÉLi
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 1) = Round(Bleu)
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 2) = Round(Vert)
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 3) = Round(Roug)
   Call OùÇaEnEst: Next Ybm: Next Xbm
MoveAM DstA:=AdresseMap, Source:=TbOct(1), L:=UBound(TbOct)
On Error Resume Next
SavePicture Img.Picture, ChNomF
If Err Then
   AbandonTâche "écriture impossible"
   MsgBox "La méthode SavePicture plante :" & vbLf & Err.Description, vbExclamation, NomTâche
   FichierProduitParAPI = False
Else
   FichierProduitParAPI = True: End If
End Function
'

Sub ÉcrireFichierBMP()
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, InStrRev(ChNomF, ".") - 1), "BitMaps,*.bmp", Title:=NomTâche)
   If Va = False Then AbandonTâche "réf. fichier non fournie": Succès = False: Exit Sub
   ChNomF = Va
   Range("RéfFicSor").Value = Replace(ChNomF, "\", vbLf, InStrRev(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 Integer: XRempliss = LgL - 3 * XbmMax
For Ybm = 1 To YbmMax
   Seek #1, LgE + LgL * (YbmMax - Ybm) + 1
   For Xbm = 1 To XbmMax
      Enrg = TE(Xbm, Ybm): Chal = TH(Xbm, Ybm): Gaît = TJ(Xbm, Ybm)
      Call CalcÉngEHJ: CalcRVBÉLi
      Put #1, , CByte(Int(Bleu + 0.5))
      Put #1, , CByte(Int(Vert + 0.5))
      Put #1, , CByte(Int(Roug + 0.5))
      Call OùÇaEnEst: Next Xbm
   Oct = 0: For Xbm = 1 To XRempliss: Put #1, , Oct: Next Xbm
   Next Ybm
Close #1
Succès = True
End Sub
Sub ÉcrireCanAlpha()
   Const BM As String * 2 = "BM": Dim Alpha As Byte
   Open "C:\Users\Luck\Pictures\CanAlpha.bmp" For Binary Access Write As #1 Len = 1
   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 Integer: XRempliss = LgL - 3 * XbmMax
   For Ybm = 1 To YbmMax
      Seek #1, LgE + LgL * (YbmMax - Ybm) + 1
      For Xbm = 1 To XbmMax
         Alpha = CByte(Int(255 * TA(Xbm, Ybm) + 0.5))
         Put #1, , Alpha: Put #1, , Alpha: Put #1, , Alpha
         Next Xbm
      Oct = 0: For Xbm = 1 To XRempliss: Put #1, , Oct: Next Xbm
      Next Ybm
   Close #1
   Shell "C:\Users\Luck\PhotoFiltre7\PhotoFiltre7 ""C:\Users\Luck\Pictures\CanAlpha.bmp""", vbNormalNoFocus
   End Sub
'

Function ImageChargéeParAPI(Img As Image) 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, C As Long
Outils.Tâche "Chargement de l'image (plan A)", XbmMax * YbmMax
hDC = GetObjectType(Img.Picture)
If hDC <> 7 Then
   AbandonTâche "Type d'image non supporté"
   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(Img.Picture, Len(BmAPI), BmAPI) = 0 Then
   AbandonTâche "Impossible d'analyser cette image"
   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
NbPixÀFaire = XbmMax * YbmMax
ReDim PxBrut(1 To 3, 1 To XbmMax, 1 To YbmMax) As Byte
ReDim TbOct(1 To LgL * YbmMax) As Byte
MoveMA TbOct(1), SrcA:=AdresseMap, L:=UBound(TbOct)
If BitPx = 24 Then
   For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
      For C = 1 To 3: PxBrut(C, Xbm, Ybm) = TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + C): Next C
      Outils.OùÇaEnEst: Next Ybm: Next Xbm
   ImageChargéeParAPI = True
ElseIf BitPx = 8 Or BitPx = 4 Then
   hDC = CreateCompatibleDC(0)
   hObjectOld = SelectObject(hDC, Img.Picture)
   If GetDIBColorTable(hDC, 0, 256, Pal(0)) = 0 Then
      AbandonTâche "Palette de couleur inaccessible"
      MsgBox "Palette de couleur inaccessible cette image " & BitPx & " bits / pixel, vbExclamation, NomTâche"
      ImageChargéeParAPI = False: Exit Function: End If
   For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
      If BitPx = 8 Then
         N°Coul = TbOct(Xbm + LgL * (YbmMax - Ybm))
      Else
         N°Coul = TbOct((Xbm + 1) \ 2 + LgL * (YbmMax - Ybm))
         If Xbm And &H1 Then N°Coul = N°Coul \ 16 Else N°Coul = N°Coul And &HF
         End If
      With Pal(N°Coul)
         PxBrut(1, Xbm, Ybm) = .rgbBlue
         PxBrut(2, Xbm, Ybm) = .rgbGreen
         PxBrut(3, Xbm, Ybm) = .rgbRed: End With
      Outils.OùÇaEnEst: Next Ybm: Next Xbm
   SelectObject hDC, hObjectOld 'Obligatoire parce que c'est comme ça.
   DeleteDC hDC
   ImageChargéeParAPI = True
Else
   MsgBox "Image " & BitPx & " bits / pixel non supportée", vbExclamation, NomTâche
   ImageChargéeParAPI = False: End If
End Function
'
Sub MàJImage(ByVal Img As MSForms.Image)
Dim Ech As Double, Forme As Shape
Img.Picture = LoadPicture(ChNomF)
Set Forme = Img.Parent.Shapes("Img")
On Error Resume Next
Ech = Img.Parent.[EchMinia].Value * 3 / 4
If Err Then Exit Sub
'Forme.Width = XbmMax * Ech
'Forme.Height = YbmMax * Ech
Img.Width = XbmMax * Ech
Img.Height = YbmMax * Ech
End Sub

Sub ShellPhotoEd()
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
'Shell "C:\Program Files\Fichiers communs\Microsoft Shared\PhotoEd\PHOTOED.EXE """ & ChNomF & """", vbNormalNoFocus
'Shell "C:\Windows\System32\mspaint.exe """ & ChNomF & """", vbNormalNoFocus
Shell "C:\Program Files\paint.net\PaintDotNet.exe """ & ChNomF & """", vbNormalNoFocus
End Sub
Sub ShellPhotoFiltre()
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
Shell "C:\Users\Luck\PhotoFiltre7\PhotoFiltre7 """ & ChNomF & """", vbNormalNoFocus
End Sub

C'est surtout la Sub ÉcrireFichierBMP() qui est intéressante. Elle part de 3 tableaux As double TE, TH, et TJ, aux dimensions de l'image à partir desquel sont calculés des codes de couleurs selon les mêmes calculs que ceux effectués dans mon CouleurCls.xlsm (disponible en téléchargement).

Staple1600 · 1 Octobre 2022

Re

@Dranreb
Merci pour ce partage.
J'ai commencé à lire ton code VBA.
(Et en premier j'ai modifié les déclarations car je suis en 64 bits)
Mais en l'état, je ne peux tester plus avant.

Dranreb · 1 Octobre 2022

Les API ne sont pas nécessaires à la Sub ÉcrireFichierBMP
Elles sont plutôt utilisées pour réécrire plus rapidement le .bmp à partir de la Picture d'un ActiveX Image.
La Sub ÉcrireCanAlpha() est peut être une base plus simple pour commencer. Comme son nom l'indique elle me sert à fabriquer un fichier bmp en nuance de gris que je fait ensuite prendre en compte par PhotoFiltre comme couche de transparence.

Staple1600 · 1 Octobre 2022

Re

J'ai une erreur ici quand je lance EcrireFichierBMP
VBE stoppe sur cette procédure
Sub ÉcritureImage(ByVal Img As Image)
et affiche ce message
Type défini par l'utilisateur non défini

Staple1600 · 1 Octobre 2022

@Dranreb

J'ai téléchargé CouleurCls.xlsm.
Il fonctionne sur mon Office 365

Mais je n'arrive toujours pas à tester le VBA du message#92

Voici comment j'ai modifié les déclarations pour le 64 bits

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
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetObjectType Lib "gdi32.dll" (ByVal hgdiobj As Long) As Long
Private Declare PtrSafe Function GetObject Lib "gdi32.dll" Alias "GetObjectA" _
   (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" _
   (ByVal hDC As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" _
   (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function SetDIBColorTable Lib "gdi32.dll" _
   (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcRGBQuad As RGBQUAD) As Long

Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetLastError Lib "kernel32.dll" () As Long
  
Declare PtrSafe Sub MoveMM Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal L As Long)
Declare PtrSafe Sub MoveAM Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, Source As Any, ByVal L As Long)
Declare PtrSafe Sub MoveMA Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal SrcA As Long, ByVal L As Long)
Declare PtrSafe Sub MoveAA Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, ByVal SrcA As Long, ByVal L As Long)
#Else
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 SetDIBColorTable Lib "gdi32.dll" _
   (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcRGBQuad 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
  
Declare Sub MoveMM Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal L As Long)
Declare Sub MoveAM Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, Source As Any, ByVal L As Long)
Declare Sub MoveMA Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal SrcA As Long, ByVal L As Long)
Declare Sub MoveAA Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, ByVal SrcA As Long, ByVal L As Long)
#End If
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, Feui As Worksheet
'
Public XbmMax As Long, Xbm As Long
Public YbmMax As Long, Ybm As Long
Public TE() As Double, TH() As Double, TJ() As Double, TA() As Double

garnote · 1 Octobre 2022

Dranreb à dit:
Bonjour.
Une de mes vieilles images :
Regarde la pièce jointe 1151106
C'est au départ un .bmp réalisé par un classeur Excel disposant d'une routine permettant d'en écrire à partir de tableaux, avec ou sans palette (au cas où ça vous intéresserait de savoir y colorer des pixels plutôt que des cellules d'une feuille de calcul).

Staple1600 à dit:
Bonsoir le fil, @garnote, @TooFatBoy

Je ne m'en lasse pas
Maintenant comme faire ceci avec la méthode de @garnote, là je sèche dans les grandes largeurs.

Code:

Sub lime() Application.ScreenUpdating = False Grille Mandelbrot ActiveWindow.Zoom = 35 Application.ScreenUpdating = True End Sub Private Sub Grille() Range("A1:OF396").ColumnWidth = 0.2 Range("A1:OF396").RowHeight = 2 End Sub Private Sub Mandelbrot() D = 99 For x = 1 To 4 * D For y = 1 To 4 * D p = 0: q = 0 For j = 1 To 98 c = 2 * p * q p = p ^ 2 - q ^ 2 - 2 + (x - 1) / D q = c + 2 + (1 - y) / D If p ^ 2 + q ^ 2 >= 4 Then Exit For Next j j = -j * (j < D) Cells(y, x).Interior.Color = Rnd(-j) * 1000000# * j / D Next y, x 'crédits: Engine Toaster - septembre 2017 End Sub

Vous reprendrez bien un petit peu de PowerShell ?

Code:

$M='System.Windows.Forms';nal n New-Object;Add-Type -A System.Drawing,$M;($a=n "$M.Form").backgroundimage=($b=n Drawing.Bitmap 300,300);0..299|%{$r=$_;0..299|%{$i=99;$k=$C=n numerics.complex($_/75-2),($r/75-2);while((($k=$k*$k).Magnitude-lt4)-and$i--){$k+=$C}$b.SetPixel($_,$r,-5e6*++$i)}};$a.Show()

Il ouvre PowerShell (en mode Console)
Il copie/colle la ligne de code ci-dessus
Il fait infuser son thé 61 secondes puis il regarde son écran
Etonnant, non ?

NB: C'est aussi une spéciale dédicace à Monsieur @TooFatBoy

Ave fil, @Staple1600 @TooFatBoy
Je ne crois pas qu'on puisse faire un Mandelbrot et des Julia avec ma méthode des "456 fractales". Et quant à en faire avec des cellules plutôt qu'avec un graphique, je suis dans l'étonnement total.

garnote · 1 Octobre 2022

Dranreb à dit:

Bon, je cite provisoirement un bout de module qui fabrique des .bmp :

VB:

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 SetDIBColorTable Lib "gdi32.dll" _
   (ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, ByRef pcRGBQuad 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
 
Declare Sub MoveMM Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal L As Long)
Declare Sub MoveAM Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, Source As Any, ByVal L As Long)
Declare Sub MoveMA Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, ByVal SrcA As Long, ByVal L As Long)
Declare Sub MoveAA Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal DstA As Long, ByVal SrcA As Long, 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, Feui As Worksheet
'
Public XbmMax As Long, Xbm As Long
Public YbmMax As Long, Ybm As Long
Public TE() As Double, TH() As Double, TJ() As Double, TA() As Double
Sub InitCalculImage(Feuille As Worksheet)
Set Feui = Feuille
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
XbmMax = Feui.Range("XbmMax").Value
YbmMax = Feui.Range("YbmMax").Value
Tâche "Calcul image", XbmMax * YbmMax
ReDim TE(1 To XbmMax, 1 To YbmMax) As Double
ReDim TH(1 To XbmMax, 1 To YbmMax) As Double
ReDim TJ(1 To XbmMax, 1 To YbmMax) As Double
ReDim TA(1 To XbmMax, 1 To YbmMax) As Double
End Sub
'

Sub ÉcritureImage(ByVal Img As Image)
Succès = FichierProduitParAPI(Img)
If Not Succès Then ÉcrireFichierBMP
If Succès Then
   MàJImage Img
   On Error Resume Next
   Dim G As Chart: Set G = Feui.ChartObjects("GImage").Chart: If Err Then Exit Sub
   G.Axes(xlCategory).MaximumScale = XbmMax
   G.Axes(xlValue).MaximumScale = YbmMax
   G.Axes(xlCategory).TickLabels.AutoScaleFont = False
   G.Axes(xlValue).TickLabels.AutoScaleFont = False
   Dim Divi As Long: On Error Resume Next: Divi = ActiveSheet.[DivGraph].Value: If Err Then Divi = 1
   On Error GoTo 0
   G.Axes(xlCategory).MajorUnit = Divi
   G.Axes(xlValue).MajorUnit = Divi
   G.PlotArea.Fill.UserPicture PictureFile:=ChNomF
   G.CopyPicture
   GphIsoEchelles G
   End If
End Sub
'

Function FichierProduitParAPI(Img As Image) As Boolean
Dim BmAPI As BITMAP, AdresseMap As Long, TbOct() As Byte
Tâche "Production de l'image (plan A)", XbmMax * YbmMax
On Error Resume Next
Img.Picture = LoadPicture(ChNomF)
If Err Then
    AbandonTâche "nouveau fichier": FichierProduitParAPI = False: Exit Function: End If
On Error GoTo 0
If GetObject(Img.Picture, Len(BmAPI), BmAPI) = 0 Then
    AbandonTâche "objet non obtenu": FichierProduitParAPI = False: Exit Function: End If
With BmAPI
   If .bmWidth <> XbmMax Or .bmHeight <> YbmMax Or .bmBitsPixel <> 24 Then
      AbandonTâche "caractéristiques image trop différentes"
      FichierProduitParAPI = False: Exit Function: End If
   LgL = .bmWidthBytes: AdresseMap = .bmBits: End With
ReDim TbOct(1 To LgL * YbmMax) As Byte
For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
   Enrg = TE(Xbm, Ybm): Chal = TH(Xbm, Ybm): Gaît = TJ(Xbm, Ybm)
   Call CalcÉngEHJ: CalcRVBÉLi
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 1) = Round(Bleu)
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 2) = Round(Vert)
   TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + 3) = Round(Roug)
   Call OùÇaEnEst: Next Ybm: Next Xbm
MoveAM DstA:=AdresseMap, Source:=TbOct(1), L:=UBound(TbOct)
On Error Resume Next
SavePicture Img.Picture, ChNomF
If Err Then
   AbandonTâche "écriture impossible"
   MsgBox "La méthode SavePicture plante :" & vbLf & Err.Description, vbExclamation, NomTâche
   FichierProduitParAPI = False
Else
   FichierProduitParAPI = True: End If
End Function
'

Sub ÉcrireFichierBMP()
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, InStrRev(ChNomF, ".") - 1), "BitMaps,*.bmp", Title:=NomTâche)
   If Va = False Then AbandonTâche "réf. fichier non fournie": Succès = False: Exit Sub
   ChNomF = Va
   Range("RéfFicSor").Value = Replace(ChNomF, "\", vbLf, InStrRev(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 Integer: XRempliss = LgL - 3 * XbmMax
For Ybm = 1 To YbmMax
   Seek #1, LgE + LgL * (YbmMax - Ybm) + 1
   For Xbm = 1 To XbmMax
      Enrg = TE(Xbm, Ybm): Chal = TH(Xbm, Ybm): Gaît = TJ(Xbm, Ybm)
      Call CalcÉngEHJ: CalcRVBÉLi
      Put #1, , CByte(Int(Bleu + 0.5))
      Put #1, , CByte(Int(Vert + 0.5))
      Put #1, , CByte(Int(Roug + 0.5))
      Call OùÇaEnEst: Next Xbm
   Oct = 0: For Xbm = 1 To XRempliss: Put #1, , Oct: Next Xbm
   Next Ybm
Close #1
Succès = True
End Sub
Sub ÉcrireCanAlpha()
   Const BM As String * 2 = "BM": Dim Alpha As Byte
   Open "C:\Users\Luck\Pictures\CanAlpha.bmp" For Binary Access Write As #1 Len = 1
   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 Integer: XRempliss = LgL - 3 * XbmMax
   For Ybm = 1 To YbmMax
      Seek #1, LgE + LgL * (YbmMax - Ybm) + 1
      For Xbm = 1 To XbmMax
         Alpha = CByte(Int(255 * TA(Xbm, Ybm) + 0.5))
         Put #1, , Alpha: Put #1, , Alpha: Put #1, , Alpha
         Next Xbm
      Oct = 0: For Xbm = 1 To XRempliss: Put #1, , Oct: Next Xbm
      Next Ybm
   Close #1
   Shell "C:\Users\Luck\PhotoFiltre7\PhotoFiltre7 ""C:\Users\Luck\Pictures\CanAlpha.bmp""", vbNormalNoFocus
   End Sub
'

Function ImageChargéeParAPI(Img As Image) 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, C As Long
Outils.Tâche "Chargement de l'image (plan A)", XbmMax * YbmMax
hDC = GetObjectType(Img.Picture)
If hDC <> 7 Then
   AbandonTâche "Type d'image non supporté"
   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(Img.Picture, Len(BmAPI), BmAPI) = 0 Then
   AbandonTâche "Impossible d'analyser cette image"
   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
NbPixÀFaire = XbmMax * YbmMax
ReDim PxBrut(1 To 3, 1 To XbmMax, 1 To YbmMax) As Byte
ReDim TbOct(1 To LgL * YbmMax) As Byte
MoveMA TbOct(1), SrcA:=AdresseMap, L:=UBound(TbOct)
If BitPx = 24 Then
   For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
      For C = 1 To 3: PxBrut(C, Xbm, Ybm) = TbOct(3 * (Xbm - 1) + LgL * (YbmMax - Ybm) + C): Next C
      Outils.OùÇaEnEst: Next Ybm: Next Xbm
   ImageChargéeParAPI = True
ElseIf BitPx = 8 Or BitPx = 4 Then
   hDC = CreateCompatibleDC(0)
   hObjectOld = SelectObject(hDC, Img.Picture)
   If GetDIBColorTable(hDC, 0, 256, Pal(0)) = 0 Then
      AbandonTâche "Palette de couleur inaccessible"
      MsgBox "Palette de couleur inaccessible cette image " & BitPx & " bits / pixel, vbExclamation, NomTâche"
      ImageChargéeParAPI = False: Exit Function: End If
   For Xbm = 1 To XbmMax: For Ybm = 1 To YbmMax
      If BitPx = 8 Then
         N°Coul = TbOct(Xbm + LgL * (YbmMax - Ybm))
      Else
         N°Coul = TbOct((Xbm + 1) \ 2 + LgL * (YbmMax - Ybm))
         If Xbm And &H1 Then N°Coul = N°Coul \ 16 Else N°Coul = N°Coul And &HF
         End If
      With Pal(N°Coul)
         PxBrut(1, Xbm, Ybm) = .rgbBlue
         PxBrut(2, Xbm, Ybm) = .rgbGreen
         PxBrut(3, Xbm, Ybm) = .rgbRed: End With
      Outils.OùÇaEnEst: Next Ybm: Next Xbm
   SelectObject hDC, hObjectOld 'Obligatoire parce que c'est comme ça.
   DeleteDC hDC
   ImageChargéeParAPI = True
Else
   MsgBox "Image " & BitPx & " bits / pixel non supportée", vbExclamation, NomTâche
   ImageChargéeParAPI = False: End If
End Function
'
Sub MàJImage(ByVal Img As MSForms.Image)
Dim Ech As Double, Forme As Shape
Img.Picture = LoadPicture(ChNomF)
Set Forme = Img.Parent.Shapes("Img")
On Error Resume Next
Ech = Img.Parent.[EchMinia].Value * 3 / 4
If Err Then Exit Sub
'Forme.Width = XbmMax * Ech
'Forme.Height = YbmMax * Ech
Img.Width = XbmMax * Ech
Img.Height = YbmMax * Ech
End Sub

Sub ShellPhotoEd()
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
'Shell "C:\Program Files\Fichiers communs\Microsoft Shared\PhotoEd\PHOTOED.EXE """ & ChNomF & """", vbNormalNoFocus
'Shell "C:\Windows\System32\mspaint.exe """ & ChNomF & """", vbNormalNoFocus
Shell "C:\Program Files\paint.net\PaintDotNet.exe """ & ChNomF & """", vbNormalNoFocus
End Sub
Sub ShellPhotoFiltre()
ChNomF = Replace(Range("RéfFicSor").Value, vbLf, "\")
Shell "C:\Users\Luck\PhotoFiltre7\PhotoFiltre7 """ & ChNomF & """", vbNormalNoFocus
End Sub

C'est surtout la Sub ÉcrireFichierBMP() qui est intéressante. Elle part de 3 tableaux As double TE, TH, et TJ, aux dimensions de l'image à partir desquel sont calculés des codes de couleurs selon les mêmes calculs que ceux effectués dans mon CouleurCls.xlsm (disponible en téléchargement).

Démentiel ! Nettement au-delà de mes petites compétences!

Dranreb · 2 Octobre 2022

Bonjour.

Staple1600 à dit:
J'ai une erreur ici quand je lance EcrireFichierBMP
…
Type défini par l'utilisateur non défini

Insère un nouvel UserForm que tu supprimera ensuite. Il s'agit sans nul doute de MSForms.Image
Je ne peux pas joindre ce classeur, il est énorme, et en perpétuelle évolution, avec 44 feuille. Je le bricole chaque fois que je veux fabriquer une nouvelle image de bouton par exemple.
De plus il a en référence un classeur de macro lui aussi énorme.
Le mieux serait je pense que j'équipe un de vos classeur de quoi fabriquer un .bmp
Ou alors que vous me décriviez quel classeur à possibilités limitées vous intéresserait.

Staple1600 · 2 Octobre 2022

Bonjour Dranreb

On pourrait partir sur l'exemple du message#53
(Je republie le code ici pour faciliter la facture)

VB:

Sub Dessiner_Julia()
Application.ScreenUpdating = False
Range("C3:HL141").Interior.Color = vbBlack
Calculs
Mise_En_Forme
End Sub
Sub Calculs()
[B1] = 0.0002: [D3] = 0.2: [C4] = 0.3
[E3:HK3].Formula = "=D3+$B$1": [C5:C140].Formula = "=C4-$B$1": [D4:HK140].Formula = "=JULIA(D$3,$C4)"
[C5].CurrentRegion = [C5].CurrentRegion.Value
End Sub

Sub Mise_En_Forme()
Dim Julia As Range
Set Julia = Range("D4:HK140")
Julia.ColumnWidth = 0.35: Julia.RowHeight = 3.5
Julia.FormatConditions.AddColorScale ColorScaleType:=3
Julia.FormatConditions(Julia.FormatConditions.Count).SetFirstPriority
Julia.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
Julia.FormatConditions(1).ColorScaleCriteria(1).FormatColor.Color = vbRed
Julia.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
Julia.FormatConditions(1).ColorScaleCriteria(2).Value = 50
Julia.FormatConditions(1).ColorScaleCriteria(2).FormatColor.Color = vbYellow
Julia.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
Julia.FormatConditions(1).ColorScaleCriteria(3).FormatColor.Color = vbGreen
ActiveWindow.Zoom = 50
End Sub
Function Julia(x, y) As Integer
Dim Modulo, z_reel, z_imag, z_carre_reel, z_carre_imag As Double
Dim n As Integer
n = 0
Modulo = 0
z_reel = x
z_imag = y
Do While (n < 200 And Modulo < 2)
z_carre_reel = z_reel ^ 2 - z_imag ^ 2
z_carre_imag = 2 * z_reel * z_imag
z_reel = z_carre_reel - 0.7927
z_imag = z_carre_imag + 0.1609
Modulo = Sqr(z_reel ^ 2 + z_imag ^ 2)
n = n + 1
Loop
Julia = n
End Function

Je cherche effectivement à m'affranchir des cellules et de passer par des tableaux mais là cela dépasse mes compétences (notamment au niveau des mathématiques)

Ou alors si vous pouvez publier un extrait de votre classeur, ce serait chouette
1) Génération d'une "fractale" et une seule (Julia ou Mandelbrot)
2) Export en fichier *.BMP

Dranreb · 2 Octobre 2022

Pourrais-je avoir un classeur, que je puisse voir où on saisit l'échelle, les dimensions de l'image, le centre (si décentré) et les parties réelle et imaginaire du complexe caractéristique de l'ensemble voulu ?
Un bmp à palette serait-il souhaité ?

Staple1600 · 2 Octobre 2022

Re

@Dranreb
Le code VBA ne suffit-il pas ?
(en tout cas pour l'exemple que j'ai posté dans ce fil)
Je remets le code VBA sans utiliser les balises SPOILER
Il suffit de copier/coller tout le code VBA dans un classeur vierge
et de lancer la macro Dessiner_Julia
En B1, se trouve le pas pour calculer les valeurs de la partie réelle de z0 en [E3:HK3] et en [C5:C140] les valeurs de la partie imaginaire.

VB:

Sub Dessiner_Julia()
Application.ScreenUpdating = False
Range("C3:HL141").Interior.Color = vbBlack
Calculs
Mise_En_Forme
End Sub
Sub Calculs()
[B1] = 0.0002: [D3] = 0.2: [C4] = 0.3
[E3:HK3].Formula = "=D3+$B$1": [C5:C140].Formula = "=C4-$B$1": [D4:HK140].Formula = "=JULIA(D$3,$C4)"
[C5].CurrentRegion = [C5].CurrentRegion.Value
End Sub

Sub Mise_En_Forme()
Dim Julia As Range
Set Julia = Range("D4:HK140")
Julia.ColumnWidth = 0.35: Julia.RowHeight = 3.5
Julia.FormatConditions.AddColorScale ColorScaleType:=3
Julia.FormatConditions(Julia.FormatConditions.Count).SetFirstPriority
Julia.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
Julia.FormatConditions(1).ColorScaleCriteria(1).FormatColor.Color = vbRed
Julia.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
Julia.FormatConditions(1).ColorScaleCriteria(2).Value = 50
Julia.FormatConditions(1).ColorScaleCriteria(2).FormatColor.Color = vbYellow
Julia.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
Julia.FormatConditions(1).ColorScaleCriteria(3).FormatColor.Color = vbGreen
ActiveWindow.Zoom = 50
End Sub
Function Julia(x, y) As Integer
Dim Modulo, z_reel, z_imag, z_carre_reel, z_carre_imag As Double
Dim n As Integer
n = 0
Modulo = 0
z_reel = x
z_imag = y
Do While (n < 200 And Modulo < 2)
z_carre_reel = z_reel ^ 2 - z_imag ^ 2
z_carre_imag = 2 * z_reel * z_imag
z_reel = z_carre_reel - 0.7927
z_imag = z_carre_imag + 0.1609
Modulo = Sqr(z_reel ^ 2 + z_imag ^ 2)
n = n + 1
Loop
Julia = n
End Function

Un bmp à palette serait-il souhaité ?

Je réponds oui (sans forcément savoir ce qu'est un bmp à palette)

Il faut que je retourne consulter votre outil CouleurCls pour me rafraichir la mémoire.

Dranreb · 2 Octobre 2022

Un bmp à palette est à 256 valeurs différentes par pixel (1 octet donc par pixel) correspondant à des codes couleurs indiqués dans une table au début. c'est cette table qui constitue la palette.

Staple1600 · 2 Octobre 2022

Re

Précisions
Je parcoure beaucoup de sites relatifs aux fractales, à Mandelbrot etc..
Mais mes lacunes en mathématiques et en programmation m'empêchent d'utiliser les outils plus adaptés qu'Excel.

Donc pour le moment, je me contente de tester ou reproduire ce que je comprends en VBA dans Excel.

Staple1600 · 2 Octobre 2022

Re

@Dranreb
En relisant l'article que je cite au message#53, je viens de m'apercevoir qu'il y a un fichier Excel à disposition
Voici donc le lien vers ce classeur

http://revue.sesamath.net/IMG/xls/fractales.xls

[Digressions] Shapes your booty, Fractales et consorts...

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

garnote

XLDnaute Junior

garnote

XLDnaute Junior

Dranreb

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc