Discussion :

[marycaLou]

Bonjour,

Voici ma première question: J'ai créé une forme dans VBA de Outlook. Malheureusement, je ne trouve pas comment faire pour que l'utilisateur puisse l'agrandir ou la réduire la forme.
Est-ce possible?

Ma deuxième question concerne une listBox dans la forme cité plus haut. J'aimerais pouvoir utiliser le bouton de défilement de la souris et je n'y arrive pas. Doit-on le programmer? Si oui, comment faire?

Merci.

[Oliv-]

Bonjour,
ce sont des questions purement vba , tu trouveras des solutions pour excel qui vont marcher aussi pour outlook

voilà des solutions que m'a donné GOOGLE

pour la souris

http://www.mrexcel.com/forum/excel-q...lications.html
http://www.ozgrid.com/forum/showthread.php?t=184493
http://stackoverflow.com/questions/1...mbobox-listbox

[Oliv-]

pour la taille de l'userform il y a cet exemple aussi avec les API

FormFun.zip

[marycaLou]

En effet, cela fonctionne. Mais Est-ce qu'il y a un moyen de ne pas utiliser le "Spinbutton". Ou de faire en sorte de créer un bouton et de lui demander d'exécuter ce que fait le "Spinbutton". Voici un exemple de mon code:

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
Private Sub cmdMoins_Click()
    SpinButton1_SpinDown
End Sub
Private Sub cmdPlus_Click()
    SpinButton1_SpinUp
End Sub
Private Sub SpinButton1_SpinUp()
    ActionSpin = "Plus"
    Reglage
End Sub
Private Sub SpinButton1_SpinDown()
    ActionSpin = "Moins"
    Reglage
End Sub
Private Sub Reglage()
    With Me
        Coef = .SpinButton1 - 100
        .Height = ((Hauteur / 100) * Coef) + Hauteur
        .Width = ((Largeur / 100) * Coef) + Largeur
        .Zoom = .SpinButton1
    End With
End Sub

Merci

[Oliv-]

voir le fichier de mon précédent message

[marycaLou]

J'ai recopié le code et cela ne marche pas. Je n'arrive pas à faire dérouler ma liste avec le bouton de la souris.
Pourtant, je n'ai pas d'erreur dans mon code et j'ai modifié les noms des objets pour que cela correspondent aux miens.

Auriez-vous une autre solution pour que nous puissions avoir le bouton déroulant de la souris.

Merci.

[marycaLou]

J'aimerais bien trouvé comment agrandir la fenêtre dans Outlook. Avec le spinbutton cela fonctionne mais c'est tout qui agrandit.
Exemple: Dans tout l'écran, c'est la police de caractères qui change. Elle grossit ou se réduit selon le bouton utiliser.

Je ne veux pas que la police change, je veux que ce soit les objets qui s'agrandissent ou se réduisent, exemple la fenêtre, la listbox1, la textbox1.

Comment faire.

Merci.

[Oliv-]

Bonsoir même réponse que la précédente voir le fichier forfun

[marycaLou]

J'ai intégré le code. mais j'ai une erreur sur la ligne suivante:

Code :

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

1
2
3
4
5
6
7
    With fraClasser      'fraStyle
        dFrameCols = Application.Max(1, (Me.InsideWidth - dGAP * 3 - (.Width - .InsideWidth)) \ (chkClasser.Width + dGAP))
        dFrameRows = .Controls.Count / dFrameCols
 
        If dFrameRows <> Int(dFrameRows) Then dFrameRows = Int(dFrameRows) + 1
        dFrameHeight = dFrameRows * lstEmpla.Height + dGAP + .Height - .InsideHeight
    End With

Sur la ligne "Application.Max ..." j'ai l'erreur 438, Propriété ou méthode non gérée par cet objet".
Comment fait-on pour référer l'application à Outlook?
Tous les objets de cette ligne, me donne des valeur sauf le maximum de "Application.max".

[Oliv-]

Bonjour,
Il y avait quelques adaptations à faire pour OUTLOOK, notamment application.max est une fonction EXCEL


Changer le code de l'userform par celui-ci

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
 
