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

  • Initiateur de la discussion Initiateur de la discussion Staple1600
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

J'ai un plaisir fou à fréquenter ce site et bien sûr, c'est grâce à vous tous. Vos merveilles de macros, votre humour et toujours prêts à me venir en aide. Merci!
 

Pièces jointes

  • Fractale ED.PNG
    Fractale ED.PNG
    20.8 KB · Affichages: 8
Bonjour tout le monde,

Étant donné que chaque macro R_90, RV, RH, DP et DS contient ce même bout de code :

ReDim x(1 To n)
For Each cel In ici
i = i + 1
x(i) = cel.Interior.ColorIndex
Next cel

n'y aurait-il pas moyen d'éviter ces répétitions en confiant ce bout-là à une autre macro
qu'il me suffirait d'appeler? Et ci-joint mon fichier "Collection de fractales", renommé
et légèrement modifié. Promis, la dernière fois que je vous achale avec ça! 🙄
 

Pièces jointes

J'ai essayé, mais sans succès! 😭
Tu as peut-être oublié de déclarer x() en variable globale. 😉

Pour info, chez moi ça sembler fonctionner sans problème.
VB:
Dim cel As Range
Dim ici As Range
Dim n As Long
Dim c As Long
Dim x() As Variant


Sub Départ()
    Set ici = Selection
    n = ici.Cells.Count
    c = Sqr(n)
    ReDim x(1 To n)
    For Each cel In ici
        i = i + 1
        x(i) = cel.Interior.ColorIndex
    Next cel
End Sub

Sub Identité()
'    Hahaha! Une macro qui ne fait rien.
    Application.ScreenUpdating = False
End Sub

Sub R_90()
    Application.ScreenUpdating = False
    Départ
    For i = c To 1 Step -1
        For j = 1 To c
            v = i + (j - 1) * c
            k = k + 1
            ici.Cells(k).Interior.ColorIndex = x(v)
        Next j
    Next i
End Sub

2022-09-30 025450.png
 
Dernière édition:
Tu as peut-être oublié de déclarer x() en variable globale. 😉

Pour info, chez moi ça sembler fonctionner sans problème.
VB:
Dim cel As Range
Dim ici As Range
Dim n As Long
Dim c As Long
Dim x() As Variant


Sub Départ()
    Set ici = Selection
    n = ici.Cells.Count
    c = Sqr(n)
    ReDim x(1 To n)
    For Each cel In ici
        i = i + 1
        x(i) = cel.Interior.ColorIndex
    Next cel
End Sub

Sub Identité()
'    Hahaha! Une macro qui ne fait rien.
    Application.ScreenUpdating = False
End Sub

Sub R_90()
    Application.ScreenUpdating = False
    Départ
    For i = c To 1 Step -1
        For j = 1 To c
            v = i + (j - 1) * c
            k = k + 1
            ici.Cells(k).Interior.ColorIndex = x(v)
        Next j
    Next i
End Sub

Merci, c'est en plein ça. Un nouveau Départ! 🙂 . Je songe sérieusement à arrêter de picoler! 😉
Et en passant, ton "Il y a 10 sortes de personnes : celles qui comprennent le binaire,
celles qui ne le comprennent pas." a fait un tabac sur Facebook! 🙂
 
Dernière édition:
Et en passant, ton "Il y a 10 sortes de personnes : celles qui comprennent le binaire,
celles qui ne le comprennent pas." a fait un tabac sur Facebook! 🙂
Ce n'est malheureusement pas de moi. ☹️

Je suis tombé, la semaine dernière, sur un gars (sur un autre forum) qui avait à peu près la même signature : ça disait la même chose mais tourné différemment. 😉
 
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 😉
 
Dernière édition:
Bonjour le fil,

Donnez-lui ses gouttes !!:
Il recommence
VB:
Sub ito_Presto()
Application.ScreenUpdating = False
Range("A1:IW128").Clear
Cells.ColumnWidth = 2
Triangulons_un_1er_Octobre
Application.ScreenUpdating = True
End Sub
Sub Triangulons_un_1er_Octobre(Optional Waclaw_Franciszek_Sierpinski As String = "CéBO!")
Dim SunShine_Baby
Randomize 1600
SunShine_Baby = Choose(Int(7 * Rnd + 1), vbBlack, vbRed, vbBlue, vbGreen, vbYellow, vbMagenta, vbWhite)
Dim r As Range: Set r = Range("B2:IW128"): [DZ1] = 1
With r
    .Formula = "=IF(SUM(A1:C1)=1,1,"""")"
    .Value = .Value
        With .Offset(-1).Resize(128)
            .FormatConditions.Add 1, 3, "=1"
            .FormatConditions(1).Interior.Color = SunShine_Baby
        End With
End With
ActiveWindow.Zoom = 20
End Sub
PS: C'est la faute à @garnote au m'a fait replongé en réveillant cette discussion 😉
 
Bonjour.
Une de mes vieilles images :
1664635626792.png

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).
 
Bonjour Dranreb

Cela ressemble à l'ensemble de Julia, non ?

Et oui, bien sûr que je serais (et sans doute ceux qui passent dans ce fil) intéressé par cette routine et ce classeur.

Bienvenue dans ce fil 😉
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Retour