Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

VBA PowerPoint Discussion :

Positionner un userform au dessus d'une shape


Sujet :

VBA PowerPoint

  1. #1
    Nouveau Candidat au Club
    Positionner un userform au dessus d'une shape
    Bonjour,

    je voudrais superposer un "userform" au dessus d'une "shape" en particulier.
    Je n'ai rien trouvé sur le Net pour me permettre de faire cette manipulation.
    Je serai plus qu'heureux si quelqu'un pouvait me conseiller


    Voici le résultat de mes recherches
    j'ai créé un bouton associé à une macro dont l'objectif est d'identifier une shape en particulier, de sauver les attributs: top, left, height, width et de les passer à une userform

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    ' Shape information
    Public ii_shapeTop                  As Double ' current shape top
    Public ii_shapeLeft                 As Double ' current shape left
    Public ii_shapeWidth                As Double ' current shape width
    Public ii_shapeHeight               As Double ' current shape height
     
     
     
    Sub DemoSize()
     
    Dim li_slide        As Integer
     
        li_slide = SlideShowWindows(1).View.CurrentShowPosition
        With ActivePresentation.Slides(li_slide)
            With .Shapes("Balise2")
             ii_shapeTop = .Top
             ii_shapeLeft = .Left
             ii_shapeWidth = .Width
             ii_shapeHeight = .Height
            End With 
        End With  
        F_Demo.Show
    End Sub



    Dans le userform, j'utilise des fonctions système pour convertir des Pixels en Points (trouvé sur le Net)
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    'Function to get screen resolution
    Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
    'Functions to get DPI
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Const LOGPIXELSX = 88 'Pixels/inch in X
    Private Const POINTS_PER_INCH As Long = 72 'A point is defined as 1/72 inches


    j'ai testé deux types de fonctions (trouvé sur le Net) sans aucun résultat

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    Public Function PointsPerPixel() As Double
     Dim hDC As Long
     Dim lDotsPerInch As Long
     hDC = GetDC(0)
     lDotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
     PointsPerPixel = POINTS_PER_INCH / lDotsPerInch
     ReleaseDC 0, hDC
    End Function
     
    Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, _
                                          ByVal sXorY As String) As Single
    Dim hDC As Long
       hDC = GetDC(0)
       If sXorY = "X" Then
          ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
       End If
       If sXorY = "Y" Then
          ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
       End If
       Call ReleaseDC(0, hDC)
    End Function


    dans le UserForm_Activate() j'ai testé quelques formules:

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    ' ------- Test 1 -------- Not Ok
     w = GetSystemMetrics32(0) ' Screen Resolution width in points
     h = GetSystemMetrics32(1) ' Screen Resolution height in points
    With Me
      .StartUpPosition = 1
      .Width = w * PointsPerPixel * 0.85 'Userform width= Width in Resolution * DPI * 85%
      .Height = h * PointsPerPixel * 0.85 'Userform height= Height in Resolution * DPI * 85%
      .Top = 100
    End With
     
    '------ Test 2 --------- Error
    ' ==> Error no ActivePresentation!
    'Set sld = Application.ActivePresentation.SlideShowWindow.View.Slide
    '    With Application.ActivePresentation.SlideShowWindow ' Application.ActivePresentation.SlideShowWindow.View.Slide
    '        Me.Left = .Application.ActiveWindow.PointsToScreenPixelsX((0 + ii_shapeLeft + 0.5 * ii_shapeWidth)) - (0.5 * Me.Width)
    '        Me.Top = .Application.ActiveWindow.PointsToScreenPixelsY((0 + ii_shapeTop - 20) - Me.Height)
    '    End With
     
    '---- Test 3 ------ Not Ok
    Me.Left = ConvertPixelsToPoints(ii_shapeLeft, "X")
    Me.Top = ConvertPixelsToPoints(ii_shapeTop, "Y")
     
    '---- Test 4 ------ Not Ok
    Me.Left = ((PointsPerPixel * ii_shapeLeft) + ii_shapeLeft) * PointsPerPixel
    Me.Top = ((PointsPerPixel * ii_shapeTop) + ii_shapeTop) * PointsPerPixel



    Très cordialement,
    Philippe

  2. #2
    Expert éminent sénior
    Citation Envoyé par pgoffin Voir le message

    Bonjour,

    A tester et sans doute à adapter suivant votre écran :

    Important ! Le volet Sélection ne doit pas être activé.

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
     
    Sub DemoSize()
     
    Dim I As Integer
    Dim ShapeTop As Double, ShapeLeft As Double, ShapeWidth  As Double, ShapeHeight As Double
    Dim EcartTop As Double, EcartLeft As Double
     
        EcartTop = 154.8  ' C'est la position du userform en bord haut de la diapo sur mon écran
        EcartLeft = 265.2 ' Au bord gauche de la diapo
     
        ShapeTop = 0: ShapeLeft = 0: ShapeWidth = 0: ShapeHeight = 0
        With ActivePresentation.Windows(1).View.Slide
     
             If .Shapes.Count > 0 Then
                For I = 1 To .Shapes.Count
                    With .Shapes(I)
                         If .Name = "Content Placeholder 5" Then  ' A adapter
                                 ShapeTop = .Top
                                 ShapeLeft = .Left
                                 ShapeWidth = .Width
                                 ShapeHeight = .Height
                                 .Select
                                 'Debug.Print "Balise 2 : haut " & ShapeTop & ", gauche : " & ShapeLeft
                          End If
                    End With
                Next I
             End If
     
             If ShapeTop > 0 Then
                With F_Demo
                     .Top = ShapeTop * 0.809 + EcartTop - .Height
                     .Left = ShapeLeft * 0.808 + EcartLeft
                     .Show
                End With
             End If
     
        End With
     
    End Sub


    Pour tester les différentes positions du Userform en limite de la diapo, il vous faut ajouter un bouton et le code suivant :
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
     
    Private Sub CommandButton1_Click()
     
              Debug.Print "F_Demo top : " & F_Demo.Top & ", gauche : " & F_Demo.Left
     
    End Sub


    Eric KERGRESSE
    https://sites.google.com/site/erickergresseeirl/
    Lorsque vous avez la réponse à votre question, n'oubliez pas de cliquer sur et si celle-ci est pertinente pensez à voter