Mohair et chinoiseries

Bonjour Bonjour à tous et à toutes,

J'espère que tout va bien pour vous.
Voici quelques macros pour le plaisir et
pour fêter ma retraite. C'est, ma foi, assez zoli!

Bien bonne et belle journée,
Serge





Public Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Dim octo1 As Shape, octo2 As Shape
Dim cercle1 As Shape, cercle2 As Shape
Dim ligne1 As Shape, ligne2 As Shape

Sub Phénomènes_De_Moiré()

'Si vous lancez cette macro, une animation vous
'attend. Par la suite, vous pourrez sélectionner
'et déplacer les formes à votre guise.
'Si vous déplacez une forme sur une autre forme
'avec les flèches de direction, vous obtiendrez
'd'autres phénomènes de moiré animés.

Dim i As Integer, rep As Integer
Dim n() As Variant

'Je mets le curseur en forme de sablier
Application.Cursor = xlWait
'Pas de rafraîchissement, plein écran et
'contrôle des interruptions. Vous pouvez
'arrêter l'animation avec Escape ou
'Ctrl+Pause. Vous aurez alors le choix
'de continuer ou pas.
With Application
.ScreenUpdating = False
.DisplayFullScreen = True
.EnableCancelKey = xlErrorHandler
End With
'Remarque trouvée chez MONSIEUR Walkenbach:
'Pour que les procédures de gestion d'erreurs puissent
'fonctionner, le paramètre "Arrêt sur toutes les erreurs"
'doit être désactivé. Dans l'éditeur de VB, choisissez
'Outils/Options et cliquez sur l'onglet Général dans la
'boîte de dialogue d'options. Si "Arrêt sur toutes les
'erreurs" est sélectionné, VBA ignore votre code de
'gestion d'erreurs.
On Error GoTo FIN
'J'ajoute une feuille
Sheets.Add
'Je fais disparaître le quadrillage et les en-têtes
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With

With ActiveSheet 'Le plus gros With de ma vie ;-)

'Entre les étiquettes 1 et 100, je construis deux groupes
'd'octogones concentriques, deux groupes de cercles
'concentriques et deux groupes de lignes parallèles.
1:
ReDim n(1 To 20)
'Je construis 20 octogones
For i = 1 To 20
Set octo = _
.Shapes.AddShape(msoShapeOctagon, 1, 1, 10 * i - 5, 10 * i - 5)
n(i) = i
Next i
'Je confie les octogones à la macro Emboîter
Emboîter .Shapes.Range(n)
'Je groupe les octogones
Set octo1 = .Shapes.Range(n).Group
'Je confie le groupe d'octogones à la macro Placer
Placer octo1, 207, 15, 8
'Je copie le groupe octo1 et je le place
Set octo2 = octo1.Duplicate
Placer octo2, 7, 215, 10
ReDim n(3 To 22)
'Je construis 20 cercles
For i = 1 To 20
Set cercle = _
.Shapes.AddShape(msoShapeOval, 1, 1, 10 * i - 5, 10 * i - 5)
n(i + 2) = i + 2
Next i
'Je les emboîte
Emboîter .Shapes.Range(n)
'Je les groupe
Set cercle1 = .Shapes.Range(n).Group
'Je les place
Placer cercle1, 7, 15, 12
'Je copie le groupe cercle1 et je le place
Set cercle2 = cercle1.Duplicate
Placer cercle2, 408, 15, 14
'Je construis deux groupes de lignes parallèles.
'La distance séparant deux lignes d'un groupe
'est légèrement différente de celle séparant
'deux lignes de l'autre groupe. C'est ce petit
'décalage qui engendre un phénomène de moiré
'quand on superpose les groupes de lignes.
ReDim n(5 To 44)
For i = 1 To 40
Set ligne = .Shapes.AddLine(5 * i + 5, 10, 5 * i + 5, 150)
ligne.Line.Weight = 2
n(i + 4) = i + 4
Next i
Set ligne1 = .Shapes.Range(n).Group
Placer ligne1, 230, 242, 8
ReDim n(6 To 39)
For i = 1 To 34
Set ligne = .Shapes.AddLine(6 * i + 4, 10, 6 * i + 4, 150)
ligne.Line.Weight = 2
n(i + 5) = i + 5
Next i
Set ligne2 = .Shapes.Range(n).Group
Placer ligne2, 432, 242, 10
100:
'Pour voir l'animation
Application.ScreenUpdating = True
'Petite pause
Sleep (100)
'ANIMATION. Si sa vitesse ne vous convient pas,
'modifiez l'argument du Sleep.
With cercle1
For i = 7 To 506
.Left = i
DoEvents
Sleep (20)
Next i
Sleep (200)
.Left = 7
.Top = 15
End With
With ligne2
For i = 430 To 297 Step -1
.Left = i
DoEvents
Sleep (20)
Next i
Sleep (200)
.Left = 432
'Je copie le groupe ligne2 et je fais
'pivoter cette copie de 15 degrés
With .Duplicate
.IncrementRotation 15
.Left = 226
.Top = 242
End With
End With
End With 'Fin du With ActiveSheet, il était temps!

