Accueil ouverture

Le 07/07/2018 à 21:49

Bonsoir le forum

Je viens vous demandé un peu d'aide sur une idée pour ma feuille accueil

J’ai une image dans le centre de ma feuille accueil

Ce que je recherche à faire sais comment faire apparaitre tout autour de mon image centrale les images que j’ai en feuille 2 toute les 8 secondes enfin je ne sais pas si j’ai été assez clair

Mais vous avait fait déjà beaucoup, de miracle dans ce forum

avec tout mes remercîments

GINA

15essaie-01.xlsm (82.23 Ko)
Le 08/07/2018 à 09:06

Bonjour,

Regardes si c'est ce que tu cherches, pour le test, la durée est de une seconde. Je poste le code et le classeur en retour :

Dim Toupie As Shape
Dim Centre As Shape

Dim PosGauche As Single
Dim PosHaut As Single
Dim Rayon As Single
Dim Diametre As Single
Dim Gauche As Single
Dim Haut As Single
Dim Arc As Single
Dim Angle As Single

Dim I As Integer
Dim Max As Integer

Dim Arret As Boolean

Const Pi As Single = 3.14159265358979

Sub Arreter()

    Dim S As Shape

    Set S = ActiveSheet.Shapes("BtnArret")

    Arret = Not Arret

    S.TextFrame.Characters.Text = IIf(Arret = True, "Marche", "Arrêt")

End Sub

Sub Demarrer()

    Set Toupie = ActiveSheet.Shapes("Base")
    Set Centre = ActiveSheet.Shapes("Image 1")

    Gauche = Centre.Left - Toupie.Width
    Haut = Centre.Top - Toupie.Width
    Diametre = Centre.Width + Toupie.Width * 2

    Rayon = Diametre / 2 'rayon

    'tout les 30 degrés
    Max = 12

    'longueur de l'arc
    Arc = Diametre * Pi / Max

    'angle découlant de la longueur de l'arc
    Angle = Arc / Rayon

    'appel de la sub pour la rotation autour de l'image
    Manege 1

End Sub

Sub Manege(I As Integer)

    If Arret = True Then Exit Sub

    If I = 13 Then I = 1

    PosGauche = Gauche + Rayon + (Rayon + 20) * Sin(Angle * I + (Angle / 2)) - Toupie.Width / 2
    PosHaut = Haut + (Rayon - (Rayon + 20) * Cos(Angle * I + (Angle / 2))) - Toupie.Width / 2

    Toupie.Left = PosGauche
    Toupie.Top = PosHaut

    'récursive (elle se rappelle elle même) adapter les secondes, ici 1 seconde
    Application.OnTime Now + TimeValue("00:00:01"), "'Manege " & I + 1 & "'"

End Sub
16essaie-01.xlsm (92.96 Ko)
Le 08/07/2018 à 14:50

bonjour le forum ,THEZE

telle un magicien

MERCI belle réalisation cela est bien mais je recherche comment faire apparaitre l'image 1, suite image 2 suite l'image 3 suite 4 et 5 et 6 7 8 . car j'aurais 8 icone mais dans le même principe mettre tout aux tour et en automatique sans les boutons si possibles

enfin si cela est réalisable

avec tout mes remerciements

14essaie-01v.xlsm (92.96 Ko)
Le 08/07/2018 à 16:26

Re,

Voici le code modifié et le classeur en retour !

Les boutons sont là pour le test, le démarrage et l'arrêt peuvent être réalisés de différentes manières mais comme je n'en sais pas plus pour l'instant, là dessus je ne peux pas t'aider. Pour ce qui concerne les huit pictogrammes, j'attend aussi de tous les avoir mais pour l'instant je l'ai fais pour les trois disponibles :

Dim TblShape(1 To 3) As Shape 'trois pour l'instant puisqu'il n'y en a pas plus !
Dim Centre As Shape

Dim TblPos(1 To 3) As Integer 'fonction du nombre d'objets en satellite
Dim PosGauche As Single
Dim PosHaut As Single
Dim Rayon As Single
Dim Diametre As Single
Dim Gauche As Single
Dim Haut As Single
Dim Arc As Single
Dim Angle As Single

Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim Max As Integer