'***************************************************************************
'*
'* MODULE NAME:     USERFORM WINDOW STYLES
'* AUTHOR:          STEPHEN BULLEN, Office Automation Ltd.
'*                  TIM CLEM
'*
'* CONTACT:         stephen@oaltd.co.uk
'* WEB SITE:        http://www.oaltd.co.uk
'*
'* DESCRIPTION:     Modifies a form's window styles in response to check box clicks
'*
'* NOTES:
'* In this demo, I'm changing the form's styles while the form is being used.
'* Hence, I've used a module-level variable for the CFormChanger class, which is
'* set to Nothing in the Userform_Terminate event. In normal operation, you'll
'* only need to set the styles once, so everything can be contained in the
'* Userform_Activate event:
'*
'*  'Initialise the form to not have a close button
'*  Private Sub UserForm_Activate()
'*      Dim clsFormChanger As CFormChanger
'*
'*      Set clsFormChanger = New CFormChanger
'*      clsFormChanger.ShowCloseBtn = False
'*      clsFormChanger.ShowSysMenu = False
'*      Set clsFormChanger.Form = Me
'*  End Sub
'*
'* Also note that disabling the close button through API calls does NOT stop
'* the form being closed using the Alt+F4 shortcut key, so we still have to use
'* the QueryClose event to trap that case.
'*
'* UPDATES:
'*  DATE            COMMENTS
'*  11 Jan 2005     Added Userform_QueryClose event to handle Alt+F4.
'*                  Added Userform_Terminate event to set the mclsFormChanger to Nothing
'*                  Added the usage notes above
'*
'***************************************************************************
 
Option Explicit
 
'Declare a new instance of our form changer class
Dim mclsFormChanger As CFormChanger
 
 
Private Sub UserForm_Activate()
 
    Set mclsFormChanger = New CFormChanger
 
    'Initialise to be like a 'standard' userform
    cbModal.Value = True
    cbCaption.Value = True
    cbCloseBtn.Value = True
    cbTaskBar.Value = True
    cbIcon.Value = False
    cbMaximize.Value = False
    cbMinimize.Value = False
    cbSizeable.Value = False
    cbSysmenu.Value = True
    cbTaskBar.Value = False
    cbSmallCaption.Value = False
 
    'Set the form changer to change this userform
    Set mclsFormChanger.Form = Me
 
    'Make sure everything is in the right place to start with
    UserForm_Resize
 
End Sub
 
