Discussion :

[cerede2000]

Bonjour à tous,

Je cherche le moyen de positionner correctement un UserForm sur une cellule.

J'ai rapidement compris que le simple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Me.Top = Activecell.Top
Me.Left = Activecell.Left

Ne fonctionnais pas, semble-t-il à cause d'un conversion nécessaire entre Pt et Px.

J'ai donc tenté :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Me.Left = ActiveWindow.PointsToScreenPixelsX(pPosition.Left)
Me.Top = ActiveWindow.PointsToScreenPixelsY(pPosition.Top)

Mais ça ne donne pas vraiment un résultat plus probant

J'ai trouvé ce sujet : http://www.developpez.net/forums/d82...pport-cellule/
Mais cela ne fonctionne pas correctement non plus, le UserForm est quand même largement décalé.

Petite précision, je ne sais pas si ça peu jouer mais j'ai retiré la CaptionBar du UserForm.

Merci pour votre aide

[patricktoulon]

bonjour

met ca dans un module standard

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
Option Explicit
 Declare Function GetDC& Lib "user32.dll" (ByVal hwnd&)
 Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&)
' Fonction d'acquisition de l'identifiant de la fenêtre active
Private Declare Function GAW Lib "User32" Alias "GetActiveWindow" () As Long
' Fonction de changement
Private Declare Function SWL Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Fonction pour redresser l'affichage de la form sans la caption
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
 
  Sub Sans_Caption()
    SWL GAW, -16, &H94080080: SWL GAW, -20, 0: DrawMenuBar GAW
End Sub
Sub position_usf(usf, cel)
' 1 inch = 72 points for usually 96 or 120 dpi
Dim x#, y#, w#, h#
x = GetDeviceCaps(GetDC(0), 88) / 72
y = GetDeviceCaps(GetDC(0), 90) / 72
With usf
.StartUpPosition = 0
.Left = (ActiveWindow.PointsToScreenPixelsX(cel.Left * x) * 1 / x)
.Top = (ActiveWindow.PointsToScreenPixelsY(cel.Top * y) * 1 / y)
End With
ActiveWindow.ScrollRow = cel.Row
ActiveWindow.ScrollColumn = cel.Column
End Sub

et dans le activate de l'userform tu met

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub UserForm_Activate()
Sans_Caption
position_usf Me, ActiveCell
End Sub

au load de ton userform il s'affiche a l'angle gauche haut de ta cellule active et sans caption
si ta cellule active n'est pas visible le scroll de la feuille se fait automatiquement

adit:
supprime les deux ligne de scroll c'est pas au point je fait une erreur quelque part

[Invité]

Bonjour,
regarde le fichier et fais un double Click sur un cellule!

[cerede2000]

Merci pour vos réponses.

@patricktoulon : Ne fonctionne pas, le form est beaucoup plus haut que la cellule active et décaler vers la gauche
La sub Sans_Caption ne fonctionne pas, mais j'ai déjà le code pour le cacher.
Comment fonctionne-t-elle sans le Handle de la fenêtre ?

@rdurupt : Pareille, il se positionne au même endroit qu'avec le code de @patricktoulon
Et se pose aussi le problème du Zoom, si celui-ci n'est pas à 100 la position de ton Calendard n'est pas bonne

En PJ le XLSX, la colonne dans laquelle je veux afficher le form sur selection_change est K
Classeur1.xlsx

[Invité]

je un peut d’adaptation!

[cerede2000]

Génial !!

Je remarque juste qu'il doit y avoir quelques valeur à adapter en fonction de la taille du UserForm.
Sur X et Y ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
X = (Target.Left - ActiveWindow.VisibleRange.Left + 45) * ActiveWindow.Zoom / 100
Y = (Target.Top + Target.Height - ActiveWindow.VisibleRange.Top + 9.3 + 226) * ActiveWindow.Zoom / 100

Le + 45 et le + 226 ?

[Invité]

le 45;226 correspond aux bordure de la gille!

[cerede2000]

Ah ok !!

Mais comment adapte tu le positionnement alors ?
Car mon USF fait H:115 et W:132

Si je redimensionne ton USF Calendard exemple avec ces dimensions le positionnement n'est plus correcte.