Dim Arret As Boolean

Const Pi As Single = 3.14159265358979

Sub Arreter()

    Dim S As Shape

    Set S = ActiveSheet.Shapes("BtnArret")

    Arret = Not Arret

    S.TextFrame.Characters.Text = IIf(Arret = True, "Marche", "Arrêt")

End Sub

Sub Demarrer()

    'les trois disponibles pour l'instant et renommés pour plus de clarté !
    Set TblShape(1) = ActiveSheet.Shapes("Base")
    Set TblShape(2) = ActiveSheet.Shapes("Soins")
    Set TblShape(3) = ActiveSheet.Shapes("Pharma")

    Set Centre = ActiveSheet.Shapes("Image 1")

    Gauche = Centre.Left - TblShape(1).Width
    Haut = Centre.Top - TblShape(1).Width
    Diametre = Centre.Width + TblShape(1).Width * 2

    Rayon = Diametre / 2

    'tout les 30 degrés
    Max = 12

    'longueur de l'arc
    Arc = Diametre * Pi / Max

    'angle découlant de la longueur de l'arc
    Angle = Arc / Rayon

    I = 0
    'appel de la sub pour la rotation autour de l'image
    Manege 1

End Sub

Sub Manege(I As Integer)

    Dim Tbl() As Single

    If Arret = True Then Exit Sub

    If I = Max + 1 Then I = 1

    J = I + 1
    If J = Max + 1 Then J = 1

    K = J + 1
    If K = Max + 1 Then K = 1

    Tbl() = Position(I)
    PosGauche = Tbl(1): PosHaut = Tbl(2)

    TblShape(1).Left = PosGauche: TblShape(1).Top = PosHaut

    Tbl() = Position(J)
    PosGauche = Tbl(1): PosHaut = Tbl(2)

    TblShape(2).Left = PosGauche: TblShape(2).Top = PosHaut

    Tbl() = Position(K)
    PosGauche = Tbl(1): PosHaut = Tbl(2)

    TblShape(3).Left = PosGauche: TblShape(3).Top = PosHaut

    'récursive (elle se rappelle elle même) adapter les secondes, ici 1 seconde
    Application.OnTime Now + TimeValue("00:00:01"), "'Manege " & I + 1 & "'"

End Sub

Function Position(Pos As Integer) As Single()

    Dim Tbl(1 To 2) As Single

    Tbl(1) = Gauche + Rayon + (Rayon + 20) * Sin(Angle * Pos + (Angle / 2)) - TblShape(1).Width / 2
    Tbl(2) = Haut + (Rayon - (Rayon + 20) * Cos(Angle * Pos + (Angle / 2))) - TblShape(1).Width / 2

    Position = Tbl()

End Function
14essaie-01-v2.xlsm (94.72 Ko)
Le 08/07/2018 à 18:19

Re,

Je reviens sur ton post car j'ai modifié mon code afin d'y inclure les huit Shapes. Pour qu'il fonctionne, tes huit Shapes doivent avoir le même préfixe à savoir "Picto" puis ils doivent être numérotés de cette façon Picto1, Picto2, Picto3, etc... (jusqu'à 8). Voici le code et en bas le classeur dont j'ai multiplié tes Shapes pour en avoir huit (petite précision au cas où, le code fonctionne quand le titre du bouton "Marche/Arrêt" est sur "Arrêt") :

Dim TblShape(1 To 8) As Shape 'pour les huit objets
Dim Centre As Shape

Dim TblPos(1 To 8) As Integer 'fonction du nombre d'objets en satellite

Dim PosGauche As Single
Dim PosHaut As Single
Dim Rayon As Single
Dim Diametre As Single
Dim Gauche As Single
Dim Haut As Single
Dim Arc As Single
Dim Angle As Single

Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim Max As Integer

Dim Arret As Boolean

Const Pi As Single = 3.14159265358979

