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

Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour mapomme

J'étais plutôt B.Lenoir que G.Lang
Et comme disait Frank Zappa
“Un pays n’existe pas s’il ne possède pas sa bière et une compagnie aérienne.
Eventuellement, il est bien qu’il possède également une équipe de football et l’arme nucléaire mais ce qui compte surtout c’est la bière.”
Moi, je possède juste le temps qu'offre le confinement (pour faire du ménage sur mon HD et/ou baguenauder dans les méandres de la WWW (et non pas la WRTL) ;)
 
Staple1600

Staple1600

XLDnaute Barbatruc
Bonsoir David

Excel n'est forcément le meilleur outil surtout si on s'amuse avec des Shapes.
Puisque tu apprécies les fractales, je te laisse tester ce petit bout de code. ;)
VB: 
Sub Test()
dessin 290#, 15#, -280#: TSier 6, 10#, 15#, 280#
ActiveSheet.DrawingObjects.Group.Name = "TriA"
ActiveSheet.Shapes("TriA").Line.ForeColor.RGB = RGB(255, 0, 0)
[A2:E21].Interior.Color = vbBlack
End Sub

Private Sub dessin(X, Y, L)
Dim vPi, shp As Shape, f As Worksheet: Set f = ActiveSheet
vPi = WorksheetFunction.Pi()
X1 = X: X2 = X + L: X3 = X + L / 2
Y1 = 300 - Y: Y2 = 300 - (Y - L * Sin(60 * vPi / 180))
Set shp = f.Shapes.AddLine(X1, Y1, X2, Y1)
Set shp = f.Shapes.AddLine(X1, Y1, X3, Y2)
Set shp = f.Shapes.AddLine(X2, Y1, X3, Y2)
End Sub

Private Sub TSier(N, X, Y, L)
Dim vPi
vPi = WorksheetFunction.Pi()
H = L * Sin(60 * vPi / 180)
dessin X + L / 4, Y + H / 2, L / 2
If N = 0 Then Exit Sub
TSier N - 1, X, Y, L / 2
TSier N - 1, X + L / 2, Y, L / 2
TSier N - 1, X + L / 4, Y + H / 2, L / 2
End Sub
 
Modeste geedee

Modeste geedee

XLDnaute Barbatruc
Bonsour®
Staple1600 à dit:
Bonjour le fil
Mathématiquement futile...
Cliquez pour agrandir...

Mathématiquement déficient .
faute d'un monde rieur ...
voici un MONDRIAN ;)

VB: 
Sub Pietcolor()
Dim PIET As Range, cell As Range, colonne As Range, ligne As Range
Application.ScreenUpdating = False
Randomize
Set PIET = Range("C1:R16")
For Each cell In PIET
cell.Interior.Color = Choose(1 + (Rnd() * 6), vbBlack, vbYellow, vbWhite, vbBlue, vbRed, vbWhite)
cell.Borders.Weight = xlThick
Next
For Each colonne In PIET.Columns
colonne.ColumnWidth = Rnd() * 12
Next
For Each ligne In PIET.Rows
ligne.RowHeight = Rnd() * 60
Next
Application.ScreenUpdating = True

End Sub
 

Pièces jointes

  • Mondrian.xlsm
    25 KB · Affichages: 14
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil, Modeste geedee

Je vous laisse voir dans Excel ce que produit ce petit bout de code
(un indice: voir le message#33)
VB: 
Dim AngD, dAng
Sub dessin()
Application.ScreenUpdating = False
mt 350, 425, 170, AngD
[C2:J29].Interior.Color = vbBlack
End Sub
Private Function mt(xA, yA, p, a)
Dim f As Worksheet, shp As Shape: Set f = ActiveSheet
Pi = WorksheetFunction.Pi
AngD = 1.5 * Pi
dAng = 0.2 * Pi
If p >= 1# Then
xB = xA + p * Cos(a)
yB = yA + p * Sin(a)
Set shp = f.Shapes.AddLine(xA, yA, xB, yB)
mt xB, yB, p * 0.6, a + dAng
mt xB, yB, p * 0.6, a - dAng
End If
End Function

•>Modeste geedee
Piet Mondrian n'avait pas Excel pour l'aider.
Son talent suffisait.
Je viens d'aller lire sa page Wikipédia.
Merci pour ton passage et ta contribution de 2h28! :eek:
(Il est jamais trop tôt pour faire de l'art ou l'Excel ;))
 
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil

Sorti des entrailles de mes vielles archives.
(Celles du temps des modems 56k ou pire des téléchargements sur cassettes audio par le biais du minitel ;))
(çà sent un peu la disquette 5 pouces ;), avec des bouts de Qbasic dedans)
J'ai mis tout cela dans le caquelon d'Excel.
C'est noir ou blanc ;)
VB: 
Sub Re_confinement_Amusements()
Dim rng As Range: Set rng = [A1:LH321]
rng.RowHeight = 0.75: rng.ColumnWidth = 0.08: rng.Interior.Color = vbWhite
Dim vArr(1 To 320, 1 To 320)
SC = InputBox("Saisir un chiffre entre 3 et 9", "Formes étoilées", 4)
Application.ScreenUpdating = False: ActiveSheet.DrawingObjects.Delete
For i = 1 To 320
  For j = 1 To 320
      A = i / SC
      C = Int(A * Sqr(A * j / SC) + 0.5)
        If C / 2 <> Int(C / 2) Then
        vArr(j, i) = 0
        End If
    Next j
  Next i
