SELECT IDUtilisateur, Prenom & " " & NomFamille AS NomComplet
FROM TBLUtilisateurs
WHERE IDUtilisateur <> 123456789;
ORDER BY NomFamille

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then
	    '........... [Code vu plus loin]
    End If
End Sub

''' ************************************************************************************
''' Project name        :   Gestionnaire de Post-It pour applications Access
''' Purpose             :   Module dédié aux calculs nécessaires à l'ajustement du contrôle
'''                         du formulaire en fonction du texte qu'il contient
'''-------------------------------------------------------------------------------------
''' Module              :   frmPostitNew - Classe
''' Created on          :   28/07/2008
''' Author              :   Jean-Philippe AMBROSINO
'''-------------------------------------------------------------------------------------
''' Contact WEB         :   http://argyronet.developpez.com
''' ************************************************************************************

Option Compare Database
Option Explicit

''' Classe de la gestion de la molette de la souris
Private WithEvents clsMouseWheel As MouseWheel.CMouseWheel

Private Sub chkAnotherUser_Click()
'---------------------------------------------------------------------------
' Procedure     : chkAnotherUser_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement clic de la case à cocher permettant de choisir un autre utilisateur
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
Dim oQDF                                As DAO.QueryDef
Dim SQLSelect                           As String
Dim lngIDUser                           As Long

    ''' Requête contenant les utilisateurs
Const QUERY_USERLIST                       As String = "qry_Combo_GetListOfUsers"
    
    ''' Obtention de l'ID utilisateur
    lngIDUser = GetCurrentIDUser()
    ''' Construction de la chaîne SQL visant à mettre à jour la requête
    SQLSelect = "SELECT TBL_Users.IDUser, [LastName] &" & Chr(34) & " " & Chr(34) & _
    "& [FirstName] AS FullName"
    SQLSelect = SQLSelect & vbCrLf & "FROM TBL_Users"
    SQLSelect = SQLSelect & vbCrLf & "WHERE TBL_Users.IDUser <> " & lngIDUser & _
    " AND TBL_Users.IDUser <> " & DATA_IDU_NONE & " AND TBL_Users.IsActivated=True;"
    ''' Affectation d'un objet QueryDefs avec la nouvelle valeur SQL
    Set oQDF = CurrentDb.QueryDefs(QUERY_USERLIST)
    oQDF.SQL = SQLSelect
    '''Si c'est un autre utilisateur que vous
    If Me!chkAnotherUser Then
        ''' On affecte la requête à la propriété RowSource et toutes les propriétés corrélatives
        With cmbUsers
            .RowSource = QUERY_USERLIST
            .Enabled = True
            .Locked = False
            .SetFocus
            .Dropdown
        End With
    Else
        ''' On donne le focus directement à la zone de texte avec tous les propriétés corrélatives
        txtPostItContent.SetFocus
        With cmbUsers
            .RowSource = vbNullString
            .Locked = True
            .Enabled = False
        End With
        Me!cmbUsers = vbNullString
    End If
End Sub

Private Sub clsMouseWheel_MouseWheel(Cancel As Integer)
'---------------------------------------------------------------------------
' Procedure     : chkAnotherUser_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseWheel de la classe clsMouseWheel :
'                 Désactive la molette (Version Access 2000)
'...........................................................................
' Parameters    : Cancel => True = Désactivé
' Return Codes  : Aucun
'---------------------------------------------------------------------------
  Cancel = True
End Sub

Private Sub cmdCancel_Click()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement clic du bouton Annuler :
'                 Annule le message et ferme le formulaire
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    If MsgBox("Souhaitez-vous annuler la création du PostIt ?", _
    vbExclamation + vbYesNo, "Annuler") = vbYes Then
      On Error Resume Next
      DoCmd.RunCommand acCmdUndo
      If err <> 0 Then err.Clear
      DoCmd.Close acForm, Me.Name
      DoCmd.OpenForm "frmMainMenu", acNormal, , , , acDialog
    End If
End Sub

Private Sub cmdSave_Click()
Dim strFrom As String
Dim strDate As String
Dim SQLSelect As String

Dim lngIDUser As Long
Dim strPreviousMessage As String
Dim strPostItContent As String
Dim strNewMessage As String
Dim blnShown As Boolean

Dim blnAlreadyGotMessage As Boolean
Dim blnForMeOnly As Boolean

Dim oRS As DAO.Recordset
  ''' On vérifie que le message n'est pas vide avant d'enregistrer
  If IsNull(strPostItContent) Or Len(strPostItContent) < 3 Then
    MsgBox "Un message doit être inscrit avant d'enregistrer !", _
    vbExclamation, "Message requis"
    Exit Sub
  End If
  ''' On définit alors le nom de l'émetteur du message à l'aide de l'API GetUserName()
  ''' et de la table des utilisateurs
  strFrom = GetCurrentUserName(True)
  ''' on définit la date du jour de rédaction du message
  strDate = "Le " & Format(Now, "d mmmm yyyy") & " à " & _
  Left(Format(Now, "hh:mm"), 2) & "h" & Right(Format(Now, "hh:mm"), 2) & ", "
  ''' On définit du destinataire du message : vous-même ou un autre utilisateur
  If IsNull(Me!chkAnotherUser) Then
    lngIDUser = GetCurrentIDUser()
    blnForMeOnly = True
  Else
    If Me!chkAnotherUser Then
      lngIDUser = Me!cmbUsers
      blnForMeOnly = False
    Else
      lngIDUser = GetCurrentIDUser()
      blnForMeOnly = True
    End If
  End If
  ''' On vérifie si le destinataire du message possède déjà un autre message
  strPreviousMessage = GetStringFieldValueFromTable( _
  "TBLPostIt", "IDUser", "PostItContent", lngIDUser)
  blnAlreadyGotMessage = (Len(strPreviousMessage) > 0)
  ''' Construction de la clause SQL
  SQLSelect = "SELECT IDUser, PostItContent, TypeOfMessage, Shown, FormName, IDKeyCriteria"
  SQLSelect = SQLSelect & vbCrLf & "FROM TBLPostIt"
  ''' Rédaction du message en fonction du destinataire
  If blnForMeOnly Then
    If blnAlreadyGotMessage Then
      strPostItContent = vbCrLf & vbCrLf & strDate & _
      "je me suis de nouveau écrit ce message :" & vbCrLf & Me!txtPostItContent
      SQLSelect = SQLSelect & vbCrLf & "WHERE IDUser = " & lngIDUser
    Else
      strPostItContent = strDate & "je me suis écrit ce message :" & vbCrLf & Me!txtPostItContent
    End If
  Else
    If blnAlreadyGotMessage Then
      strPostItContent = vbCrLf & vbCrLf & strDate & strFrom & _
      " vous a écrit :" & vbCrLf & Me!txtPostItContent
      SQLSelect = SQLSelect & vbCrLf & "WHERE IDUser = " & lngIDUser
    Else
      strPostItContent = strDate & strFrom & " vous a écrit :" & vbCrLf & Me!txtPostItContent
    End If
  End If
  ''' Affectation à la variable du message et de son contenu
  strNewMessage = strPreviousMessage & strPostItContent
  ''' On réinitialise certains contrôles
  blnShown = False
  strFormName = vbNullString
  lngIDKeyCriteria = 0
  ''' Selon le cas, on met à jour ou on ajoute un enregistrement dans la table
  On Error GoTo L_ErrCannotAddData
  Set oRS = CurrentDb.OpenRecordset(SQLSelect, 2)
  With oRS
    If blnAlreadyGotMessage Then
      .Edit     ' Met à jour
    Else
      .AddNew   ' Ajoute l'enregistrement
    End If
    .Fields("IDUser") = lngIDUser
    .Fields("PostItContent") = strNewMessage
    .Fields("Shown") = blnShown
    .update
  End With
  Set oRS = Nothing
  ''' Affectation des contrôles
  cmdCancel.Caption = CMD_CLOSE
  cmdCancel.SetFocus
  chkAnotherUser.Enabled = False
  txtPostItContent.Locked = True
  cmdSave.Enabled = False
L_ExCannotAddData:
  ''' Libération des objets instanciés
  Set oRS = Nothing
  Exit Sub
