Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Staple1600

XLDnaute Barbatruc
Bonsoir Modeste geedee

Si on peut le faire, alors faisons le
Mais je ne suis pas le plus matheux d'entre vous (hélas) pour ce faire.
Ce genre de choses est trop compliquée pour moi.

Geometry of the 4x4 Square

Geometry of the 4x4 square
finitegeometry.org
(même en français)
 

Staple1600

XLDnaute Barbatruc
Bonsoir le fil

L'abus de confinement nuit gravement à mon Excel
Je vous laisse juge de la chose
(Si vous avez d'autres jolis points dans l'Array, n'hésitez point )
VB: 
Sub De_L_Amour_De_L_Art_Ou_Du_Cochon()
Dim shp As Shape, i&, j&, k&, X&
ActiveSheet.DrawingObjects.Delete
Dim points(1 To 10, 1 To 2) As Single
Randomize 1600
X = Application.RandBetween(5, 22)
For k = 1 To X
For i = 1 To UBound(points, 1)
For j = 1 To UBound(points, 2)
points(i, j) = Application.RandBetween(17, 467)
Next j
Next i
Application.ScreenUpdating = False
Set shp = ActiveSheet.Shapes.AddCurve(SafeArrayOfPoints:=points)
shp.Line.ForeColor.RGB = RGB(255 * Rnd, 166 * Rnd, 255 * Rnd)
shp.SoftEdge.Type = msoSoftEdgeType6
shp.Fill.ForeColor.RGB = RGB(255 * Rnd, 255 * Rnd, 122 * Rnd)
shp.ThreeD.PresetMaterial = Application.RandBetween(1, 15)
Next
ActiveSheet.DrawingObjects.Group.Name = "OCBO"
Set shp = ActiveSheet.Shapes("OCBO")
shp.Glow.Transparency = 0.96
shp.Glow.Radius = 2
[A1:I33].Interior.Color = RGB(65 * Rnd, 255 * Rnd, 255 * Rnd)
shp.BackgroundStyle = Application.RandBetween(1, 11)
shp.IncrementLeft 23.25
shp.IncrementTop 9.75
Set shp = Nothing
Application.ScreenUpdating = True
End Sub
 

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
 

David Aubert

XLDnaute Barbatruc
Administrateur
Modérateur
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
 
Identifiez-vous ou inscrivez-vous pour participer.
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…