UN GRAPHIQUE 3D TOUT EN MOUVEMENT

Dans l'objet Thisworkbook

'Macro Creee par : BigFish_le Vrai (Philippe E)
'le :13-08-2008
'V2.3
'
'
'
'Permet de Remplir ou vider les modules de classe a l'ouverture
'ou lors des changements de feuille

Option Explicit

Dim Feuille As Worksheet

Private Sub Workbook_Open()
    Set Feuille = Worksheets("Graph 3D")
    Set XlAppli.XL = Excel.Application
    Call XlAppli.InitClass(Feuille)
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call XlAppli.InitClass(Sh)
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    Call XlAppli.EmptyClass(Sh)
End Sub
---------------------------------------------------------------------------

---------------------------------------------------------------------------
Dans le module1 :

'Macro Creee par : BigFish_le Vrai (Philippe E)
'le :15-08-2008
'V2.6
'
Option Explicit

Public XlAppli As New ClasseAppli
---------------------------------------------------------------------------

---------------------------------------------------------------------------
Dans le module de classe ClasseAppli :

'Macro Creee par : BigFish_le Vrai (Philippe E)
'le :13-08-2008
'V2.3
'
Option Explicit

Public WithEvents XL As Excel.Application
Dim ClTabChart() As ClasseChart


'Permet de vider la classe
Public Sub EmptyClass(ByVal Feuille As Object)
    Dim j As Integer
    On Error Resume Next
    For j = 1 To UBound(ClTabChart)
        Set ClTabChart(j).Graph = Nothing
    Next
End Sub
 'remplissage de la classe
Public Sub InitClass(ByVal Feuille As Object)
    Dim i As Integer
    'on verifi que c'est bien une feuille
    If TypeOf Feuille Is Worksheet Then
        'on regarde si il y a des graphique dans la feuille
        If Feuille.ChartObjects.Count = 0 Then Exit Sub
        'S'il y a bien un ou plusieurs graphiques,
        'on les injectes dans le module de classe
        ReDim Preserve ClTabChart(Feuille.ChartObjects.Count)
        For i = 1 To Feuille.ChartObjects.Count
            Set ClTabChart(i) = New ClasseChart
            Set ClTabChart(i).Graph = Feuille.ChartObjects(i).Chart
            Set ClTabChart(i).ParentSheet = Feuille
        Next i
    End If
End Sub
---------------------------------------------------------------------------

---------------------------------------------------------------------------
Dans le module de classe ClasseChart :

'Macro Creee par : BigFish_le Vrai (Philippe E)
'le :29-09-2008
'V2.7
'Merci à PCPT(VBFRANCE) pour les corrections
'
Option Explicit

'permet de recuperer la position en x,y du pointeur de souris
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type
Dim PositionCursor As POINTAPI

'permet de detecter l'etat des touches du clavier
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Const VK_LSHIFT As Long = &HA0 'touche shift de Gauche
Private Const VK_RSHIFT As Long = &HA1 'touche shift de Droite

Private Const MaxAngle As Integer = 360 'valeur limite maxi en rotation
Private Const MaxElevation As Integer = 90 'valeur limite maxi en elevation

Dim KeyTest As Boolean, AngleRotation As Integer, GraphElevation As Integer
Dim CursorOrigineX As Integer, CursorOrigineY As Integer, GraphOrigineX As Integer, GraphOrigineY As Integer

Public ParentSheet As Worksheet
Public WithEvents Graph As Chart

Private Sub Graph_BeforeRightClick(Cancel As Boolean)
    ' desactive le menu contextuel du graphique qui apparait lors d'un clic droit
    ' ici il sera desactive si la touche shift est enfoncee
    If ShiftKeyStat() = True Then Cancel = True
End Sub

'ici on detecte un clic droit ou gauche dans le graphique
Private Sub Graph_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
    'si clic il y a :
    Call GraphMotion
End Sub

Private Function ShiftKeyStat() As Boolean
    'permet de détecter si les touches shift de droite ou de gauche sont enfoncees
    ShiftKeyStat = False 'remise a false avant vérif.
    If GetKeyState(VK_LSHIFT) < 0 Or GetKeyState(VK_RSHIFT) < 0 Then ShiftKeyStat = True
End Function