Private Sub UserForm_Resize()
 
    Dim dFrameCols As Double, dFrameRows As Double, dFrameHeight As Double
    Dim i As Integer, j As Integer
 
    'Standard control gap of 6pts
    Const dGAP As Integer = 6
 
    'Exit the sub if we've been minimized
    If Me.InsideWidth = 0 Then Exit Sub
 
    'Set controls that don't move/size
    With lblMessage                              'The position of the "Message" label
        .Top = dGAP
        .Left = dGAP
    End With
 
    With tbMessage                               'The position of the message box (the size changes, not the position)
        .Top = dGAP + lblMessage.Height + dGAP
        .Left = dGAP
    End With
 
    fraStyle.Left = dGAP
 
    'Don't let the form get less than a certain height - must have at least the message and button
    If Me.InsideHeight < lblMessage.Height + btnOK.Height + fraStyle.Height + dGAP * 5 Then
 
        'Reset the height, allowing for the form's border (Height - InsideHeight)
        Me.Height = lblMessage.Height + btnOK.Height + fraStyle.Height + dGAP * 5 + Me.Height - Me.InsideHeight
    End If
 
    'Don't let the form get less than a certain width - must be as wide as the biggest check box, plus the standard gap
    If Me.InsideWidth < cbMaximize.Width + fraStyle.Width - fraStyle.InsideWidth + dGAP * 4 Then
 
        'Reset the width, allowing for the form's border (Width - InsideWidth)
        Me.Width = cbMaximize.Width + fraStyle.Width - fraStyle.InsideWidth + dGAP * 4
    End If
 
    'Work out the new dimensions of the frame (as the check boxes move within the frame)
    With fraStyle
 
        dFrameCols = (Me.InsideWidth - dGAP * 3 - (.Width - .InsideWidth)) \ (cbMaximize.Width + dGAP)
        If dFrameCols < 1 Then dFrameCols = 1
        dFrameRows = .Controls.Count / dFrameCols
 
        If dFrameRows <> Int(dFrameRows) Then dFrameRows = Int(dFrameRows) + 1
        dFrameHeight = dFrameRows * cbMaximize.Height + dGAP + .Height - .InsideHeight
    End With
 
    'Don't allow the form width to decrease so that there's no room for the checkboxes
    'i.e. decreasing the width causes the check boxes to require an extra row, which doesn't fit.
    If Me.InsideHeight <= btnOK.Height + lblMessage.Height + dFrameHeight + dGAP * 5 Then
 
        'Reset the width, allowing for the form's border (Width - InsideWidth)
        Me.Width = fraStyle.Width + dGAP * 2 + Me.Width - Me.InsideWidth
 
        'Recalculate the frame's dimensions with the changed form's width
        With fraStyle
            dFrameCols = Application.Max(1, (Me.InsideWidth - dGAP * 3 - (.Width - .InsideWidth)) \ (cbMaximize.Width + dGAP))
            dFrameRows = .Controls.Count / dFrameCols
 
            If dFrameRows <> Int(dFrameRows) Then dFrameRows = Int(dFrameRows) + 1
            dFrameHeight = dFrameRows * cbMaximize.Height + dGAP + .Height - .InsideHeight
        End With
 
    End If
 
    'Set the OK button to be in the middle at the bottom
    With btnOK
        .Left = (Me.InsideWidth - btnOK.Width) / 2
        .Top = Me.InsideHeight - btnOK.Height - dGAP
    End With
 
    'Sometimes the OK button leaves white lines from its edges, so use a label to clear them
    With lblBlank
        .Width = Me.InsideWidth
        .Top = btnOK.Top - 0.75
    End With
 
    'Set the frame to be as wide as the box and move the check boxes in it to fit
    With fraStyle
        .Width = Me.InsideWidth - dGAP * 2
        .Height = dFrameHeight
 
        'Reposition the controls in the frame, according to their tab order
        For i = 0 To .Controls.Count - 1
            For j = 0 To .Controls.Count - 1
                With .Controls(j)
                    If .TabIndex = i Then
                        .Left = (i Mod dFrameCols) * (cbMaximize.Width + dGAP) + dGAP
                        .Top = Int(i / dFrameCols) * cbMaximize.Height + dGAP
                    End If
                End With
            Next
        Next
 
        .Top = btnOK.Top - dGAP - .Height
    End With
 
    'Userform is big enough, so set the message box's height and width to fill it
    With tbMessage
        .Width = Me.InsideWidth - dGAP * 2
 
        'Don't allow the height to go negative
        Dim maxHeight
        maxHeight = fraStyle.Top - .Top - dGAP
        If maxHeight < 0 Then
        .Height = 0
        Else
         .Height = maxHeight
         End If
    End With
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 
    'If we've disabled the [x] close button, prevent the Alt+F4 keyboard shortcut too
    If CloseMode = vbFormControlMenu And Not cbCloseBtn.Value Then
        Cancel = True
    End If
End Sub
 
Private Sub UserForm_Terminate()
    Set mclsFormChanger = Nothing
End Sub
 
Private Sub cbModal_Change()
    mclsFormChanger.Modal = cbModal.Value
    CheckEnabled
End Sub
 
Private Sub cbSizeable_Change()
    mclsFormChanger.Sizeable = cbSizeable.Value
 
    CheckBorderStyle
End Sub
 
Private Sub cbCaption_Change()
    mclsFormChanger.ShowCaption = cbCaption.Value
 
    CheckBorderStyle
    CheckEnabled
End Sub
 
Private Sub cbSmallCaption_Change()
    mclsFormChanger.SmallCaption = cbSmallCaption.Value
    CheckEnabled
End Sub
 
Private Sub cbTaskBar_Change()
    mclsFormChanger.ShowTaskBarIcon = cbTaskBar.Value
    CheckEnabled
End Sub
 
Private Sub cbSysmenu_Change()
    mclsFormChanger.ShowSysMenu = cbSysmenu.Value
    CheckEnabled
End Sub
 
Private Sub cbIcon_Change()
    mclsFormChanger.ShowIcon = cbIcon.Value
    If cbIcon.Value And mclsFormChanger.IconPath = "" Then btnChangeIcon_Click
    CheckEnabled
End Sub
 
Private Sub btnChangeIcon_Click()
 
    Dim vFile As Variant