L_ErrCannotAddData:
  MsgBox Err.Description, vbCritical, Err
  Resume L_ExCannotAddData
End Sub

Private Sub Form_Close()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Close du formulaire
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
  On Error Resume Next
  clsMouseWheel.SubClassUnHookForm
  Set clsMouseWheel.Form = Nothing
  Set clsMouseWheel = Nothing
End Sub

Private Sub Form_Load()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Load du formulaire : initialise la classe MouseWheel
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
  Set clsMouseWheel = New MouseWheel.CMouseWheel
  Set clsMouseWheel.Form = Me
  clsMouseWheel.SubClassHookForm
End Sub

Private Sub imgInfo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'image représentant l'icône
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub imgPostit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'image représentant la feuille
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub lblTitle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'étiquette du titre du message
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub txtPostItContent_Change()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Change de la zone de texte
'                 Libère l'état du bouton Enregistrer
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
  cmdSave.Enabled = (Len(Me!txtPostItContent.Text) > 0)
End Sub

Private Sub MoveForm(F As Form)
'---------------------------------------------------------------------------
' Procedure     : MoveForm
' DateTime      : 17/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Permet de déplacer un formulaire dépourvu de barre de titre
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    ReleaseCapture
    SendMessageCapture F.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

''' ************************************************************************************
''' Project name        :   Gestionnaire de Post-It pour applications Access
''' Purpose             :   Module dédié aux calculs nécessaire à l'ajustement du contrôle
'''                         du formulaire en fonction du texte qu'il contient
'''-------------------------------------------------------------------------------------
''' Module              :   frmPostit - Classe
''' Created on          :   28/07/2008
''' Author              :   Jean-Philippe AMBROSINO
'''-------------------------------------------------------------------------------------
''' Contact WEB         :   http://argyronet.developpez.com
''' ************************************************************************************

Option Compare Database
Option Explicit

''' Classe de la gestion de la molette de la souris
Private WithEvents clsMouseWheel        As MouseWheel.CMouseWheel
Private Sub clsMouseWheel_MouseWheel(Cancel As Integer)
'---------------------------------------------------------------------------
' Procedure     : chkAnotherUser_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseWheel de la classe clsMouseWheel :
'                 Désactive la molette (Version Access 2000)
'...........................................................................
' Parameters    : Cancel => True = Désactivé
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    Cancel = True
End Sub

