XL 2016 Rotation continue d'une image autour d'axe y et à l'ouverture de fichier

lakriti said

XLDnaute Nouveau
Bonjour à tous ;

j'aimerais boucler mon macro qui permet de faire la rotation de logo (image s'appelle "Logo") de notre entreprise OCP d'une façon permanant et à l'ouverture de fichier excel "DA IN PROCESS" dans la feuille "Data" et voila mon macro



Public Sub Workbook_Open()

Dim n As Integer

Worksheets("Data").Activate
ActiveSheet.Shapes("Logo").LockAspectRatio = False
n = 5
#If VBA7 Then
n = 10
#End If
GrowShape ActiveSheet.Shapes("Logo"), n
SpinShape ActiveSheet.Shapes("Logo"), n

End Sub

Function SpinShape(ByRef Shape As Shape, Step As Integer) As Boolean
' Description:Expands a shape into view
' Parameters: Shape The shape to animate
' Step Larger #s animate faster
' Steps should divide 90 evenly
' Example: SpinShape ActiveSheet.Shapes("Logo"), 10
' Date Ini Modification
' 01/10/11 CWH Initial Programming
' 12/08/13 CWH XL2013 Compatibility

Const Pi = 3.14159265358979
Dim sng01 As Single '1 Degree in Radians
sng01 = Pi / 180

Dim lCenterX As Long 'Shape's center X coordinate
Dim lCenterY As Long 'Shape's center Y coordiante
Dim lWidth As Long 'Shape's width
Dim lHeight As Long 'Shape's height
Dim l As Long 'Generic Counter for the loop

With Shape
.LockAspectRatio = False
'Remember shape's original dimensions
lCenterX = .Width / 2 + .Left
lCenterY = .Height / 2 + .Top
lWidth = .Width
lHeight = .Height
Shape.Visible = True
'Animation Loop
For l = 0 To 360 Step Step
.Width = lWidth * Abs(Cos(l * sng01))
.Left = lCenterX - .Width / 2
If l = 90 Or l = 270 Then .Flip msoFlipHorizontal
DoEvents
Next l
'Restore shape's original dimensions
.Width = lWidth
.Height = lHeight
.Left = lCenterX - .Width / 2
.Top = lCenterY - .Height / 2
End With
End Function

Function GrowShape(ByRef Shape As Shape, Step As Integer) As Boolean

Dim lCenterX As Long 'Shape's center X coordinate
Dim lCenterY As Long 'Shape's center Y coordiante
Dim lWidth As Long 'Shape's width
Dim lHeight As Long 'Shape's height
Dim l As Long 'Generic Counter for the loop

With Shape
'Remember shape's original dimensions
lCenterX = .Width / 2 + .Left
lCenterY = .Height / 2 + .Top
lWidth = .Width
lHeight = .Height
Shape.Visible = True
'Animation Loop
For l = 0 To lWidth Step Step
.Width = l
.Height = l * lHeight / lWidth
.Left = lCenterX - .Width / 2
.Top = lCenterY - .Height / 2
DoEvents
Next l
'Restore shape's original dimensions
.Width = lWidth
.Height = lHeight
.Left = lCenterX - .Width / 2
.Top = lCenterY - .Height / 2
End With

End Function
 

Pièces jointes

  • DA IN PROCESS.xlsm
    104.1 KB · Affichages: 21
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Ben déjà mettre la Public Sub Workbook_Open() en Private Sub Workbook_Open() mais dans le module ThisWorkbook et non dans le module de l'objet Worksheet représentant la feuille. Dans ce dernier vous pourriez à la rigueur mettre une Worksheet_Activate qui fait la même chose.
 

Modeste geedee

XLDnaute Barbatruc
Bonsour®
Bonjour à tous ;

j'aimerais boucler mon macro qui permet de faire la rotation de logo (image s'appelle "Logo") de notre entreprise OCP d'une façon permanant et à l'ouverture de fichier excel "DA IN PROCESS" dans la feuille "Data"
supprime les macros concernées déjà existantes
dans le module "Thisworkbook "
inserer ce code :
VB:
Private Sub Workbook_Deactivate()
anime = False
Application.OnTime earliesttime = NextTime, procedure:="macro1", schedule:=False
End Sub

Private Sub Workbook_Open()
anime = True
Macro1
End Sub
dans un module standard
inserer ce code
VB:
Public NextTime As Double, anime As Boolean
Sub Macro1()
Dim x As Integer, logo As Shape
Set logo = ActiveSheet.Shapes("Logo")
For x = 1 To 360 Step 10
                logo.ThreeD.RotationX = x
                DoEvents
    Next
   NextTime = Now + TimeValue("00:00:02")
   If anime = True Then Application.OnTime NextTime, "macro1"
End Sub
Sub Logo_Cliquer()
anime = Not anime
Call Macro1
End Sub

l'animation démarre dés l'ouverture

l'arret ou re-demarrage de l'animation ce fait par un click sur le logo
 

Pièces jointes

  • DA IN PROCESS (1).xlsm
    102.7 KB · Affichages: 28

Discussions similaires