vFile = BrowseForFile_CommonDialog("Open Icon File")
    'vFile = Application.GetOpenFileName("Icon files (*.ico;*.exe;*.dll),*.ico;*.exe;*.dll", 0, "Open Icon File", "Open", False)
 
    'Showing dialog sets the form modeless, so check it
    mclsFormChanger.Modal = cbModal
 
    If vFile = False Then Exit Sub
 
    mclsFormChanger.IconPath = vFile
 
End Sub
 
Private Sub cbCloseBtn_Change()
    mclsFormChanger.ShowCloseBtn = cbCloseBtn.Value
    CheckEnabled
End Sub
 
Private Sub cbMinimize_Change()
    mclsFormChanger.ShowMinimizeBtn = cbMinimize.Value
    CheckEnabled
End Sub
 
Private Sub cbMaximize_Change()
    mclsFormChanger.ShowMaximizeBtn = cbMaximize.Value
    CheckEnabled
End Sub
 
Private Sub btnOK_Click()
    Unload Me
End Sub
 
Private Sub CheckBorderStyle()
 
    'If the userform is not sizeable and doesn't have a caption,
    'Windows draws it without a border, and we need to apply our
    'own 3D effect.
    If Not (cbSizeable Or cbCaption) Then
        Me.SpecialEffect = fmSpecialEffectRaised
    Else
        Me.SpecialEffect = fmSpecialEffectFlat
    End If
 
End Sub
 
Private Sub CheckEnabled()
 
    'Without a system menu, we can't have the close, max or min buttons
    cbSysmenu.Enabled = cbCaption
    cbCloseBtn.Enabled = cbSysmenu And cbCaption
    cbIcon.Enabled = cbSysmenu And cbCaption And Not cbSmallCaption
    cbMaximize.Enabled = cbSysmenu And cbCaption And Not cbSmallCaption
    cbMinimize.Enabled = cbSysmenu And cbCaption And Not cbSmallCaption
 
    btnChangeIcon.Enabled = cbIcon.Value And cbIcon.Enabled
 
End Sub
Sub test_BrowseForFile_CommonDialog()
MsgBox BrowseForFile_CommonDialog("test")
End Sub
Function BrowseForFile_CommonDialog(strPrompt)
 
    Dim cd
    Set cd = CreateObject("MSComDlg.CommonDialog")
    cd.DialogTitle = strPrompt
    cd.filter = "Icones|*.ico;*.exe;*.dll"
    cd.InitDir = "C:\"
    cd.ShowOpen
    BrowseForFile_CommonDialog = cd.FileName
End Function

et celui du module de classe par celui-ci

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
'***************************************************************************
'*
'* MODULE NAME:     USERFORM WINDOW STYLES
'* AUTHOR:          STEPHEN BULLEN, Office Automation Ltd.
'*                  TIM CLEM
'*
'* CONTACT:         Stephen@oaltd.co.uk
'* WEB SITE:        http://www.oaltd.co.uk
'*
'* DESCRIPTION:     Changes userform's window styles to give different visual effects
'*
'* THIS MODULE:     Changes the userform's styles so it can be resized/maximised/minimized, etc.
'*                  The code was initially created by Tim Clem, and expanded by Stephen Bullen.
'*
'* UPDATES:
'*  DATE            COMMENTS
'*  11 Jan 2005     Changed the way 'ShowInTaskBar' works, fixing a bug found by Jamie Collins
'*
'***************************************************************************
 
Option Explicit
 
'Windows API calls to do all the dirty work!
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
 
'Lots of window styles for us to play with!
Private Const GWL_STYLE As Long = (-16)          'The offset of a window's style
Private Const GWL_EXSTYLE As Long = (-20)        'The offset of a window's extended style
Private Const WS_CAPTION As Long = &HC00000      'Style to add a titlebar
Private Const WS_SYSMENU As Long = &H80000       'Style to add a system menu
Private Const WS_THICKFRAME As Long = &H40000    'Style to add a sizable frame
Private Const WS_MINIMIZEBOX As Long = &H20000   'Style to add a Minimize box on the title bar
Private Const WS_MAXIMIZEBOX As Long = &H10000   'Style to add a Maximize box to the title bar
Private Const WS_EX_APPWINDOW As Long = &H40000  'Application Window: shown on taskbar
Private Const WS_EX_TOOLWINDOW As Long = &H80    'Tool Window: small titlebar
 