rng.Value = vArr
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=ET(A1=0;A1<>"""")"
rng.FormatConditions(1).Interior.Color = vbBlack
rng.Copy: ActiveSheet.Pictures.Paste.Select
rng.Clear: rng.RowHeight = 15: rng.ColumnWidth = 10.71: Cells(1).Select
End Sub
 
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil

• Hervé (merci d'être passé dans le fil ;)
Peut-être adoras-tu aussi ceci?
VB: 
Sub Dessiner_Rose_de_Maurer_en_Shapes()
Dim f As Worksheet: Set f = ActiveSheet
Dim shp As Shape
Randomize 1600
With Application
    .ScreenUpdating = False
    f.DrawingObjects.Delete: n = 6: d = 71
    For i = 0 To 360 Step 0.5
    k1 = i * d: k2 = (i + 1) * d
    r1 = 265 * Sin(.Radians(n * k1)): r2 = Sin(.Radians(n * k2)) * 265
    x1 = r1 * Cos(.Radians(k1)) + 450: y1 = r1 * Sin(.Radians(k1)) + 300
    x2 = r2 * Cos(.Radians(k2)) + 450: y2 = r2 * Sin(.Radians(k2)) + 300
    Set shp = f.Shapes.AddLine(x1, y1, x2, y2)
    shp.Line.Weight = 0.01: shp.Line.ForeColor.RGB = RGB(128, 0, 128): shp.Line.DashStyle = 11
    Next
End With
'Plus de détails ici:
'http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.97.8141&rep=rep1&type=pdf
End Sub
 
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Une dernière pour la route
(Le confinement me fait faire de ces choses dans mon tableur ;))
VB: 
Sub limation_Triangulaire()
Application.ScreenUpdating = False
Sierpinski
Coloriage
End Sub
Private Sub Coloriage()
Dim r As Range: Set r = [A1:IV256]
r.RowHeight = 0.75: r.ColumnWidth = 0.08: r.Interior.Color = vbWhite
r.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1"
r.FormatConditions(1).Interior.Color = vbBlack
r.Copy
ActiveSheet.Pictures.Paste.Select
r.Clear
r.Item(1).Select
End Sub
Private Sub Sierpinski()
For X = 0 To 255
For Y = 0 To 255
Cells(X + 1, (X And Y) + 1) = 1
Next Y
Next X
End Sub
 
Hervé

Hervé

XLDnaute Barbatruc
salut staple

j'adore la simplicité de la fractale triangle, on place des 1 on rajoute un format condi, et on colle en image

c'est super malin

bravo

hervé
 
garnote

garnote

XLDnaute Junior
Staple1600 à dit:
Re

Une dernière pour la route
(Le confinement me fait faire de ces choses dans mon tableur ;))
VB: 
Sub limation_Triangulaire()
Application.ScreenUpdating = False
Sierpinski
Coloriage
End Sub
Private Sub Coloriage()
Dim r As Range: Set r = [A1:IV256]
r.RowHeight = 0.75: r.ColumnWidth = 0.08: r.Interior.Color = vbWhite
r.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1"
r.FormatConditions(1).Interior.Color = vbBlack
r.Copy
ActiveSheet.Pictures.Paste.Select
r.Clear
r.Item(1).Select
End Sub
Private Sub Sierpinski()
For X = 0 To 255
For Y = 0 To 255
Cells(X + 1, (X And Y) + 1) = 1
Next Y
Next X
End Sub
Cliquez pour agrandir...
Salut,
Super! et quelques jours plus tard :) , une autre façon de procéder.
Bonne soirée!
 

Pièces jointes

  • Triangle fractal.xlsm
    18.9 KB · Affichages: 3
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour @garnote

Trés malin cette autre façon

Cela m'a donné envie de sortir mes crayons de couleurs
VB: 
Sub TriangleSierpinski()
Randomize 1600
    ActiveWindow.DisplayGridlines = False
    Efface
    Application.ScreenUpdating = False
    Range("A1,A2,B2").Interior.ColorIndex = Application.RandBetween(1, 56) ' ma boite de crayons
    For i = 1 To 6
        j = 2 ^ i
        With ActiveSheet.Range(Cells(1, 1), Cells(j, j))
            .Copy Cells(j + 1, 1)
            .Copy Cells(j + 1, j + 1)
        End With
    Next i
    With Cells
        .ColumnWidth = 0.35
        .RowHeight = 3.5
    End With
    [EE133].Select
    Application.ScreenUpdating = True
End Sub
 
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour le fil

@garnote
C'est malin, tu m'as fait replonger dans la Matrice ;)
Une autre autre façon
VB: 
Sub Triangulons_nos_Cellules()
Dim R As Range: Set R = Range("B2:BM65"): R.Clear
    With R
        .Clear: .Item(1) = 1
        .Offset(1).Resize(R.Rows.Count - 1).FormulaR1C1 = "=MOD(R[-1]C+R[-1]C[-1],2)"
        .FormatConditions.Add 1, 3, "=0": .FormatConditions(1).SetFirstPriority
        .FormatConditions(1).Interior.Color = vbBlue: .FormatConditions.Add 1, 3, "=1"
        .FormatConditions(2).SetFirstPriority: .FormatConditions(1).Interior.Color = vbYellow
        .ColumnWidth = 0.35: .RowHeight = 3.5
    End With
End Sub

PS: @Modeste geedee merci pour le passage réactionnel ;)
 
Dernière édition:

Membres actuellement en ligne

13 membres et 93 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 091
Messages
2 116 111
Membres
112 662
dernier inscrit
lou75