Private Sub Form_Close()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Close du formulaire
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    On Error Resume Next
    clsMouseWheel.SubClassUnHookForm
    Set clsMouseWheel.Form = Nothing
    Set clsMouseWheel = Nothing
End Sub

Private Sub Form_Current()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Current du formulaire
'                 Calcule la hauteur nécessaire pour la zone de texte devant
'                 contenir le message avec la fonction GetTextLength()
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
Const MARGIN_HEIGHT                     As Integer = 32

    Me.txtPostItContent.Height = GetTextLength(Me!txtPostItContent)
    Me.Section("Detail").Height = Me.txtPostItContent.Top + _
        Me.txtPostItContent.Height + MARGIN_HEIGHT
    Me.InsideHeight = Me.Section("Detail").Height + MARGIN_HEIGHT
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement KeyDown du formulaire
'
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
Dim intAnswer                           As Integer
    If KeyCode = vbKeyEscape Then
        intAnswer = MsgBox("Voulez-vous supprimer ce message avant de fermer ?", _
            vbQuestion + vbDefaultButton3 + vbYesNoCancel, "Supprimer")
        Select Case intAnswer
            Case vbCance ' On sort
                Exit Sub
            Case vbNo   ' On affecte True à la case à cocher
                Me!chkShown = True
            Case vbYes  ' On supprime le message via la procédure DeleteMessage()
                DeleteMessage Me!txtIDUser
        End Select
        DoCmd.Close acForm, Me.Name
    End If