'Constant to identify the Close menu item
Private Const SC_CLOSE As Long = &HF060
 
'Constants for hide or show a window
Private Const SW_HIDE As Long = 0
Private Const SW_SHOW As Long = 5
 
'Constants for Windows messages
Private Const WM_SETICON = &H80
 
'Variables to store the various selections/options
Dim mbSizeable As Boolean, mbCaption As Boolean, mbIcon As Boolean
Dim mbMaximize As Boolean, mbMinimize As Boolean, mbSysMenu As Boolean, mbCloseBtn As Boolean
Dim mbAppWindow As Boolean, mbToolWindow As Boolean, mbModal As Boolean
Dim msIconPath As String
Dim moForm As Object
Dim mhWndForm As Long
 
'Set the class's initial properties to be those of a default userform
Private Sub Class_Initialize()
    mbCaption = True
    mbSysMenu = True
    mbCloseBtn = True
End Sub
 
'Allow the calling code to tell us which form to handle
Public Property Set Form(oForm As Object)
 
    'Get the userform's window handle
    If Val(Application.Version) < 9 Then
        mhWndForm = FindWindow("ThunderXFrame", oForm.caption)    'XL97
    Else
        mhWndForm = FindWindow("ThunderDFrame", oForm.caption)    'XL2000+
    End If
 
    'Remember the form for later
    Set moForm = oForm
 
    'Set the form's style
    SetFormStyle
 
    'Update the form's icon
    ChangeIcon
 
    'Update the taskbar visibility
    If mbAppWindow Then ShowTaskBarIcon = True
 
End Property
 
'***************************************************************
'* Property procedures to get and set the form's window styles
'***************************************************************
 
Public Property Let Modal(bModal As Boolean)
    mbModal = bModal
 
    'Make the form modal or modeless by enabling/disabling Excel itself
    EnableWindow FindWindow(vbNullString, Application.ActiveExplorer.caption), Abs(CInt(Not mbModal))
End Property
 
Public Property Get Modal() As Boolean
    Modal = mbModal
End Property
 
Public Property Let Sizeable(bSizeable As Boolean)
    mbSizeable = bSizeable
    SetFormStyle
End Property
 
Public Property Get Sizeable() As Boolean
    Sizeable = mbSizeable
End Property
 
Public Property Let ShowCaption(bCaption As Boolean)
    mbCaption = bCaption
    SetFormStyle
End Property
 
Public Property Get ShowCaption() As Boolean
    ShowCaption = mbCaption
End Property
 
Public Property Let SmallCaption(bToolWindow As Boolean)
    mbToolWindow = bToolWindow
    SetFormStyle
End Property
 
Public Property Get SmallCaption() As Boolean
    SmallCaption = mbToolWindow
End Property
 
Public Property Let ShowMaximizeBtn(bMaximize As Boolean)
    mbMaximize = bMaximize
    SetFormStyle
End Property
 
Public Property Get ShowMaximizeBtn() As Boolean
    ShowMaximizeBtn = mbMaximize
End Property
 
Public Property Let ShowMinimizeBtn(bMinimize As Boolean)
    mbMinimize = bMinimize
    SetFormStyle
End Property
 
Public Property Get ShowMinimizeBtn() As Boolean
    ShowMinimizeBtn = mbMinimize
End Property
 
Public Property Let ShowSysMenu(bSysMenu As Boolean)
    mbSysMenu = bSysMenu
    SetFormStyle
End Property
 
Public Property Get ShowSysMenu() As Boolean
    ShowSysMenu = mbSysMenu
End Property
 
Public Property Let ShowCloseBtn(bCloseBtn As Boolean)
    mbCloseBtn = bCloseBtn
    SetFormStyle
End Property
 
Public Property Get ShowCloseBtn() As Boolean
    ShowCloseBtn = mbCloseBtn
End Property
 
