Positionner UserForm sur cellule

Version imprimable

Voir 40 message(s) de cette discussion en une page

09/03/2016, 11h01
cerede2000

Positionner UserForm sur cellule
Bonjour à tous,

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

J'ai rapidement compris que le simple :
Code:

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:

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 :)

heu

bonjour

met ca dans un module standard

Code:

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:

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 :oops:

09/03/2016, 12h17
Invité

1 pièce(s) jointe(s)

Bonjour,
regarde le fichier et fais un double Click sur un cellule!
09/03/2016, 13h28
cerede2000

1 pièce(s) jointe(s)

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
Pièce jointe 203392
09/03/2016, 13h56
Invité

1 pièce(s) jointe(s)

je un peut d’adaptation!

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:

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 ?

09/03/2016, 14h27
Invité

1 pièce(s) jointe(s)

le 45;226 correspond aux bordure de la gille!
09/03/2016, 14h39
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:

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

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

Code:

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:

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

09/03/2016, 14h59
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 :( ?
09/03/2016, 18h42
patricktoulon

re

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"
10/03/2016, 08h27
cerede2000

1 pièce(s) jointe(s)

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 !!!
Pièce jointe 203450
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 :(
10/03/2016, 11h17
patricktoulon

re

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
10/03/2016, 13h00
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 ?

re tiens un bout de code teste ca dans un fichier propre

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:

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:

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

10/03/2016, 13h57
patricktoulon

re

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

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:

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:

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 :(

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:

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

re
essaie plutôt ca !!

Code:

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:

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

;)

10/03/2016, 15h13
cerede2000

1 pièce(s) jointe(s)

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 :
Pièce jointe 203502

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 ?

Voir 40 message(s) de cette discussion en une page