End Sub

Private Sub Form_Load()
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement Load du formulaire : initialise la classe MouseWheel
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    Set clsMouseWheel = New MouseWheel.CMouseWheel
    Set clsMouseWheel.Form = Me
    clsMouseWheel.SubClassHookForm
End Sub

Private Sub imgInfo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'image représentant l'icône
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub imgPostit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'image représentant la feuille
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub lblTitle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'étiquette du titre du message
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub txtPostItContent_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---------------------------------------------------------------------------
' Procedure     : cmdCancel_Click
' DateTime      : 28/07/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Evénement MouseMove de l'étiquette du titre du message
'                 Permet de déplacer la fenêtre
'...........................................................................
' Parameters    : Button, Shift, X, Y (Voir Aide - F1)
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    MoveForm Me
End Sub

Private Sub DeleteMessage(ByVal IDUser As Long)
'---------------------------------------------------------------------------
' Procedure     : DeleteMessage
' DateTime      : 17/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Supprime tous les messages de l'utilisateur sélectionné
'...........................................................................
' Parameters    : IDUser = identifiant de l'utilisateur
' Return Codes  :
'---------------------------------------------------------------------------
Dim oRS                                 As DAO.Recordset

    Set oRS = CurrentDb.OpenRecordset( _
    "SELECT * FROM TBLPostIt WHERE IDUser = " & txtIDUser, dbOpenDynaset)
    With oRS
        If Not .EOF Then
            Do While Not .EOF
                .Delete
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set oRS = Nothing
End Sub

Private Sub MoveForm(F As Form)
'---------------------------------------------------------------------------
' Procedure     : MoveForm
' DateTime      : 17/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Permet de déplacer un formulaire dépourvu de barre de titre
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Aucun
'---------------------------------------------------------------------------
    ReleaseCapture
    SendMessageCapture F.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

''' ************************************************************************************
''' Project name        :   Gestionnaire de Post-It pour applications Access
''' Purpose             :   Module dédié aux calculs nécessaires à l'ajustement du contrôle
'''                         du formulaire en fonction du texte qu'il contient
'''-------------------------------------------------------------------------------------
''' Module              :   frmMainMenu - Classe
''' Created on          :   28/07/2008
''' Author              :   Jean-Philippe AMBROSINO
'''-------------------------------------------------------------------------------------
''' Contact WEB         :   http://argyronet.developpez.com
''' ************************************************************************************

Option Compare Database
Option Explicit

''' [....]
''' [....]
''' [Blocs des autres événements]
''' [....]

Private Sub cmdNewPostIt_Click()
'---------------------------------------------------------------------------
' Procedure     : cmdNewPostIt_Click
' DateTime      : 17/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Permet de générer un nouveau message
'...........................................................................
' Parameters    : Aucun
' Return Codes  :
'---------------------------------------------------------------------------
  DoCmd.OpenForm "frmPopupPostIt_New", , , , acFormAdd, acDialog
End Sub

''' [....]
''' [....]
''' [Blocs des autres événements]
''' [....]

Private Sub Form_Timer()
'---------------------------------------------------------------------------
' Procedure     : Form_Timer
' DateTime      : 17/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Permet de déterminer s'il faut afficher un message
'                 On obtient l'ID utilisateur et on compte ses messages
'...........................................................................
' Parameters    : Aucun
' Return Codes  :
'---------------------------------------------------------------------------
Dim intNBMessages                       As Integer
Dim lngCurrentUser                      As Long
Dim strSQL                              As String
Dim oRS                                 As DAO.Recordset
    '''On désactive le Timer
    Me.TimerInterval = 0
    ''' On compte le nombre de messages
    strSQL "SELECT COUNT(*) FROM TBLPostIt WHERE IDUser = " & GetCurrentIDUser()
    Set oRS = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
    With oRS
        If Not .EOF Then
            ''' On ouvre le formulaire
            DoCmd.OpenForm "frmPopupPostIt", , , "[IDUser]=" & lngCurrentUser, acFormEdit, acDialog
        End If
        .Close
    End With
    Set oRS = Nothing