Public Property Let ShowTaskBarIcon(bAppWindow As Boolean)
 
    mbAppWindow = bAppWindow
 
    'When showing/hiding the task bar icon, we have to hide and reshow the form
    'to get Windows to update the task bar
    If mhWndForm <> 0 Then
        'Freeze the form, to avoid flicker when hiding/showing it
        LockWindowUpdate mhWndForm
 
        'Enable the Excel window, so we don't lose focus
        EnableWindow FindWindow(vbNullString, Application.ActiveExplorer.caption), True 'FindWindow("XLMAIN", Application.caption), True
 
        'Hide the form
        ShowWindow mhWndForm, SW_HIDE
 
        'Update the style bits
        SetFormStyle
 
        'Reshow the userform
        ShowWindow mhWndForm, SW_SHOW
 
        'Unfreeze the form
        LockWindowUpdate 0&
 
        'Set the Outlook window's enablement to the correct choice --Excel
        EnableWindow FindWindow(vbNullString, Application.ActiveExplorer.caption), Abs(CInt(Not mbModal))
        'EnableWindow FindWindow("XLMAIN", Application.caption), Abs(CInt(Not mbModal))
    End If
 
End Property
 
Public Property Get ShowTaskBarIcon() As Boolean
    ShowTaskBarIcon = mbAppWindow
End Property
 
Public Property Let ShowIcon(bIcon As Boolean)
    mbIcon = Not bIcon
    ChangeIcon
    SetFormStyle
End Property
 
Public Property Get ShowIcon() As Boolean
    ShowIcon = (mbIcon <> 1)
End Property
 
Public Property Let IconPath(sNewPath As String)
    msIconPath = sNewPath
    ChangeIcon
    SetFormStyle
End Property
 
Public Property Get IconPath() As String
    IconPath = msIconPath
End Property
 
'***************************************************************
'* Private procedures to perform the updates
'***************************************************************
 
'Procedure to set the form's window style
Private Sub SetFormStyle()
 
    Dim lStyle As Long, hMenu As Long
 
    'Have we got a form to set?
    If mhWndForm = 0 Then Exit Sub
 
    'Get the basic window style
    lStyle = GetWindowLong(mhWndForm, GWL_STYLE)
 
    'Build up the basic window style flags for the form
    SetBit lStyle, WS_CAPTION, mbCaption
    SetBit lStyle, WS_SYSMENU, mbSysMenu
    SetBit lStyle, WS_THICKFRAME, mbSizeable
    SetBit lStyle, WS_MINIMIZEBOX, mbMinimize
    SetBit lStyle, WS_MAXIMIZEBOX, mbMaximize
 
    'Set the basic window styles
    SetWindowLong mhWndForm, GWL_STYLE, lStyle
 
    'Get the extended window style
    lStyle = GetWindowLong(mhWndForm, GWL_EXSTYLE)
 
    'Build up and set the extended window style
    SetBit lStyle, WS_EX_APPWINDOW, mbAppWindow
    SetBit lStyle, WS_EX_TOOLWINDOW, mbToolWindow
 
    SetWindowLong mhWndForm, GWL_EXSTYLE, lStyle
 
    'Handle the close button differently
    If mbCloseBtn Then
        'We want it, so reset the control menu
        hMenu = GetSystemMenu(mhWndForm, 1)
    Else
        'We don't want it, so delete it from the control menu
        hMenu = GetSystemMenu(mhWndForm, 0)
        DeleteMenu hMenu, SC_CLOSE, 0&
    End If
 
    'Update the window with the changes
    DrawMenuBar mhWndForm
    SetFocus mhWndForm
 
End Sub
 
'Procedure to set or clear a bit from a style flag
Private Sub SetBit(ByRef lStyle As Long, ByVal lBit As Long, ByVal bOn As Boolean)
    If bOn Then
        lStyle = lStyle Or lBit
    Else
        lStyle = lStyle And Not lBit
    End If
End Sub
 
'Procedure to set the form's icon
Private Sub ChangeIcon()
 
    Dim hIcon As Long
 
    On Error Resume Next
 
    If mhWndForm <> 0 Then
 
        Err.Clear
        If msIconPath = "" Then
            hIcon = 0
        ElseIf Dir(msIconPath) = "" Then
            hIcon = 0
        ElseIf Err.Number <> 0 Then
            hIcon = 0
        ElseIf Not mbIcon Then
            'Get the icon from the source
            hIcon = ExtractIcon(0, msIconPath, 0)
        Else
            hIcon = 0
        End If
 
        'Set the big (32x32) and small (16x16) icons
        SendMessage mhWndForm, WM_SETICON, True, hIcon
        SendMessage mhWndForm, WM_SETICON, False, hIcon
    End If
 
