Discussion :

[pgoffin]

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

[Invité]

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

Pièce jointe 544337