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

Créer une discussion
Répondre
  • 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 !

S'inscrire
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) 😉
 
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
 
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

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! 😱
(Il est jamais trop tôt pour faire de l'art ou l'Excel 😉)
 
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
 
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
 
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
 
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é
 
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

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
 
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:
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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