insertion d'une date dans une cellule à partir d'un calendrier

**Bouom771** · 03/12/2007, 20h02

Bonsoir,

Après le lancement de la fonction "Recherche", je n'ai rien trouvé de semblable à mon problème.

Voilà, Je suis complètement novice en VBE.

Je crée actuellement un document Excel dédié au prêt de vidéoprojecteur et de portable, pour le boulot.

Je voudrai donc savoir comment insérer une date par un simple clic, choisie dans un calendrier, afin que celle-ci s'affiche dans la cellule voulue.

J'ai suivi ce tuto pour l'affichage simple : http://opus-all.paris.iufm.fr/tr&ast...?id_article=51

Après cette phase, pourriez-vous m'indiquer pas à pas la procédure pour mener à bien mon projet.

Merci à vous tous.

**fred65200** · 03/12/2007, 22h20

bonjour,
Je vais te proposer une adaptation d'un code trouvé sur le net et je n'ai malheureusement pas noté la source. Si elle se reconnaît, merci de m'en informer pour que je puisse le spécifier.

1 tu insères un userform dans ton projet, nomme le ufCalendrier
2 dans ce userform, tu place un CommandButton nommé CommandButton1
3 Tu colles le code suivant dans le module de code du 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
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
 
' Tout le code n'est pas de moi, et j'ai oublié la source. J'en suis désolé
Option Explicit
Private Sub UserForm_Initialize()
    Const WS_CHILD& = &H40000000, MONTHCAL_CLASS$ = "SysMonthCal32", _
        MCM_FIRST& = &H1000&, MCM_GETMINREQRECT& = (MCM_FIRST + 9&), _
        SWP_SHOWWINDOW& = &H40&, MCS_NOTODAY& = &H10&, _
        MCS_NOTODAYCIRCLE& = &H8&, ICC_DATE_CLASSES& = &H100&
 
    Const SM_CYCAPTION = 4
    Dim CalRect As RECT, LeTop&, LeLeft&, hwnd&, Marge&, CvtPtPixel!, _
        IniCtrl As InitCommonControlsExType, PtCal As PointAPI
    LeTop = 5&
    Marge = 5&
    CvtPtPixel = 3 / 4
    hwnd = FindWindow(vbNullString, Me.Caption)
'Création du controle calendrier
    With IniCtrl
        .dwSize = Len(IniCtrl)
        .dwICC = ICC_DATE_CLASSES
    End With
    InitCommonControlsEx IniCtrl
    mWnd = CreateWindowEx(0&, MONTHCAL_CLASS, vbNullString, _
        WS_CHILD Or MCS_NOTODAY Or MCS_NOTODAYCIRCLE _
        , 0&, 0&, 0&, 0&, hwnd, 0&, 0&, 0&)
'Ajustement de la position du control calendrier
    SendMessage mWnd, MCM_GETMINREQRECT, 0&, CalRect
    SetWindowPos mWnd, 0, LeTop, Marge, CalRect.Right + Marge, _
        CalRect.Bottom + LeTop, SWP_SHOWWINDOW
'Ajustement de la position des boutons
    GetWindowRect mWnd, CalRect
    With CalRect
        PtCal.x = .Right
        PtCal.y = .Top
    End With
    ScreenToClient hwnd, PtCal
    LeLeft = PtCal.x * CvtPtPixel + Marge
    With CommandButton1
        .Left = LeLeft
        .Top = Marge
    End With
'Ajustement de la taille du UserForm
    With CalRect
        PtCal.x = .Top
        PtCal.y = .Bottom
    End With
    ScreenToClient hwnd, PtCal
    With Me
        .StartUpPosition = 0
        .CommandButton1.Height = PtCal.y * CvtPtPixel - Marge
        .CommandButton1.Width = 23
        .CommandButton1.Caption = "OK"
        .Width = CommandButton1.Width + LeLeft + Marge * 2
        .Height = (PtCal.x + PtCal.y) * CvtPtPixel + Marge
        .Top = PtCur.y * CvtPtPixel
        .Left = PtCur.x * CvtPtPixel
    End With
End Sub
 