Sub Arreter()

    Dim S As Shape

    Set S = ActiveSheet.Shapes("BtnArret")

    Arret = Not Arret

    S.TextFrame.Characters.Text = IIf(Arret = True, "Marche", "Arrêt")

End Sub

Sub Demarrer()

    'les huit Shapes ont leur nom qui commence par "Picto" et sont numéroté de 1 à 8 (Picto1, Picto2, Pict3, etc...)
    'afin de simplifier le code avec la boucle ci-dessous
    For I = 1 To 8: Set TblShape(I) = ActiveSheet.Shapes("Picto" & I): Next I

    'rien de changé
    Set Centre = ActiveSheet.Shapes("Image 1")

    'les Shape sont sensés avoir la même taille donc le 1er sert de référence
    Gauche = Centre.Left - TblShape(1).Width
    Haut = Centre.Top - TblShape(1).Width
    Diametre = Centre.Width + TblShape(1).Width * 2

    Rayon = Diametre / 2

    'avec une valeur de 8, les Shapes s'interchange à leur position
    'plus la valeur sera grande, plus ils seront proche les uns des autres
    Max = 8

    'longueur de l'arc
    'ici, la variable pourrait être supprimée mais je la laisse pour plus de compréhension dans le calcul de l'angle
    Arc = Diametre * Pi / Max

    'angle découlant de la longueur de l'arc
    Angle = Arc / Rayon

    I = 0
    'appel de la sub pour la rotation autour de l'image
    Manege I

End Sub

Sub Manege(I As Integer)

    Dim Tbl() As Single
    Dim L As Integer

    If Arret = True Then Exit Sub

    'initialise la première position...
    TblPos(1) = I

    'puis crée les positions suivantes pour les différents Shapes
    For L = 1 To 7

        If TblPos(L) = Max + 1 Then TblPos(L) = 1
        TblPos(L + 1) = TblPos(L) + 1

    Next L

    'calcul du point supérieur gauche et positionnement des Shapes
    For L = 1 To 8

        Tbl() = Position(TblPos(L))
        PosGauche = Tbl(1): PosHaut = Tbl(2)
        TblShape(L).Left = PosGauche: TblShape(L).Top = PosHaut

    Next L

    'récursive (elle se rappelle elle même) adapter les secondes, ici 1 seconde
    Application.OnTime Now + TimeValue("00:00:01"), "'Manege " & I + 1 & "'"

End Sub

Function Position(Pos As Integer) As Single()

    Dim Tbl(1 To 2) As Single

    Tbl(1) = Gauche + Rayon + (Rayon + 20) * Sin(Angle * Pos + (Angle / 2)) - TblShape(1).Width / 2
    Tbl(2) = Haut + (Rayon - (Rayon + 20) * Cos(Angle * Pos + (Angle / 2))) - TblShape(1).Width / 2

    Position = Tbl()

End Function
23essaie-01-v3.xlsm (96.50 Ko)
Le 08/07/2018 à 21:51

bonsoir le forum THESE

BELLE réalisation vraiment superbe peux ton les faire venir les un après les autres avec un délais entre eux

sinon sais bien se que je cherchais a faire

encore un grand merci pour ton aide et ta magie

amicalement

Le 09/07/2018 à 07:06

Bonjour,

peux ton les faire venir les un après les autres avec un délais entre eux

Oui, on peux, il suffit de les rendre invisibles et les faire apparaître les uns après les autres.

