[EXCEL 2013] Macro Calendrier fonctionne sous 2016, mais pas 2013

Question

Bonsoir @toute la Communauté!

J'ai souhaité insérer un calendrier dans une cellule Excel, de telle sorte qu'en cliquant dessus une petite fenêtre apparaisse avec un calendrier dedans.

Je suis tombé sur cette page Web qui m'a bien aidé : insérer un calendrier dans une cellule Excel

J'ai téléchargé de là ce fichier: CalAPI.xlsm

J'ai :

1. Copié la UserForm "Calendrier" dans mon fichier et
2. Inséré le code ci-dessous dans la feuille concernée:

=========================================

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address(0, 0) = "B7" Then Calendrier1.Show

End Sub

=========================================

Alors, tout cela ça fonctionne parfaitement sur mon PC où j'ai Excel 2016 (Win7), mais dès que mon DGA l'ouvre sur son PC dans son Excel 2013 (Win10), il a immédiatement l'erreur suivante qui s'affiche:

Saurez vous me dire pourquoi réagit il ainsi et que faire pour corriger ce problème?

D'avance merci @tous!

Evguen

Answer 1

J'ai une erreur de syntaxe. Peux-tu vérifier qu'il n'y a pas d'erreur de recopie dans cette parie :

Private Declare Function CreateWindowEx& Lib "user32" _

    Alias "CreateWindowExA" _

    (ByVal dwExStyle&**** ByRef lpParam As Any)

Daniel

Bonjour,

J'ai vérifié, et apparemment tout est correct:

Private Declare Function CreateWindowEx& Lib "user32" _

    Alias "CreateWindowExA" _

    (ByVal dwExStyle&**** ByRef lpParam As Any)

Vous pouvez aussi télécharger le fichier d'ici et vérifier par vous-même: CalAPI.xlsm

Excellente journée!

Evguen

Answer 2

Essaie ce code. Je n'ai pas pu les tester. Tiens-moi au courant.

#If VBA6 Then

  Private Declare Function FindWindow& Lib "user32" _

    Alias "FindWindowA" _

    (ByVal lpClassName$, ByVal lpWindowName$)

  Private Declare Function ScreenToClient& Lib "user32" _

      (ByVal hwnd&, ByRef lpPoint As POINTAPI)

  Private Declare Function GetWindowRect& Lib "user32" _

      (ByVal hwnd&, lpRect As RECT)

  Private Declare Function CreateWindowEx& Lib "user32" _

      Alias "CreateWindowExA" _

      (ByVal dwExStyle&, ByRef lpParam As Any)

  Private Declare Function InitCommonControlsEx& Lib "COMCTL32" _

      (ByRef INITCOMMONCONTROLSEXData As InitCommonControlsExType)

  Private Declare Function DestroyWindow& Lib "user32" _

      (ByVal hwnd&)

  Private Declare Function SendMessage& Lib "user32" _

      Alias "SendMessageA" _

      (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByRef lParam As Any)

  Private Declare Function SetWindowPos& Lib "user32" _

      (ByVal hwnd&, ByVal hWndInsertAfter&, ByVal x&, _

      ByVal y&, ByVal cx&, ByVal cy&, ByVal wFlags&)