' ---------------------------------------------
' ce code est appele si un clic sur le graph a ete detecte par
' l'evenement Mouse_down de la classe Classechart
' ce code permet :
' - de lancer le déplacement du graphique si la touche shift est
'   enfoncé lors du clic.
' - de calculer les valeurs de déplacement.
' ----------------------------------------------
Private Sub GraphMotion()

    Dim NomGraph As String, NbRotationX As Long
    
    NbRotationX = 0

    ' Dans le cas d'un deuxieme passage on passe cette variable a false
    ' pour stopper la boucle do loop
    If KeyTest = True Then KeyTest = False '***donc si false on fait rien? donc on met false de toute manière...
    ' ben en faite tous s'arretera à la boucle do/loop... ouai ce n'est peut etre pas tres propre...
    ' un exit sub aurai pu faire l'affaire mais je le sent pas car cela n'arreterait pas
    ' l'eventuelle premiere boucle en cours... ou alors associé au false pourquoi pas, mais rajouter
    ' une ligne exit sub alors que le false ce suffit à lui meme... J'sais pô !
    
    'si une des touches shift est enfoncée on demarre le deplacement
    If ShiftKeyStat() = True Then
        'cette variable vas nous permetre de sortir de la boucle
        KeyTest = ShiftKeyStat()
        'on recupere le nom du graphique activé
        'NomGraph = Right(ActiveChart.Name, Len(ActiveChart.Name) - Len(ActiveSheet.Name) - 1)
        NomGraph = Right$(Me.Graph.Name, Len(Me.Graph.Name) - Len(Me.ParentSheet.Name) - 1)
        
        'ici ce trouve toute la subtilite qui permet le deplacement
        '  sans clignotement du graphique :
        'pour demarrer nous avions besoin que le graphique soit activé
        'et dans ce cas c'est lui qui a le focus. Ors, dans cette situation,
        'lors du déplacement du pointeur de souris et a cause de la fonction
        'GetCursorPos, le focus vas alterner entre la fenetre principale d'excel
        'et le graphique ce qui provoquera le clignotement.
        'Mais on ne peut hélas pas travailler sur un graphique qui n'est pas
        'au minimum sélectionne.
        'Donc l'astuce consiste simplement a sélectionner une cellule pour
        'desactiver le graphique et donc lui enlever le focus, puis a le
        'selectionner tout de suite apres. La subtilite est qu'un graphique
        'selectionne n'a pas le focus a contrario d'un graphique active. ouf!...
        Me.ParentSheet.[A1].Select
        Me.ParentSheet.ChartObjects(NomGraph).Select
        
        'on recupere toutes les positions d'origines
        GraphOrigineX = ActiveChart.Rotation 'angle actuel du graph
        GraphOrigineY = ActiveChart.Elevation 'elevation actuelle du graph
        GetCursorPos PositionCursor 'on recupere la position X,Y du pointeur de souris
        CursorOrigineX = PositionCursor.x
        CursorOrigineY = PositionCursor.y
        
        'on a le clic... la touche [shift] est enfoncee alors on y va...
        Do Until KeyTest = False
            ' si la touche shift est relachee on sort de la boucle en changeant l'etat de la variable KeyTest
            If ShiftKeyStat() = False Then KeyTest = False

            'le deplacement ce fait par l'incementation positive ou negative des valeurs d'origines de position du graphique.
            'l'incrementation ce fait a partir d'un point 0 qui est le point du clique souris
            '
            'on recupere la position X,Y du poiteur de souris
            GetCursorPos PositionCursor
            'calcul de l'angle de rotation a partir de l'angle d'origine et de la position d'origine du clique
            '+ prise en compte de la valeur de zoom
            AngleRotation = GraphOrigineX + (CursorOrigineX - PositionCursor.x) * (1 + (ActiveWindow.Zoom / 100))
            'calcul de l'elevation a partir de l'elevation d'origine et de la position d'origine du clique
            '+ prise en compte de la valeur de zoom
            GraphElevation = GraphOrigineY - (CursorOrigineY - PositionCursor.y) * (1 + (ActiveWindow.Zoom / 100))
            
            'ici on autorise le multi tour sur laxe X
            If AngleRotation > MaxAngle Then 'Deplacement du pointeur a gauche du clique
                NbRotationX = Int(AngleRotation / MaxAngle)
                AngleRotation = AngleRotation - (MaxAngle * NbRotationX)
            End If
            If AngleRotation < 0 Then 'Deplacement du pointeur a Droite du clique
                'pour comprendre la suite n'oubliez pas que sur un cercle 360 est equivalent a 0
                'ce qui permet d'eviter la division par 0
                NbRotationX = Int(AngleRotation / MaxAngle)
                AngleRotation = AngleRotation - (MaxAngle * NbRotationX)
            End If
            
            'limitation des valeurs au maxi et mini acceptable
            ' pour l'axe Y(Elevation)
            If GraphElevation > MaxElevation Then
                GraphElevation = MaxElevation
            End If
            If GraphElevation < 0 Then GraphElevation = 0
            'Remplacez la ligne precedente par la suivante pour montrer le dessous du graphique
            'If GraphElevation < -90 Then GraphElevation = -90
            
            'en cas de depassement(run-time error 9) on gere par
            'une sortie de la boucle(le parachute)
            On Error Resume Next
            Me.Graph.Rotation = AngleRotation
            Me.Graph.Elevation = GraphElevation
            If Err > 0 Then Exit Do
            
            DoEvents
            With Me.ParentSheet
                .[u10].Value = (CursorOrigineX - PositionCursor.x)
                .[u11].Value = AngleRotation
                .[u12].Value = GraphOrigineX
                .[u14].Value = (CursorOrigineY - PositionCursor.y)
                .[u15].Value = GraphElevation
                .[u16].Value = GraphOrigineY
            End With
        Loop
        If Err = 0 Then
            Me.Graph.Rotation = AngleRotation
            Me.Graph.Elevation = GraphElevation
        Else
            Err.Clear
        End If
        Me.ParentSheet.ChartObjects(NomGraph).Activate
    End If
End Sub

Télécharger le zip

14 août 2008 00:44:13 :

Correction de l'orthographe

14 août 2008 21:24:08 :

Suite au remarque de PCPT : Amelioration du calcul des valeurs de positions angulaire et elevation. Deplacement des calculs de la classe classchart vers le module module1. Correction de l'orthographe.

15 août 2008 18:22:28 :

Application des corrections proposées par PCPT

15 août 2008 18:50:33 :

Encore une correction d'orthograph...

15 août 2008 18:56:22 :

La nouvelle capture n'est pas passée lors de la derniere modif. Donc nouvelle tentative

29 septembre 2008 16:50:47 :

- Calcul des deplacements avec prise en compte de la valeur de zoom de la feuille excel - plus de limitation en rotation ce qui permet le multi tours

22 octobre 2008 23:08:12 :

Correction de l'orthographe (pour rester coherant avec ma config americaine et mon clavier QWERTY j'ai enleve les accents)

24 juin 2009 15:40:43 :

Correction de la description