MsgBox "Vous pouvez maintenant composer vos propres motifs et les" _
& vbLf & "animer en déplaçant des formes avec les flèches de direction." _
, , " Fin de l'animation"
'Un exemple de motifs
gauche = Array(28, 288, 286, 29, 28, 284, 27)
haut = Array(14, 16, 111, 15, 257, 209, 257)
With ActiveSheet
For i = 1 To 7
.Shapes(i).Left = gauche(i - 1)
.Shapes(i).Top = haut(i - 1)
Next i
.Shapes(4).Select
End With
Application.Cursor = xlDefault
Exit Sub

FIN:
If Err = 18 Then
rep = MsgBox("Désirez-vous continuer ?", vbYesNo, " Interruption")
If rep = vbYes Then Resume
End If
Application.Cursor = xlDefault
MsgBox "Vous pouvez maintenant composer vos propres motifs et les" _
& vbLf & "animer en déplaçant des formes avec les flèches de direction." _
, , " Fin de l'animation"

'garnote, juin 2005
End Sub

Sub Emboîter(forme As Object)
With forme
.Align msoAlignCenters, False
.Align msoAlignMiddles, False
.Fill.Visible = msoFalse
.Line.Weight = 2
End With
End Sub

Sub Placer(forme As Object, gauche As Single, haut As Single, couleur As
Byte)
With forme
.Left = gauche
.Top = haut
.Line.ForeColor.SchemeColor = couleur
End With
End Sub

Sub Yin_Yang()
Dim i As Byte, j As Byte, k As Byte, l As Byte
Dim m As Byte, n As Byte, c As Byte, p As Byte
Dim lig As Byte, col As Byte
Dim couleurs As Variant
Dim patente As Range
With Application
.ScreenUpdating = False
.DisplayFullScreen = True
End With
Sheets.Add
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
With Cells
.ColumnWidth = 2
.RowHeight = 4
End With
Rows(4).RowHeight = 12
For i = 21 To 105 Step 14
Rows(i).RowHeight = 10
Next i
For i = 5 To 31 Step 4
Columns(i).ColumnWidth = 4
Next i
[A500].Select
With ActiveWindow
.ScrollColumn = 1
.ScrollRow = 1
End With
For i = 0 To 1
For j = 0 To 1
For k = 0 To 1
For l = 0 To 1
For m = 0 To 1
For n = 0 To 1
c = c + 1
col = (4 * c - 1) Mod 32
lig = 14 * WorksheetFunction.RoundUp(c / 8, 0) - 5
For p = 1 To 6
Cells(lig + 2 * (p - 1), col).Interior.ColorIndex = _
Choose(p, i, j, k, l, m, n)
Cells(lig + 2 * (p - 1), col - 1).Interior.ColorIndex = 1
Cells(lig + 2 * (p - 1), col + 1).Interior.ColorIndex = 1
Next p
Next n
Next m
Next l
Next k
Next j
Next i
With [B4]
.Value = "Les 64 hexagrammes du I Ching"
.Font.Size = 11
.Font.Bold = True
End With
[B4:AF4].HorizontalAlignment = xlCenterAcrossSelection
Application.ScreenUpdating = True
Sleep (500)
couleurs = Array(3, 4, 5, 7, 1)
For i = 0 To 4
Application.ScreenUpdating = False
ActiveWindow.Zoom = 110 + 10 * i
For Each patente In Range("B9:AF117")
If patente.Interior.ColorIndex <> xlNone Then _
patente.Interior.ColorIndex = couleurs(i)
Next patente
[B4].Font.ColorIndex = couleurs(i)
Application.ScreenUpdating = True
If i < 4 Then Sleep (500)
Next i
'garnote, juin 2005
End Sub

Sub Curseur()
'Si par malheur vous restez coincé avec le sablier,
'cliquez ici avec le sablier et tapez sur F5.
'Ou associez un raccourci à cette macro.
Application.Cursor = xlDefault
End Sub