End Sub

[marycaLou]

Merci. Cela fonctionne. Il me fallait juste ajuster certaines lignes comme vous m'avez indiqué.

Encore une fois merci.

[marycaLou]

Bonjour,
ce sont des questions purement vba , tu trouveras des solutions pour excel qui vont marcher aussi pour outlook

voilà des solutions que m'a donné GOOGLE

pour la souris

http://www.mrexcel.com/forum/excel-q...lications.html
http://www.ozgrid.com/forum/showthread.php?t=184493
http://stackoverflow.com/questions/1...mbobox-listbox

J'ai regardé et tenté d'intégrer le code défini dans les liens (surtout le premier lien) et ça ne marche pas. Je l'ai adapté à mon programme, toujours rien. Est-ce que quelqu'un saurait comment faire dérouler une liste déroulante (listbox) avec le bouton central de la souris. J'aurais besoin de l'information rapidement.

Merci

[Oliv-]

SAlut,
J'ai testé le code trouvé ici

et il fonctionne

Dans un userform mettre un Listbox se nommant ListBox1

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
''''' Userform code
Private Sub ListBox1_Change()
' be sure to include Error handling for any code that
' might get called while the hook is running
     On Error GoTo errExit
     Me.Caption = Me.ListBox1.Value
     Exit Sub
errExit:
End Sub
 
Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start tthe hook
     HookListBoxScroll
End Sub
 
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
     s = "this is line "
     For i = 1 To 50
             Me.ListBox1.AddItem s & i
     Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     UnhookListBoxScroll
End Sub
''''''' end Userform code

dans un module

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
 
 
''''''' normal module code
 
Option Explicit
 
Private Type POINTAPI
     x As Long
     y As Long
End Type
 
Private Type MOUSEHOOKSTRUCT
     pt As POINTAPI
     hwnd As Long
     wHitTestCode As Long
     dwExtraInfo As Long
End Type
 
Private Declare Function FindWindow Lib "user32" _
                     Alias "FindWindowA" ( _
                             ByVal lpClassName As String, _
                             ByVal lpWindowName As String) As Long
 
Private Declare Function GetWindowLong Lib "user32.dll" _
                     Alias "GetWindowLongA" ( _
                             ByVal hwnd As Long, _
                             ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" _
                     Alias "SetWindowsHookExA" ( _
                             ByVal idHook As Long, _
                             ByVal lpfn As Long, _
                             ByVal hmod As Long, _
                             ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" ( _
                             ByVal hHook As Long, _
                             ByVal nCode As Long, _
                             ByVal wParam As Long, _
                             lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                             ByVal hHook As Long) As Long
 
Private Declare Function PostMessage Lib "user32.dll" _
                     Alias "PostMessageA" ( _
                             ByVal hwnd As Long, _
                             ByVal wMsg As Long, _
                             ByVal wParam As Long, _
                             ByVal lParam As Long) As Long
 
Private Declare Function WindowFromPoint Lib "user32" ( _
                             ByVal xPoint As Long, _
                             ByVal yPoint As Long) As Long
 
Private Declare Function GetCursorPos Lib "user32.dll" ( _
                             ByRef lpPoint As POINTAPI) As Long
 
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
 
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
 
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
 
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
        GetCursorPos tPT
        hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
        If mListBoxHwnd <> hwndUnderCursor Then
             UnhookListBoxScroll
             mListBoxHwnd = hwndUnderCursor
                lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
             If Not mbHook Then
                     mLngMouseHook = SetWindowsHookEx( _
                                                     WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                     mbHook = mLngMouseHook <> 0
             End If
     End If
End Sub
 
Sub UnhookListBoxScroll()
     If mbHook Then
             UnhookWindowsHookEx mLngMouseHook
             mLngMouseHook = 0
             mListBoxHwnd = 0
             mbHook = False
     End If
End Sub
 
Private Function MouseProc( _
             ByVal nCode As Long, ByVal wParam As Long, _
             ByRef lParam As MOUSEHOOKSTRUCT) As Long
        On Error GoTo errH 'Resume Next
        If (nCode = HC_ACTION) Then
             If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
                     If wParam = WM_MOUSEWHEEL Then
                             MouseProc = True
                             If lParam.hwnd > 0 Then
                                     PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                             Else
                                     PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                             End If
                             PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                             Exit Function
                     End If
             Else
                     UnhookListBoxScroll
             End If
     End If
        MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
        UnhookListBoxScroll
End Function

[marycaLou]

SAlut,
J'ai testé le code trouvé ici

et il fonctionne

Dans un userform mettre un Listbox se nommant ListBox1

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
''''' Userform code
Private Sub ListBox1_Change()
' be sure to include Error handling for any code that
' might get called while the hook is running
     On Error GoTo errExit
     Me.Caption = Me.ListBox1.Value
     Exit Sub