Il faut jouer à ce niveau la ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Me.Height = Me.Height - 17: Me.Top = Me.Top + Me.Height - 4: Me.Left = Me.Left - 4

[Invité]

on ne passe au UserForm que la position de la cellule, c'est à lui de s'adapter!

Code possionnement de la cellule :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Target.Column = 11 And Target.Row >= 11 Then
Dim X As Double, Y As Double
X = (Target.Left - ActiveWindow.VisibleRange.Left + 45) * ActiveWindow.Zoom / 100
Y = (Target.Top + Target.Height - ActiveWindow.VisibleRange.Top + 9.3 + 226) * ActiveWindow.Zoom / 100
Target = Calendard.Chargement(Target.Text, X & ";" & Y, FormatDate:="yyyy-mm-dd")
End If
End Sub

Code code appelé par Worksheet_BeforeDoubleClick :

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

Public Function Chargement(Optional Mydate As String = "", Optional Pose As String = "0;0", Optional Caption As String = "", Optional BackColor As String = "", Optional FormatDate = "dd/mm/yyyy")
Dim T
T = Split(Pose, ";")
Me.Top = T(1)
Me.Left = T(0)
If Pose = "0;0" Then
    Me.StartUpPosition = 2
Else
 hWnd = FindWindow(vbNullString, Me.Caption)
 Style = GetWindowLong(hWnd, -16) And Not &HC00000
 SetWindowLong hWnd, -16, Style
 DrawMenuBar hWnd
 Me.Height = Me.Height - 17: Me.Top = Me.Top + Me.Height - 4: Me.Left = Me.Left - 4 'vue que nous supprimmons l'etête du userform!
End If
If Caption <> "" Then Me.Caption = Caption
Dim I As Integer
If BackColor <> "" Then
    Me.BackColor = BackColor
   
End If
If Mydate <> "" And IsDate(Mydate) Then Me.Tag = Mydate Else Me.Tag = Date
Me.Mois = Format(Me.Tag, "MMMM YYYY")
MajControle
Me.Show vbModal
On Error Resume Next
Chargement = Format(Me.Tag, FormatDate)
If Err <> 0 Then Chargement = False
Unload Me
End Function

[cerede2000]

C'est bien ce que j'ai compris, mais du coup pourquoi si la taille de l'USF change le positionnement n'est plus correct par rapport à la cellule ?

[patricktoulon]

j'avoue que je comprends pas pourquoi vous vous embêtez la vie mon exemple fonctionne très bien sans les deux lignes de scroll

et puis les scroll c'est pas nécessaire finalement puisque le référence c'est "activecell"

[cerede2000]

Si le Zoom n'est pas à 100% alors le positionnement avec ton code n'est pas correct

Edit : Et si tu arrive à comprendre pourquoi sur cette feuille avec ton code l'USF est décalé je t'en serais éternellement reconnaissant !!!
Classeur2.xlsx
Si je créé un nouveau classeur vierge avec ton code c'est ok, mais si j'applique ton code en SelectionChange sur cette feuille, l'USF est décalé, c'est un truc de fou

[patricktoulon]

Bonjour
j'avoue que je reste bouche B moi non plus je ne comprends pas on dirait que les apis considèrent la grille Excel comme a l'origine et pas avec les cellules redimensionnées


dans l'exemple de Rdurupt il utilise 45 et 226 attention 's'est pas pour tout le monde pareil c'est en fonction de la résolution de ton écran

pour le calculer il faut capter le handle de la grille uniquement car oui on peut le capter avec l'api createrectangle on a les coordonnées

classe de l'application ="EXCEL2"
classe de la grille ="XLDESK"' donne le handle de la grille exel avec findwindow sur la classname et vbnullstring pour la caption ou même avec getwindow dans une boucle
apres
restangle handle 1-restanglehandle2

[cerede2000]

Ah ça me rassure, je ne suis pas complètement fou !

Je ne vois pas de quelle API tu parle (createrectangle) ?
Aurais tu un bout de code ?

[patricktoulon]

je fait des test depuis toute a l'heure et je constate que ca fonctionne plus si bien que ca les api j'ai pas d'explication

pourtant j'ai bien les données exactes colle ca dans un module dans un fichier propre

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
40
41
42
43
44
45
46
47
48
49
50
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_) As Long
Type POINT_
      X As Long
      Y As Long