#Else

  Private Declare PtrSafe Function FindWindow Lib "user32" _

    Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$) As LongPtr

  Declare PtrSafe Function ScreenToClient Lib "user32" _

    (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long

  Declare PtrSafe Function GetWindowRect Lib "user32" _

    (ByVal hwnd As LongPtr, lpRect As RECT) As Long

  Declare PtrSafe Function CreateWindowEx Lib "user32" _

    Alias "CreateWindowExA" _

    (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName)

  Private Declare PtrSafe Function InitCommonControlsEx Lib "COMCTL32" _

    (ByRef INITCOMMONCONTROLSEXData As InitCommonControlsExType) As Boolean

  Declare PtrSafe Function DestroyWindow Lib "user32" _

    (ByVal hwnd As LongPtr) As Long

  Private Declare Function SendMessage& Lib "user32" _

      Alias "SendMessageA" _

      (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByRef lParam As Any)

  Declare PtrSafe Function SendMessage Lib "user32" _

    Alias "SendMessageA" _

    (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

  Declare PtrSafe Function SetWindowPos Lib "user32" _

 _

    (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _

    ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _

    ByVal wFlags As Long) As Long

#End If

Private Type InitCommonControlsExType

    dwSize As Long

    dwICC As Long

End Type

Private Type POINTAPI

    x As Long

    y As Long

End Type

Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

Private 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

Private mWnd&

Public ObjetSource As Object, MaDate As Date

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&

    Dim CalRect As RECT, LeTop&, LeLeft&, hwnd&, Marge&, CvtPtPixel!, _

        IniCtrl As InitCommonControlsExType, PtCal As POINTAPI

    LeTop = 10&

    Marge = 10&

    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 = PtCal.y * CvtPtPixel + 75

        LeTop = LeTop * 2 + .Height

    End With

'Ajustement de la taille du UserForm

    With CalRect

        PtCal.x = .Top

        PtCal.y = .Bottom

    End With

    ScreenToClient hwnd, PtCal

    With Me

        .Width = CommandButton1.Width + LeLeft + Marge + 10

        .Height = (PtCal.x + PtCal.y) * CvtPtPixel

    End With

    Set ObjetSource = ActiveCell

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 dans une cellule

    SendMessage mWnd, MCM_GETCURSEL, 0&, LeTime

    With LeTime

        'MsgBox "Vous avez choisi le : " & vbNewLine & vbTab & _

            Format(DateSerial(.wYear, .wMonth, .wDay), "dddd dd mmmm yyyy") & "."

            MaDate = DateSerial(.wYear, .wMonth, .wDay)

'Récupérer la date sélectionnée dans une TextBox

            If Not ObjetSource Is Nothing Then

                If InStr(1, "Range,TextBox", TypeName(ObjetSource)) >= 1 Then ObjetSource.Value = MaDate

            End If

    End With

    Unload Me

End Sub

Private Sub UserForm_Terminate()

'Détruire le control calendrier

    DestroyWindow mWnd

End Sub

Answer 3

J'ai une erreur de syntaxe. Peux-tu vérifier qu'il n'y a pas d'erreur de recopie dans cette parie :

Private Declare Function CreateWindowEx& Lib "user32" _

    Alias "CreateWindowExA" _

    (ByVal dwExStyle&**** ByRef lpParam As Any)

Daniel

Answer 4

Bonjour,

Il s'agit d'un problème incompatibilité entre le VBA 32 bits et le VBA 64 bits. Il faudrait que tu publies la totalité de ton code. Je ne suis pas sûr de pouvoir tout corriger...

Daniel

Bonsoir Daniel et merci pour cette rapide intervention.

Le code complet de "Calendrier1" est le suivant:

===================================

Option Explicit

Private Declare Function FindWindow& Lib "user32" _

    Alias "FindWindowA" _

    (ByVal lpClassName$, ByVal lpWindowName$)

Private Declare Function ScreenToClient& Lib "user32" _

    (ByVal hWnd&, ByRef lpPoint As POINTAPI)

Private Declare Function GetWindowRect& Lib "user32" _

    (ByVal hWnd&, lpRect As RECT)

Private Declare Function CreateWindowEx& Lib "user32" _

    Alias "CreateWindowExA" _

    (ByVal dwExStyle&**** ByRef lpParam As Any)

Private Declare Function InitCommonControlsEx& Lib "comctl32" _

    (ByRef INITCOMMONCONTROLSEXData As InitCommonControlsExType)

Private Declare Function DestroyWindow& Lib "user32" _

    (ByVal hWnd&)

Private Declare Function SendMessage& Lib "user32" _

    Alias "SendMessageA" _

    (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, ByRef lParam As Any)

Private Declare Function SetWindowPos& Lib "user32" _

    (ByVal hWnd&, ByVal hWndInsertAfter&, ByVal x&, _

    ByVal y&, ByVal cx&, ByVal cy&, ByVal wFlags&)

Private Type InitCommonControlsExType

    dwSize As Long

    dwICC As Long

End Type

Private Type POINTAPI

    x As Long

    y As Long

End Type

Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

Private 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

Private mWnd&

Public ObjetSource As Object, MaDate As Date

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&

    Dim CalRect As RECT, LeTop&, LeLeft&, hWnd&, Marge&, CvtPtPixel!, _

        IniCtrl As InitCommonControlsExType, PtCal As POINTAPI

    LeTop = 10&

    Marge = 10&

    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 = PtCal.y * CvtPtPixel + 75

        LeTop = LeTop * 2 + .Height

    End With

'Ajustement de la taille du UserForm

    With CalRect

        PtCal.x = .Top

        PtCal.y = .Bottom

    End With

    ScreenToClient hWnd, PtCal

    With Me

        .Width = CommandButton1.Width + LeLeft + Marge + 10

        .Height = (PtCal.x + PtCal.y) * CvtPtPixel

    End With

    Set ObjetSource = ActiveCell

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 dans une cellule

    SendMessage mWnd, MCM_GETCURSEL, 0&, LeTime

    With LeTime

        'MsgBox "Vous avez choisi le : " & vbNewLine & vbTab & _

            Format(DateSerial(.wYear, .wMonth, .wDay), "dddd dd mmmm yyyy") & "."

            MaDate = DateSerial(.wYear, .wMonth, .wDay)

'Récupérer la date sélectionnée dans une TextBox

            If Not ObjetSource Is Nothing Then

                If InStr(1, "Range,TextBox", TypeName(ObjetSource)) >= 1 Then ObjetSource.Value = MaDate

            End If

    End With

    Unload Me

End Sub

Private Sub UserForm_Terminate()

'Détruire le control calendrier

    DestroyWindow mWnd

End Sub

===================================

Encore merci!

Evguen

Answer 5

Bonjour,

Il s'agit d'un problème incompatibilité entre le VBA 32 bits et le VBA 64 bits. Il faudrait que tu publies la totalité de ton code. Je ne suis pas sûr de pouvoir tout corriger...

Daniel