errExit:
End Sub
 
Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start tthe hook
     HookListBoxScroll
End Sub
 
Private Sub UserForm_Initialize()
Dim i As Long
Dim s As String
     s = "this is line "
     For i = 1 To 50
             Me.ListBox1.AddItem s & i
     Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     UnhookListBoxScroll
End Sub
''''''' end Userform code

dans un module

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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
 
 
''''''' normal module code
 
Option Explicit
 
Private Type POINTAPI
     x As Long
     y As Long
End Type
 
Private Type MOUSEHOOKSTRUCT
     pt As POINTAPI
     hwnd As Long
     wHitTestCode As Long
     dwExtraInfo As Long
End Type
 
Private Declare Function FindWindow Lib "user32" _
                     Alias "FindWindowA" ( _
                             ByVal lpClassName As String, _
                             ByVal lpWindowName As String) As Long
 
Private Declare Function GetWindowLong Lib "user32.dll" _
                     Alias "GetWindowLongA" ( _
                             ByVal hwnd As Long, _
                             ByVal nIndex As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" _
                     Alias "SetWindowsHookExA" ( _
                             ByVal idHook As Long, _
                             ByVal lpfn As Long, _
                             ByVal hmod As Long, _
                             ByVal dwThreadId As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" ( _
                             ByVal hHook As Long, _
                             ByVal nCode As Long, _
                             ByVal wParam As Long, _
                             lParam As Any) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                             ByVal hHook As Long) As Long
 
Private Declare Function PostMessage Lib "user32.dll" _
                     Alias "PostMessageA" ( _
                             ByVal hwnd As Long, _
                             ByVal wMsg As Long, _
                             ByVal wParam As Long, _
                             ByVal lParam As Long) As Long
 
Private Declare Function WindowFromPoint Lib "user32" ( _
                             ByVal xPoint As Long, _
                             ByVal yPoint As Long) As Long
 
Private Declare Function GetCursorPos Lib "user32.dll" ( _
                             ByRef lpPoint As POINTAPI) As Long
 
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
 
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
 
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
 
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
        GetCursorPos tPT
        hwndUnderCursor = WindowFromPoint(tPT.x, tPT.y)
        If mListBoxHwnd <> hwndUnderCursor Then
             UnhookListBoxScroll
             mListBoxHwnd = hwndUnderCursor
                lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
                PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
             If Not mbHook Then
                     mLngMouseHook = SetWindowsHookEx( _
                                                     WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
                     mbHook = mLngMouseHook <> 0
             End If
     End If
End Sub
 
Sub UnhookListBoxScroll()
     If mbHook Then
             UnhookWindowsHookEx mLngMouseHook
             mLngMouseHook = 0
             mListBoxHwnd = 0
             mbHook = False
     End If
End Sub
 
Private Function MouseProc( _
             ByVal nCode As Long, ByVal wParam As Long, _
             ByRef lParam As MOUSEHOOKSTRUCT) As Long
        On Error GoTo errH 'Resume Next
        If (nCode = HC_ACTION) Then
             If WindowFromPoint(lParam.pt.x, lParam.pt.y) = mListBoxHwnd Then
                     If wParam = WM_MOUSEWHEEL Then
                             MouseProc = True
                             If lParam.hwnd > 0 Then
                                     PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
                             Else
                                     PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
                             End If
                             PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                             Exit Function
                     End If
             Else
                     UnhookListBoxScroll
             End If
     End If
        MouseProc = CallNextHookEx( _
                             mLngMouseHook, nCode, wParam, ByVal lParam)
     Exit Function
errH:
        UnhookListBoxScroll
End Function

Enfin, cela fonctionne. merci