End Type
Type RECT
      Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
Dim point As POINT_
Dim coord1 As RECT
Dim coord2 As RECT
Dim nomclasse As String * 200
Function pos_souris_sur_cell()
titre = Array("position X", "positionY", "lageur de la colonne des numero de ligne", "height  ruban", "left cellule reel dans la grille", "top cellule reel dans la grille")
Range("A1:F1") = titre
'recherche de la fenetre de la page active
     pointeur = FindWindow("XLMAIN", vbNullString)
     Call GetWindowRect(pointeur, coord1)
     Call GetWindowRect(pointeur, coord1)
 
     pointeur = GetWindow(pointeur, 5)
     Do
     GetClassName pointeur, nomclasse, 250
     i = i + 1
     Cells(i, 10) = nomclasse
     If LCase(Left(nomclasse, 6)) = "xldesk" Then Exit Do ' on capte  le handle de la grille exel uniquement
     pointeur = GetWindow(pointeur, 2)
     Loop
'recherche de la position et taille de la fenetre
    Call GetWindowRect(pointeur, coord2)
    échx = Application.UsableWidth / (coord2.Right - coord2.Left)
    échy = Application.UsableHeight / (coord2.Bottom - coord2.Top)
'recherche de la position du curseur en points
      GetCursorPos point
      xpt = ((point.X - coord2.Left) * échx) - 19 ' on enleve 19 pour la colonne de chiffre representant les lignes
      ypt = ((point.Y - coord2.Top) * échy) - 15 ' on enleve 15 pour la ligne des lettres
Cells(2, 1) = ypt ' donne la position du curseur reelle dans la grille excel (left)
Cells(2, 2) = xpt ' donne la position du curseur reelle dans la grille excel (top)
Cells(2, 3) = coord2.Left - coord1.Left + 19 'donne la difference en te l'ecran et la grill excel uniquement (pas l'application entiere)
Cells(2, 4) = coord2.Top - coord1.Top + 15 ' idem pour le top
Cells(2, 5) = ActiveCell.Left / (96 / 72) + (coord2.Left - coord1.Left + 19)
Cells(2, 6) = ActiveCell.Top / (96 / 72) + (coord2.Top - coord1.Top + 15)
End Function

et ceci dans le module du sheet(1)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
pos_souris_sur_cell
End Sub

[patricktoulon]

Bon ne cherche plus
il semblerait que certaine mise a jour on modifiée certaine librairies et les api Windows avec app32 sur system 64 ne soit plus vraiment fiables

ca ca va tout chambouler
le dernier code que je t'ai donné te donne le left et top du userform mais le top déraille complètement sans raison

[cerede2000]

Pas mal quand même !

Si les API ne sont plus fiable.... Ca va être compliqué pour pas mal de truc

Peut être as tu une astuce pour afficher correctement un OleObject MSComCtl2.MonthView.2 de manière dynamique dans une feuille.
Cela résoudrais totallement mon problème de positionnement d'USF (plus besoin du coup).

Je fais ceci :

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
Dim sheet As Worksheet: Set sheet = ActiveSheet    Dim datePicker As OLEObject
 
 
    On Error Resume Next
    Set datePicker = sheet.OLEObjects("datePicker")
    If datePicker Is Nothing Then
        'Set datePicker = sheet.OLEObjects.Add(ClassType:="MSComCtl2.MonthView.2", Link:=False, DisplayAsIcon:=False, Left:=0, Top:=0, Width:=148, Height:=148)
        Set datePicker = sheet.OLEObjects.Add(ClassType:="MSComCtl2.MonthView.2", Link:=False, DisplayAsIcon:=False, Left:=0, Top:=0)
        datePicker.name = "datePicker"
        'sheet.Shapes("datePicker").Width = 148
        'sheet.Shapes("datePicker").Height = 148
        'sheet.Shapes("datePicker").ScaleHeight 2, msoTrue
        'sheet.Shapes("datePicker").ScaleWidth 2, msoTrue
    End If
 
 
    Target.Left = Target.Left
    Target.Top = Target.Top
 
 
    With datePicker
        .Visible = True
        .Left = Target.Left
        .Top = Target.Top
 
 
        sheet.Shapes("datePicker").Width = 148
        sheet.Shapes("datePicker").Height = 148
 
 
        datePicker.Width = 148
        datePicker.Height = 148
    End With

Mais au 1er affichage il s'affiche correctement mais semble figé car rien ne se passe.
Lorsque je le cache et que je le réaffiche :

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
Private Sub hideDatePicker()
    Dim sheet As Worksheet: Set sheet = ActiveSheet
    Dim datePicker As OLEObject
 
    On Error Resume Next
    Set datePicker = sheet.OLEObjects("datePicker")
    If datePicker Is Nothing Then
        Exit Sub
    End If
 
    datePicker.Left = 0
    datePicker.Top = 0
 
    datePicker.Visible = False
End Sub

Il ne s'affiche pas correctement, il est comme zommé, il est bien clicable mais il en manque les 2/3

[patricktoulon]

bon c'est vrai aussi que j'ai essayer sur 10 classeur différent et le premier que je t'avais donnée fonctionne sur tous il y a que sur le tiens que ca foonctionne pas


donc sans les apis pour le positionnemlent en prenant le zomm en compte

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
Option Explicit
 Declare Function GetDC& Lib "user32.dll" (ByVal hwnd&)
 Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&)
