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

Staple1600

XLDnaute Barbatruc
Bonsoir mapomme

Justement, tu n'aurais point quelques formules mathématiques pour remplir points avec des points "remarquables"?
Ou de jolis exemples avec Shapes.AddPolyline
 

Staple1600

XLDnaute Barbatruc
Re

On doit pouvoir des choses plus mathématiques, non?
VB:
Sub Tu_me_feras_100_lignes_sur_papier_à_petits_KRO()
Dim s As Shape, shp As Shape, i&, a, pts() As Single
a = Array(1, 2, 3, 4, 5, 7)
ReDim pts(200, 1): Randomize 1600
ActiveSheet.DrawingObjects.Delete
For i = 30 To 199
pts(i, 0) = Application.RandBetween(30, 888)
pts(i, 1) = Application.RandBetween(30, 555)
Next
Set s = ActiveSheet.Shapes.AddPolyline(pts)
s.Fill.TwoColorGradient a(Application.RandBetween(1, 5)), 1
s.Fill.BackColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
s.Fill.ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
s.Line.ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
s.Fill.GradientStops.Insert RGB(255, 48, 111), 0.37
s.Fill.GradientStops.Insert RGB(200, 96, 255), 0.7
s.Glow.Transparency = 0.96: s.Glow.Radius = 3
[A1:O45].Interior.Color = RGB(127 * Rnd, 0, 77 * Rnd)
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonjour mapomme

Nous sommes dans le digressif.
Il n'est pas nécéssaire d'accrocher, non ?
Mais tu as raison, ma journée de télétravail commence à 9ALT+0160heures ;)
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

Question: Aurais-je pondu ce VBA sans le confinement?
Sans doute pas.
Et cela aurait été dommage, non ? ;)
Car c'est joli, mignon, tout plein ;)
Et ça égayera votre Excel le soir à la veillée ;)
VB:
Sub testAA()
Dim Px, s As Shape: Randomize 1600
ActiveSheet.DrawingObjects.Delete
Px = Application.RandBetween(3, 7): [A1:K40].Interior.Color = vbBlack
Staple_Gribouille 0.67654, Px, msoThemeColorAccent4
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Line.DashStyle = msoLineSysDot
s.Glow.Transparency = 0.89: s.Glow.Radius = 3
s.IncrementLeft 75: s.IncrementTop 25: s.Flip 1
End Sub
Sub testBB()
Dim Px, s As Shape: Randomize 1600
ActiveSheet.DrawingObjects.Delete
Px = Application.RandBetween(3, 7): [A1:K40].Interior.Color = vbBlack
Staple_Gribouille 0.67654, Px, msoThemeColorDark2
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Line.DashStyle = msoLineSysDot
s.Glow.Transparency = 0.89: s.Glow.Radius = 3
s.IncrementLeft 75: s.IncrementTop 25: s.Flip 1
End Sub
Sub testCC()
Dim Px, s As Shape: Randomize 1600
ActiveSheet.DrawingObjects.Delete
Px = Application.RandBetween(3, 7): [A1:K40].Interior.Color = vbBlack
Staple_Gribouille 1.33, Px, msoThemeColorLight1, 125
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Line.DashStyle = msoLineSysDashDot
s.Line.ForeColor.RGB = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
s.IncrementLeft 75: s.IncrementTop 25: s.Flip 0
End Sub

Private Sub Staple_Gribouille(PaK, ItO, Them As MsoThemeColorIndex, Optional s As Integer = 2 ^ 7)
Dim b, c, d, g, n%, i%, r As Double, shp As Shape, p() As Single
n = s: c = (Sqr(ItO) + 1) / 2: ReDim p(n, 1)
For i = 0 To n Step PaK
r = i ^ c / (n / 5): g = 1.75 * 3.141592656 * c * i
p(i, 0) = r + Cos(g) * 2 * i: p(i, 1) = r - Sin(g) * 2 * i
Next
Set shp = ActiveSheet.Shapes.AddPolyline(p)
shp.Fill.ForeColor.ObjectThemeColor = Them
End Sub
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

Dans la série: Trop de confinement dénature mon Excel ;)
Mais au moins, si c'est futile, c'est joli, non ?