Private Sub CommandButton1_Click()
    Const MCM_FIRST& = &H1000&, MCM_GETCURSEL& = (MCM_FIRST + 1&)
    Dim LeTime As SYSTEMTIME
'Récuperer la date sélectionnée
    SendMessage mWnd, MCM_GETCURSEL, 0&, LeTime
    With LeTime
        Dim laDate As Date
        laDate = Format(DateSerial(.wYear, .wMonth, .wDay), "Short Date")  '"dd-mmm-yy") '"Short Date")
        Me.Hide
        ActiveCell = CDate(laDate):
        ActiveCell(1, 2).Select:
    End With
    Unload Me
End Sub
 
 
Private Sub UserForm_Terminate()
'Détruire le control calendrier
    DestroyWindow mWnd
End Sub

4 Colle le code suivant dans le module de la feuille où tu veux faire apparaître ton calendrier. Ajuste la zone à ta convenance, ici colonnes C et D

Code :

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

1
2
3
4
5
6
7
8
 
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'ici pour les colonne C et D (3 et 4)
If Target.Column = 3 Or Target.Column = 4 And Target.Count = 1 Then _
    Cancel = True: GetCursorPos PtCur: ufCalendrier.Show
 
End Sub

5 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
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
 
Option Explicit
Public Declare Function FindWindow& Lib "user32" _
    Alias "FindWindowA" _
    (ByVal lpClassName$, ByVal lpWindowName$)
 
Public Declare Function ScreenToClient& Lib "user32" _
    (ByVal hwnd&, ByRef lpPoint As PointAPI)
 
Public Declare Function GetWindowRect& Lib "user32" _
    (ByVal hwnd&, lpRect As RECT)
 
Public Declare Function CreateWindowEx& Lib "user32" _
    Alias "CreateWindowExA" _
    (ByVal dwExStyle&, ByVal lpClassName$, ByVal lpWindowName$, _
    ByVal dwStyle&, ByVal x&, ByVal y&, ByVal nWidth&, _
    ByVal nHeight&, ByVal hWndParent&, ByVal hMenu&, _
    ByVal hInstance&, ByRef lpParam As Any)
 
Public Declare Function InitCommonControlsEx& Lib "comctl32" _
    (ByRef INITCOMMONCONTROLSEXData As InitCommonControlsExType)
 
Public Declare Function DestroyWindow& Lib "user32" _
    (ByVal hwnd&)
 
Public Declare Function SendMessage& Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByRef lParam As Any)
 
Public Declare Function SetWindowPos& Lib "user32" _
    (ByVal hwnd&, ByVal hWndInsertAfter&, ByVal x&, _
    ByVal y&, ByVal cx&, ByVal cy&, ByVal wFlags&)
 
 Declare Function GetCursorPos Lib "user32" ( _
    lpPoint As PointAPI) As Long
 
Public Type InitCommonControlsExType
    dwSize As Long
    dwICC As Long
End Type
 
Public Type PointAPI
    x As Long
    y As Long
End Type
 
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Public mWnd&
Public PtCur As PointAPI

Ce code fonctionne sans Contrôle Calendrier
Testé sur Vista et Excel 2007, XP excel 2003

cordialement

**SilkyRoad** · 04/12/2007, 05h27

bonjour Bouom, chers Fred et Myta ... ;o)

encore une autre possibilité:

http://www.developpez.net/forums/sho...d.php?t=430867

bonne journée
michel

**Bouom771** · 04/12/2007, 20h19

Un grand merci à tous les contributeurs !

Je vais tenter les procédures gracieusement mises à ma disposition, puis vous transmettrais les résultats dès que possible.

**Oh!Tofocus** · 08/12/2007, 23h45

Envoyé par fred65200

Ce code fonctionne sans Contrôle Ccalendrier
Testé sur Vista et Excel 2007, XP excel 2003

Pour ma part le code de fred marche trés bien sur EXEL 97

Merci pour cette routine que j'ai adapté sur une feuille qui ne demandait que ça !

Encore bravo à ce super forum

insertion d'une date dans une cellule à partir d'un calendrier

Macros et VBA Excel

Discussions similaires

Partager

Partager