' Fonction d'acquisition de l'identifiant de la fenêtre active
Private Declare Function GAW Lib "User32" Alias "GetActiveWindow" () As Long
' Fonction de changement
Private Declare Function SWL Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Fonction pour redresser l'affichage de la form sans la caption
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long
 
  Sub Sans_Caption()
    SWL GAW, -16, &H94080080: SWL GAW, -20, 0: DrawMenuBar GAW
End Sub
Sub position_usf(usf, cel)
Dim z
z = ActiveWindow.Zoom / 100
SWL GAW, -16, &H94080080: SWL GAW, -20, 0: DrawMenuBar GAW
' 1 inch = 72 points for usually 96 or 120 dpi
Dim x#, y#, w#, h#
x = GetDeviceCaps(GetDC(0), 88) / 72
y = GetDeviceCaps(GetDC(0), 90) / 72
With usf
.StartUpPosition = 0
.Left = (ActiveWindow.PointsToScreenPixelsX((cel.Left * z) * x) * 1 / x)
.Top = (ActiveWindow.PointsToScreenPixelsY((cel.Top * z) * y) * 1 / y)
End With
End Sub

je regarde pour ton datepicker

[patricktoulon]

re
essaie plutôt ca !!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Dim datePicker As Object
 
    With Sheets(1)
        Set datePicker = .OLEObjects.Add(ClassType:="MSCAL.Calendar.7", Link:=False, DisplayAsIcon:=False, Left:=.Range("A10").Left, Top:=.Range("A10").Top)    '.Select
        datePicker.Name = "datePicker"
    End With

j'oubliais pour sortir du mode création il faut le rendre invisible puis visible pour débloquer son utilisation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub test()
    Dim datePicker As Object
 
    With Sheets(1)
        Set datePicker = .OLEObjects.Add(ClassType:="MSCAL.Calendar.7", Link:=False, DisplayAsIcon:=False, Left:=.Range("A10").Left, Top:=.Range("A10").Top)    '.Select
        datePicker.Name = "datePicker"
    datePicker.Visible = False
    datePicker.Visible = True
    End With
 
End Sub

[cerede2000]

Ok, j'ai compris, sur le classeur que j'ai mit plus haut le zoom semble être bloqué quelque pars !

Sur un classeur vierge même le DatePicker est ok.

Par contre j'observe un phénomène un peu embêtant.
Si on joue sur le zoom de la fenêtre, la Shape qui contient le datepicker (MSComCtl2.MonthView.2 et MSCAL.Calendar.7) est également réduite ou agrandie.
Du coup dans le sens réduction :


Peut on jouer sur le zoom d'une Shape indépendamment de la fenêtre ?

Edit : Ou un calcul qui en fonction du zoom donne la bonne taille a la Shape.
La valeur à correct est :
W : 163,5
H : 153
Quelque sois le zoom W et H ne changent jamais, mais il faudrait leur appliquer un coefficient en fonction du zoom.
Comment faire pour le déterminer ?