VB:
Sub Gribouille_1()
ActiveSheet.DrawingObjects.Delete
Corona_Yeah_But_No_Virus 5, 8, msoLineLongDashDotDot
End Sub
Sub Gribouille_2()
ActiveSheet.DrawingObjects.Delete
Corona_Yeah_But_No_Virus msoShapeRegularPentagon, 6
End Sub
Sub Gribouille_3()
ActiveSheet.DrawingObjects.Delete
Corona_Yeah_But_No_Virus msoShapeRound2SameRectangle, 10, msoLineSquareDot
End Sub
Sub Gribouille_4()
ActiveSheet.DrawingObjects.Delete
Corona_Yeah_But_No_Virus msoShape4pointStar, 6, , msoLineThinThick
End Sub
Private Sub Corona_Yeah_But_No_Virus(Figure As MsoAutoShapeType, _
                        Optional Pas_Rotation As Integer = 4, _
                        Optional x As MsoLineDashStyle = 1, _
                        Optional y As MsoLineStyle = 1)
Dim shp As Shape, i%, j%
Set shp = ActiveSheet.Shapes.AddShape(Figure, 200, 100, 350, 350)
With shp
  .Fill.Visible = 0:  .Line.Weight = 0.65: .Line.DashStyle = x: .Line.Style = y:: .Line.Visible = -1
 For i = 0 To 359 \ Pas_Rotation
    With .Duplicate
       .Left = shp.Left: .Top = shp.Top
       .IncrementRotation (i * Pas_Rotation) Mod 360
       .Line.ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 255 * Rnd)
      End With
 Next
 End With
End Sub
 
Bonjour JM, bonjour à tous,
Excellentes ces macros!!
Mon préféré c'est Gribouille 2 ;)
Bonne journée

Edit : finalement ce sont les résultats générés par la macro en post 22 que je préfère.
Le rendu est top, bravo JM!
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil, Bonsoir David

Adapté d'un code en Small Basic.
VB:
Sub Spirale()
Dim shp As Shape, f As Worksheet: Set f = ActiveSheet
Dim c As Double, X As Double, Y As Double, graines As Double
c = (Sqr(5) + 1) / 2: graines = 3000
For i = 0 To graines
    r = WorksheetFunction.Power(i, c) / graines
    Angle = 2 * WorksheetFunction.PI() * c * i
    vWH = i / graines * 10
    X = r * Sin(Angle) + 200: Y = r * Cos(Angle) + 200
        With f.Shapes.AddShape(msoShapeOval, X, Y, vWH, vWH)
            .Fill.Visible = 0: .Line.Weight = 0.25
        End With
Next
End Sub
Toujours dans le domaine du digressif, futile mais joli.
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil, David ;), mapomme ;)

Mathématiquement futile, et un petit hommage à Maïtena Douménach (en passant)
(adapté d'un code VisualBasic, glané jadis sur une page web de l'Empire du Milieu)
VB:
Sub il_a_Neigé_sur_Yesterday()
FRK 130, 230, 190, 334: FRK 190, 334, 250, 230: FRK 250, 230, 130, 230
ActiveSheet.DrawingObjects.Group.Name = "Koch"
With ActiveSheet.Shapes("Koch")
    .LockAspectRatio = -1: .ScaleHeight 3, 0, 0
    .IncrementLeft -70.5: .IncrementTop -177
    .Line.ForeColor.ObjectThemeColor = 14
End With
[A1:H30].Interior.Color = vbBlack
End Sub
Private Sub FRK(aX As Single, aY As Single, bX As Single, bY As Single)
Dim cX!, cY!, dX!, dY!, eX!, eY!, l!, alpha!, shp As Shape
vPI = WorksheetFunction.PI()
If (bX - aX) * (bX - aX) + (bY - aY) * (bY - aY) < 10 Then
    Set shp = ActiveSheet.Shapes.AddLine(aX, aY, bX, bY)
Else
cX = aX + (bX - aX) / 3: cY = aY + (bY - aY) / 3: eX = bX - (bX - aX) / 3: eY = bY - (bY - aY) / 3
l = Sqr((eX - cX) * (eX - cX) + (eY - cY) * (eY - cY)): alpha = Atn((eY - cY) / (eX - cX))
        If (alpha >= 0 And (eX - cX) < 0) Or (alpha <= 0 And (eX - cX) < 0) Then
            alpha = alpha + vPI
        End If
    dY = cY + Sin(alpha + vPI / 3) * l: dX = cX + Cos(alpha + vPI / 3) * l
    FRK aX, aY, cX, cY: FRK eX, eY, bX, bY: FRK cX, cY, dX, dY: FRK dX, dY, eX, eY
End If
End Sub
 

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

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

XLDnaute Barbatruc
Bonsour®
Bonjour le fil
Mathématiquement futile...
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
 

Fichiers joints

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 ;))
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Discussions similaires

Haut Bas