Remplace tout le code par celui-ci-dessous (c'est plus simple que de chercher les lignes ajouter), je ne re-poste pas le classeur puisque tu l'as déjà. J'ai passé le temps d'apparition à 8 secondes. Dans la Sub "Manege()", j'ai mis les commentaires pour les lignes qui concernent l'apparition des Shapes, en fonction de celle choisie, le Shape qui apparaît le fait soit devant soit derrière ceux qui sont déjà visibles. En ce qui concerne la mise en route automatique et l'arrêt du manège, ça peux se faire par exemple sur les procédures événementielles "Activate" et "Deactivate" du classeur :

Dim TblShape(1 To 8) As Shape 'pour les huit objets
Dim Centre As Shape

Dim TblPos(1 To 8) As Integer 'fonction du nombre d'objets en satellite

Dim PosGauche As Single
Dim PosHaut As Single
Dim Rayon As Single
Dim Diametre As Single
Dim Gauche As Single
Dim Haut As Single
Dim Arc As Single
Dim Angle As Single

Dim I As Integer
Dim J As Integer
Dim Max As Integer

Dim Arret As Boolean

Const Pi As Single = 3.14159265358979

Sub Arreter()

    Dim S As Shape

    Set S = ActiveSheet.Shapes("BtnArret")

    Arret = Not Arret

    S.TextFrame.Characters.Text = IIf(Arret = True, "Marche", "Arrêt")

End Sub

Sub Demarrer()

    'les huit Shapes ont leur nom qui commence par "Picto" et sont numéroté de 1 à 8 (Picto1, Picto2, Pict3, etc...)
    'afin de simplifier le code avec la boucle ci-dessous
    For I = 1 To 8

        Set TblShape(I) = ActiveSheet.Shapes("Picto" & I)
        TblShape(I).Visible = msoFalse '<--- cache les Shapes

    Next I

    'rien de changé
    Set Centre = ActiveSheet.Shapes("Image 1")

    'les Shape sont sensés avoir la même taille donc le 1er sert de référence
    Gauche = Centre.Left - TblShape(1).Width
    Haut = Centre.Top - TblShape(1).Width
    Diametre = Centre.Width + TblShape(1).Width * 2

    Rayon = Diametre / 2

    'avec une valeur de 8, les Shapes s'interchange à leur position
    'plus la valeur sera grande, plus ils seront proche les uns des autres
    Max = 8

    'longueur de l'arc
    'ici, la variable pourrait être supprimée mais je la laisse pour plus de compréhension dans le calcul de l'angle
    Arc = Diametre * Pi / Max

    'angle découlant de la longueur de l'arc
    Angle = Arc / Rayon

    I = 0
    J = 9

    'appel de la sub pour la rotation autour de l'image
    Manege I

End Sub

Sub Manege(I As Integer)

    Dim Tbl() As Single
    Dim L As Integer

    If Arret = True Then Exit Sub

    'initialise la première position...
    TblPos(1) = I

    'puis crée les positions suivantes pour les différents Shapes
    For L = 1 To 7

        If TblPos(L) = Max + 1 Then TblPos(L) = 1
        TblPos(L + 1) = TblPos(L) + 1

    Next L

    'avec la ligne ci-dessous, celui qui apparaît le fait devant les autres
    'pour cette ligne, J doit être initialisé à 0 dans la sub "Demarrer()"
    'J = J + 1: If J = 9 Then J = 1

    'avec la ligne ci-dessous, celui qui apparaît le fait derrière les autres
    'pour cette ligne, J doit être initialisé à 9 dans la sub "Demarrer()"
    J = J - 1: If J = 0 Then J = 1

    'calcul du point supérieur gauche et positionnement des Shapes
    For L = 1 To 8

        Tbl() = Position(TblPos(L))
        PosGauche = Tbl(1): PosHaut = Tbl(2)
        TblShape(L).Left = PosGauche: TblShape(L).Top = PosHaut
        TblShape(J).Visible = msoTrue '<--- rendu visible ici !

    Next L

    'récursive (elle se rappelle elle même) adapter les secondes, ici 1 seconde
    Application.OnTime Now + TimeValue("00:00:08"), "'Manege " & I + 1 & "'"

End Sub

Function Position(Pos As Integer) As Single()

    Dim Tbl(1 To 2) As Single

    Tbl(1) = Gauche + Rayon + (Rayon + 20) * Sin(Angle * Pos + (Angle / 2)) - TblShape(1).Width / 2
    Tbl(2) = Haut + (Rayon - (Rayon + 20) * Cos(Angle * Pos + (Angle / 2))) - TblShape(1).Width / 2

    Position = Tbl()

End Function
Rechercher des sujets similaires à "accueil ouverture"