End Sub

''' [....]
''' [....]
''' [Blocs des autres événements]
''' [....]

''' ************************************************************************************
''' Project name        :   Gestionnaire de Post-It pour applications Access :
''' Purpose             :   Module dédié aux calculs nécessaires à l'ajustement du contrôle
'''                         Textbox du formulaire en fonction du texte qu'il contient
'''-------------------------------------------------------------------------------------
''' Module              :   basPostIt - Module
''' Created on          :   28/07/2008
''' Author              :   Jean-Philippe AMBROSINO
'''-------------------------------------------------------------------------------------
''' Contact WEB         :   http://argyronet.developpez.com
''' ************************************************************************************

Option Compare Database
Option Explicit

''' API et constante de déplacement de la fenêtre
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

' API dédiée à obtenir les caractéristiques d'un périphérique
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal lngDC As Long, ByVal nIndex As Long) As Long

' API permettant de définir les informations du contexte d'un périphérique donné
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long

' API permettant de supprimer le contexte spécifié (DC)
Private Declare Function DeleteDC Lib "gdi32" ( _
ByVal lngDC As Long) As Long

' API permettant de sélectionner un objet dans un contexte
Private Declare Function SelectObject Lib "gdi32" ( _
ByVal lngDC As Long, ByVal hObject As Long) As Long

' API permettant de supprimer un objet dans un contexte
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long

' API permettant de "dessiner" du texte formaté dans un rectangle selon des spécifications
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" ( _
ByVal lngDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long

' API dédiée à la création d'une police logique avec caractéristiques identiques à l'originale
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" ( _
lpLogFont As LOGFONT) As Long

' API Retourne le Handle d'un contexte
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

' API dédiée à libérer la mémoire pour un context donné
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, ByVal lngDC As Long) As Long

Private Type RECT
    Gauche                              As Long
    Haut                                As Long
    Bottom                              As Long
    Right                               As Long
End Type

Private Type LOGFONT
    lfHeight                            As Long
    lfWidth                             As Long
    lfEscapement                        As Long
    lfOrientation                       As Long
    lfWeight                            As Long
    lfItalic                            As Byte
    lfUnderline                         As Byte
    lfStrikeOut                         As Byte
    lfCharSet                           As Byte
    lfOutPrecision                      As Byte
    lfClipPrecision                     As Byte
    lfQuality                           As Byte
    lfPitchAndFamily                    As Byte
    lfFaceName                          As String * 32
End Type

Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

Private Const CLIP_LH_ANGLES As Long = 16
Private Const OUT_TT_ONLY_PRECIS As Long = 7

Private Const DT_Haut As Long = &H0
Private Const DT_Gauche As Long = &H0
Private Const DT_WORDBREAK As Long = &H10
Private Const DT_CALCRECT As Long = &H400

'---------------------------------------------------------------------------
' Procedure     : GetTextLength
' DateTime      : 02/08/2008
' Author        : Jean-Philippe AMBROSINO
' Context       : Code inspiré du tutoriel de cafeine
' Purpose       : Retourne la hauteur nécessaire d'un Textbox pour afficher
'                 son contenu dans son intégralité
'...........................................................................
' Parameters    : FormControl = Control de type Textbox contenant le texte
'                 [TextToCheck] = Chaîne représentant le texte affiché
' Return Codes  : Long
'---------------------------------------------------------------------------
Public Function GetTextLength(ByVal FormControl As Control, Optional ByVal TextToCheck As String = "") As Long
Dim tyFONT                              As LOGFONT
Dim tyRECT                              As RECT
Dim lngDC                               As Long
Dim lngNewFont                          As Long
Dim lngOldFont                          As Long
Dim lngRet                              As Long
Dim strText                             As String
    
    ' Vérification du texte
    If Len(TextToCheck) = 0 Then
        strText = FormControl.Value & Chr(0)
    Else
        strText = TextToCheck & Chr(0)
    End If

    lngDC = GetDC(0&)

    ' Obtention du rectangle représenté par le contrôle
    tyRECT.Bottom = CountPixelsX(FormControl.Width)
    ' Obtention du contexte et création du texte avec les caractéristaiques de la  police
    With FormControl
        tyFONT.lfClipPrecision = CLIP_LH_ANGLES
        tyFONT.lfOutPrecision = OUT_TT_ONLY_PRECIS
        tyFONT.lfEscapement = 0
        tyFONT.lfFaceName = .FontName & Chr$(0)
        tyFONT.lfWeight = .FontWeight
        tyFONT.lfItalic = .FontItalic
        tyFONT.lfUnderline = .FontUnderline
        tyFONT.lfHeight = (.FontSize / 72) * -GetDeviceCaps(lngDC, 90)
        lngNewFont = CreateFontIndirect(tyFONT)
    End With

    ' Selectionne un objet Font
    lngOldFont = SelectObject(lngDC, lngNewFont)
    lngRet = DrawText(lngDC, strText, -1&, tyRECT, DT_CALCRECT Or DT_Haut Or DT_Gauche Or DT_WORDBREAK)
    ' Restaure la police originale
    SelectObject lngDC, lngOldFont
    ' Supprime la police précédement créée dans le contexte
    DeleteObject lngNewFont
    ' Si l'API DrawText réussi, alors la hauteur du contrôle est calculée en Twips
    GetTextLength = CountTwipsX(tyRECT.Right) + 10
    'On libère alors l'objet du contexte
    ReleaseDC 0&, lngDC
End Function

'---------------------------------------------------------------------------
' Procedure     : GetTwipsPerPixelsX
' DateTime      : 02/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Calcul le nombre de Twips par Pixel X
'...........................................................................
' Parameters    : Aucun
' Return Codes  : Long
'---------------------------------------------------------------------------
Private Function GetTwipsPerPixelsX() As Long
Dim lngDC                      As Long

    lngDC = CreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
    If lngDC <> 0 Then
        GetTwipsPerPixelsX = 1440 / GetDeviceCaps(lngDC, LOGPIXELSX)
        DeleteDC lngDC
    End If
End Function

Private Function CountPixelsX(ByRef NbTwips As Long) As Long
'---------------------------------------------------------------------------
' Procedure     : CountPixelsX
' DateTime      : 02/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Retourne le nombre de Twips selon le nombre de Pixels
'...........................................................................
' Parameters    : NbPixels = Nombre de pixels
' Return Codes  : Long
'---------------------------------------------------------------------------
    CountPixelsX = NbTwips / GetTwipsPerPixelsX
End Function

Private Function CountTwipsX(ByRef NbPixels As Long) As Long
'---------------------------------------------------------------------------
' Procedure     : CountTwipsX
' DateTime      : 02/08/2008
' Author        : Jean-Philippe AMBROSINO
' Purpose       : Retourne le nombre de Twips selon le nombre de Pixels
'...........................................................................
' Parameters    : NbPixels = Nombre de pixels
' Return Codes  : Long
'---------------------------------------------------------------------------
    CountTwipsX = NbPixels * GetTwipsPerPixelsX
End Function