Option Compare Database
'déclaration du type Rect
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
'déclaration des constantes
Private Const SW_SHOWMAXIMIZED = 3
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_HIDEWINDOW As Long = &H80
Private Const SWP_SHOWWINDOW As Long = &H40
 
'déclarations des API utiles
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 SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
 
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
 
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
 
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
 
 
 
 
Private Sub AfficherMenu(bolVisible As Boolean)
On Error Resume Next
Dim oBar As CommandBar
Dim Db As DAO.Database
Dim oRst As DAO.Recordset
'Instancie la BD
Set Db = CurrentDb
'Vide la table de sauvegarde si bolVisible=False
If Not bolVisible Then _
  Db.Execute "DELETE FROM TblBarre"
 
If Not bolVisible Then
  'Parcours chaque barre d'outils
  For Each oBar In Application.CommandBars
    'Stocke les barres visible dans la table
    If oBar.Visible Then
      Db.Execute "INSERT INTO TblBarre VALUES (" & Chr(34) & oBar.Name & Chr(34) & ")"
      'Masque la barre
      oBar.Visible = bolVisible
    End If
  Next
Else
  'Ouvre un recordset sur la table de sauvegarde
  Set oRst = Db.OpenRecordset("TblBarre")
  'Parcours le recordset
  While Not oRst.EOF
    'Restaure la barre concernée
    Application.CommandBars(oRst.Fields(0).Value).Visible = bolVisible
    'Passe au suivant
    oRst.MoveNext
  Wend
  'Ferme le curseu
  oRst.Close
End If
'Traite la barre de menu principale
DoCmd.ShowToolbar "Menu bar", IIf(bolVisible, acToolbarYes, acToolbarNo)
'Traite la barre d'état
Application.SetOption "Show Status Bar", bolVisible
End Sub
 
Private Sub AfficherBarreTitre(bolVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
'Récupère le rectangle de la fenêtre
GetWindowRect Application.hWndAccessApp, vrWin
'Récupère le style de la fenêtre
style = GetWindowLong(Application.hWndAccessApp, GWL_STYLE)
If bolVisible Then
   SetWindowLong Application.hWndAccessApp, GWL_STYLE, style Or WS_CAPTION
Else
   SetWindowLong Application.hWndAccessApp, GWL_STYLE, style And Not WS_CAPTION
End If
SetWindowPos Application.hWndAccessApp, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
     vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub
 
Private Sub AfficherBarreTache(bolVisible As Boolean)
    Dim hwnd As Long
    Dim rctTemp As RECT
    Dim inthauteur As Integer
    Dim intResolutionX As Integer, intResolutionY As Integer
    'Récupère le handle de la barre des taches
    hwnd = FindWindow("Shell_traywnd", "")
    'Récupère le rectangle de la barre des taches
    GetWindowRect hwnd, rctTemp
    'Calcule les dimensions
    inthauteur = rctTemp.Bottom - rctTemp.Top
    'Récupère les dimensions de l'écran
    intResolutionX = GetDeviceCaps(GetDC(0), 8)
    intResolutionY = GetDeviceCaps(GetDC(0), 10)
    If bolVisible Then
      'Affiche la barre des taches
      SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW
      'Redimensionne la fenêtre Access
      SetWindowPos Application.hWndAccessApp, 0, 0, 0, intResolutionX, _
       intResolutionY - inthauteur, &H20
    Else
      'Masque la barre des taches
      SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW
      'Redimensionne la fenêtre sur la totalité de l'écran
      SetWindowPos Application.hWndAccessApp, 0, 0, 0, intResolutionX, _
       intResolutionY, &H20
    End If
End Sub
 
Public Sub PleinEcran(bolEtat As Boolean)
'On Error GoTo err
'Si bolEtat=Vrai alors PleinEcran
'Sinon, retour à l'origine
'fige l'affichage
 
DoCmd.Echo False
AfficherMenu bolEtat
AfficherBarreTitre bolEtat
AfficherBarreTache bolEtat
'agrandit le formulaire en cours
DoCmd.Maximize
'Rétablit l'affichage
err:
DoCmd.Echo True
'Change l'état
bolEtat = Not bolEtat
End Sub

Option Compare Database
Dim BolState As Boolean

Private Sub MonBouton_Click()
PleinEcran BolState
End Sub

Function DisplayHdrFtr(ByVal strForm As String, ByVal OnOff As Boolean)
 
' Nous allons savoir si l'entete est activé par capture d'erreur
On Error GoTo CatchHdrFtr
 
DoCmd.OpenForm strForm, acDesign, , , , acHidden
 
 
' Vérifie si la section existe
Forms(strForm).Section("EntêteFormulaire").Height = _
  Forms(strForm).Section("EntêteFormulaire").Height
' signifie que la section existe
' n'agit que s'il est demandé de masquer
If Not (OnOff) Then
    DoCmd.RunCommand acCmdFormHdrFtr
End If
DoCmd.Close acForm, strForm, acSaveYes
Exit Function
 
CatchHdrFtr:
Select Case err.Number
    Case 2461
        ' cas ou la section n'existe pas
        If OnOff Then
            DoCmd.RunCommand acCmdFormHdrFtr
            DoCmd.Close acForm, strForm, acSaveYes
        End If
 
    Case 2102
        ' cas ou le form n'existe pas
        MsgBox "Le  formulaire " & strForm & "  n'existe pas.", _
           vbCritical + vbOKOnly
 
    Case Else
        MsgBox "Erreur n°" & err.Number & " : " & err.Description, _
           vbInformation + vbOKOnly
        err.Clear
End Select
DoCmd.Close acForm, strForm, acSaveYes
DoCmd.OpenForm strForm, acNormal
End Function

DoCmd.OpenForm strForm, acDesign

DisplayHdrFtr("Test", false)

Public Function AfficherInfo(CtlLabel as Control, CtlSource as control) As Boolean 
'Fonction qui utilise la propriété TAG de CtlSource 
'pour modifier la propriété Caption de l'étiquette 
'CtlLabel 
'Pour induire un renvoi à la ligne, il suffit de mettre la 
'Série de caractères %n% dans le texte du TAG 
    CtlLabel.Caption=Replace(CtlSource.Tag,"%n%",vbcrlf) 
End Function

AfficherInfo lblInfos, ctl1

Option Explicit
 
Private Sub AutoSizeGrid(ByVal RS As ADODB.Recordset, _
 ByVal GridObject As DataGrid, ByVal Tolerance As Single)
Dim oFields As Object
Dim nCurrentSize As Single
Dim nNewSize As Single
Dim nbRowsVisible As Integer
Dim oCol As Column
Dim I As Long
Dim R As Long
 
    I = -1
    GridObject.Row = 0
    nbRowsVisible = GridObject.VisibleRows
    With GridObject
    For R = 1 To nbRowsVisible
        For Each oFields In RS.Fields
          I = I + 1
          Set oCol = GridObject.Columns(I)
          nCurrentSize = TextWidth(Trim(oCol)) * Tolerance
          With oCol
            Select Case I
              Case 0
                Column0 = oCol.Width
                nNewSize = IIf(Column0 > nCurrentSize, Column0, nCurrentSize)
              Case 1
                Column1 = oCol.Width
                nNewSize = IIf(Column1 > nCurrentSize, Column1, nCurrentSize)
              Case 2
                Column2 = oCol.Width
                nNewSize = IIf(Column2 > nCurrentSize, Column2, nCurrentSize)
              Case 3
                Column3 = oCol.Width
                nNewSize = IIf(Column3 > nCurrentSize, Column3, nCurrentSize)
            End Select
            .Width = nNewSize
          End With
        Next oFields
      I = -1
      On Error Resume Next
      GridObject.Row = R
      Next R
    End With
    clearAllSize
    GridObject.Row = 0
End Sub
 
Private Sub clearAllSize()
'Mettre les propriétés à zéro
    Column0 = 0
    Column1 = 0
    Column2 = 0
    Column3 = 0
End Sub

Option Explicit
 
Private m_SizeCol0 As Single
Private m_SizeCol1 As Single
Private m_SizeCol2 As Single
Private m_SizeCol3 As Single
 
Public Property Get Column0() As Single
    Column0 = m_SizeCol0
End Property
 
Public Property Let Column0(ByVal ColSize As Single)
    If Column0 < ColSize Then m_SizeCol0 = ColSize
End Property
 
Public Property Get Column1() As Single
    Column1 = m_SizeCol1
End Property
 
Public Property Let Column1(ByVal ColSize As Single)
    If Column1 < ColSize Then m_SizeCol1 = ColSize
End Property
 
Public Property Get Column2() As Single
    Column2 = m_SizeCol2
End Property
 
Public Property Let Column2(ByVal ColSize As Single)
    If Column2 < ColSize Then m_SizeCol2 = ColSize
End Property
 
Public Property Get Column3() As Single
    Column3 = m_SizeCol3
End Property
 
Public Property Let Column3(ByVal ColSize As Single)
    If Column3 < ColSize Then m_SizeCol3 = ColSize
End Property

Private Sub cmdAutoSize_Click()
    AutoSizeGrid oRS1, DataGridCustomers, 1.09
End Sub

 'Replie la fenêtre de la gauche vers la droite
Public Const AW_HOR_POSITIVE = &H1
 'Replie la fenêtre de la droite vers la gauche
Public Const AW_HOR_NEGATIVE = &H2
 'Replie la fenêtre du haut vers le bas
Public Const AW_VER_POSITIVE = &H4 
 'Replie la fenêtre du bas vers le haut
Public Const AW_VER_NEGATIVE = &H8 
'Masque la fenêtre
Public Const AW_HIDE = &H10000 
 
Public Declare Function AnimateWindow Lib "user32" _
(ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) _
As Boolean

Private Sub Form_Unload(Cancel As Integer)
    AnimateWindow Me.hwnd, 200, AW_VER_NEGATIVE _
     Or AW_HOR_NEGATIVE Or AW_HIDE
End Sub

'Declaration des constantes de Menu
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
 
'Type Point pour localiser la souris
Private Type POINTAPI
    X As Long
    Y As Long
End Type
 
'Declaration des API
Private Declare Function CreatePopupMenu Lib "user32" () As Long
 
Private Declare Function TrackPopupMenuEx Lib "user32" _
(ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, _
ByVal Y As Long, ByVal HWnd As Long, ByVal lptpm As Any) As Long
 
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal HWnd As Long, ByVal bRevert As Long) As Long
 
Private Declare Function AppendMenu Lib "user32" Alias _
"AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, _
ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
 
Private Declare Function DestroyMenu Lib "user32" _
(ByVal hMenu As Long) As Long
 
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private Sub Texte1_MouseUp(Button As Integer, Shift As Integer _
, X As Single, Y As Single)
 
'Traite le cas d'un clic droit
If Button = 2 Then
    'Declaration
    Dim Pt As POINTAPI
    Dim result As Long
    Dim hMenu As Long
    Dim TypeMenu1 As Long
    Dim TypeMenu2 As Long
    Dim TypeMenu4 As Long
    'Si le texte est vide alors le type de menu sera : Desactiver
    If Texte1.Text = "" Then
        TypeMenu1 = MF_GRAYED Or MF_DISABLED
        TypeMenu2 = MF_GRAYED Or MF_DISABLED
        TypeMenu4 = MF_GRAYED Or MF_DISABLED
        'sinon,
    Else
        'Le menu Effacer sera actif
        TypeMenu4 = MF_STRING
        'Coche le menu correspondant au format du texte
        'Si majucsule, alors cocher option majuscule
        'Si minuscule,cocher option minuscule
        TypeMenu1 = IIf(Texte1.Text = UCase(Texte1.Text), _
           MF_CHECKED, MF_STRING)
 
        TypeMenu2 = IIf(Texte1.Text = LCase(Texte1.Text),  _
           MF_CHECKED, MF_STRING)
    End If
    'Creer le menu contextuel
    hMenu = CreatePopupMenu()
    'Creer les items du menu contextuel
    AppendMenu hMenu, TypeMenu1, 1, "Majuscule"
    AppendMenu hMenu, TypeMenu2, 2, "Minuscule"
    'Ajoute un séparateur dans le menu contextuel
    AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0&
    AppendMenu hMenu, TypeMenu4, 4, "Effacer"
    'Récupere l'emplacement de la souris
    GetCursorPos Pt
    'Affiche le menu à l'emplacement de la souris
    'Et récupere la valeur de l'item cliqué
    result = TrackPopupMenuEx(hMenu, _
    TPM_LEFTALIGN Or TPM_RETURNCMD _
    Or TPM_RIGHTBUTTON, Pt.X, Pt.Y, Me.HWnd, ByVal 0&)
    'Supprime le menu
    DestroyMenu hMenu
    'Traite le resultat
    Select Case result
        Case 1
            Texte1.Text = UCase(Texte1.Text)
        Case 2
            Texte1.Text = LCase(Texte1.Text)
        Case 4
            Texte1.Text = ""
    End Select
End If
 
End Sub

    AppendMenu hMenu, TypeMenu1, 1, "Majuscule"

Function TraceFlch(ByVal Couleur As Long, ByVal Taille As Long, ByVal Angle As Double) 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    'Fonction traçant une flèche à partir de 3 traits : 
    'trCorps, trGauche, trDroit 
    ' 
    'Arguments : 
    'Couleur = Entier long compris entre 0 & 16777215 
    'Taille = Longueur de la flèche en twips 
    'Angle = exprimé en degrés 
    ' 
    'Créée le 22/12/2002 par Maxence HUBICHE 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Dim v As Variant 
Const CoeffTaille   As Double = 0.1         'Taille de la pointe : 10% longueur fleche 
Const DecalAngle    As Double = 15          'Angle de la pointe : 5° par rapport au corps 
'##Définition de la couleur 
    trCorps.BorderColor = Couleur 
    trGauche.BorderColor = Couleur 
    trDroit.BorderColor = Couleur 
'##Définition du corps de la flèche 
    v = GetCoeff(Angle) 
    trCorps.Left = 500 
    trCorps.Top = 500 
    trCorps.Width = v(0) * Taille 
    trCorps.Height = v(1) * Taille 
    trCorps.LineSlant = TypeOrientation(Angle) 
'##Définition de la première pointe 
    v = GetCoeff(Angle + DecalAngle) 
    trDroit.Width = v(0) * Taille * CoeffTaille 
    trDroit.Height = v(1) * Taille * CoeffTaille 
    trDroit.LineSlant = TypeOrientation(Angle) 
'##Définition de la première pointe 
    v = GetCoeff(Angle - DecalAngle) 
    trGauche.Width = v(0) * Taille * CoeffTaille 
    trGauche.Height = v(1) * Taille * CoeffTaille 
    trGauche.LineSlant = TypeOrientation(Angle) 
'##Position de la flêche 
'--Définition des Top 
    Select Case Angle 
        Case 0 To 180 
            trDroit.Top = trCorps.Top 
            trGauche.Top = trCorps.Top 
        Case 180 To 360 
            trDroit.Top = trCorps.Top + trCorps.Height - trDroit.Height 
            trGauche.Top = trCorps.Top + trCorps.Height - trGauche.Height 
    End Select 
'--Définition des left 
    Select Case Angle 
        Case 0 To 90, 270 To 360 
            trDroit.Left = trCorps.Left + trCorps.Width - trDroit.Width 
            trGauche.Left = trCorps.Left + trCorps.Width - trGauche.Width 
        Case Else 
            trDroit.Left = trCorps.Left 
            trGauche.Left = trCorps.Left 
    End Select 
End Function 
Function GetCoeff(ByVal Angle As Double) As Variant 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    'Fonction renvoyant le coefficient multiplicateur pour la largeur et la hauteur 
    'index 0 coeff pour la largeur 
    'index 1 coeff pour la hauteur 
    ' 
    'Arguments : 
    'Angle = exprimé en degrés 
    ' 
    'Créée le 22/12/2002 par Maxence HUBICHE 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Dim x As Double 
Dim y As Double 
Dim Angle2 As Double 
Const PI As Double = 3.14159265358979 
'##Faire le calcul rapporté à 90° en radians 
    Angle2 = (Angle Mod 90) * PI / 180 
    x = Abs(Cos(Angle2)) 
    y = Abs(Sin(Angle2)) 
'##En fonction de l'angle 
    If Angle Mod 180 > 90 Then 
        GetCoeff = Array(y, x) 
    Else 
        GetCoeff = Array(x, y) 
    End If 
End Function 
 
Function TypeOrientation(ByVal Angle As Double) As Boolean 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
    'Fonction renvoyant la valeur de la propriété LineSlant 
    'du trait "/" (True) ou "\" (False) 
    ' 
    'Arguments : 
    'Angle = exprimé en degrés 
    ' 
    'Créée le 22/12/2002 par Maxence HUBICHE 
'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
'##Evaluation du LineSlant 
    If Angle Mod 180 > 90 Then 
        TypeOrientation = False 
    Else 
        TypeOrientation = True 
    End If 
 
End Function

'Enumération des types d'affichages possible
'               Clients/Commandes/Produits
Enum mhTypeElement
    mhTypeElementClients = 1
    mhTypeElementCommandes = 2
    mhTypeElementProduits = 3
End Enum

Sub FillListView(ByVal TypeElement As mhTypeElement)
'-----------------------------------------------
' Procedure : FillListView
' Créée le  : jeudi 10 mars 2005 22:46
' Auteur    : Maxence
' Objet     : Procédure principale de remplissage
'               Cette procédure récupère les informations à afficher
'               Lance le tri par défaut
'               Reprends l'affichage dernièrement choisi
'-----------------------------------------------
'
'Variable de Recordset
Dim rs As ADODB.Recordset   
'Variable tableau pour la source de données   
Dim sDataSources(3) As String
'Variable compteur du nombre de lignes
Dim intTotCount As Integer    
'Variable de compteur 1
Dim intCount1 As Integer       
'Variable de compteur 2
Dim intCount2 As Integer       
'Chaque ligne ajoutée dans le listView
Dim NewLine As Object          
 
On Error GoTo GestErr
 
'Vidage du listView
 lvwElements.ListItems.Clear
 lvwElements.ColumnHeaders.Clear
 
 'Remplissage et définition des variables de sources de données
 sDataSources(mhTypeElementClients) = "rqtClient"
 sDataSources(mhTypeElementCommandes) = "rqtCommande"
 sDataSources(mhTypeElementProduits) = "rqtProduit"
 'Initialisation et ouverture du recordset
 Set rs = New ADODB.Recordset
  rs.Open sDataSources(TypeElement), _
     CurrentProject.Connection, adOpenStatic, adLockReadOnly
  ' Définition des En-Têtes de colonnes (Un par colonne)
  For intCount1 = 0 To rs.Fields.Count - 1
   'SYNTAXE GENERALE : object.Add(index, key, text, width, alignment, icon)
   lvwElements.ColumnHeaders.Add , , rs.Fields(intCount1).Name
  Next intCount1
 
  ' Définition du nombre d'enregistrements
  intTotCount = rs.RecordCount
  ' Boucle sur les enregistrements pour définir les lignes
  For intCount1 = 1 To intTotCount
   'SYNTAXE GENERALE : object.Add(index, key, text, icon, smallIcon)
   Set NewLine = lvwElements.ListItems.Add()
   'La clé de la ligne est l'identifiant.
   'Dans notre cas, il s'agit de la première colonne
   NewLine.Key = "ID" & CStr(rs(0).Value)
   NewLine.Text = rs(0).Value
   'La première colonne est toujours le texte principal à afficher
   NewLine.Icon = TypeElement   'Affecte les icones
   NewLine.SmallIcon = TypeElement
   For intCount2 = 2 To rs.Fields.Count
    'Ajout des informations complémentaires (Report)
    NewLine.SubItems(intCount2 - 1) = Nz(rs(intCount2 - 1).Value, "")
   Next intCount2
   rs.MoveNext
  Next intCount1
 
  'Définition de l'ordre d'affichage des données
  OrderByCol 1, True
  'Définition du type d'affichage par défaut (Icon, SmallIcon, ...)
  lvwElements.View = cdrVisu
 
Finprog:
    On Error Resume Next
    Exit Sub
'En cas d'erreur :
GestErr:
    Select Case Err.Number
 
        Case 65000
            MsgBox Err.Description, vbExclamation, "UBI"
        Case Else
            MsgBox "L'Erreur N° " & Err.Number & " (" & _
            Err.Description & _
            ") s'est produite de manière inattendue dans la procédure" & _
            " FillListView du module Document VBA Form_frmAccueil", _
            vbCritical, "ERREUR INATTENDUE"
    End Select
    Resume Finprog
End Sub

sDataSources(mhTypeElementClients) = "rqtClient"
sDataSources(mhTypeElementCommandes) = "rqtCommande"
sDataSources(mhTypeElementProduits) = "rqtProduit"

  For intCount1 = 0 To rs.Fields.Count - 1
   'SYNTAXE GENERALE : object.Add(index, key, _
   '                    text, width, alignment, icon)
   lvwElements.ColumnHeaders.Add , , rs.Fields(intCount1).Name
  Next intCount1

  For intCount1 = 1 To intTotCount
   'SYNTAXE GENERALE : object.Add(index, key, _
   '                                   text, icon, smallIcon)
   Set NewLine = lvwElements.ListItems.Add()
   'La clé de la ligne est l'identifiant.
   'Dans notre cas, il s'agit de la première colonne
   NewLine.Key = "ID" & CStr(rs(0).Value)
   NewLine.Text = rs(0).Value
   'La première colonne est toujours le texte principal à afficher
   NewLine.Icon = TypeElement   'Affecte les icones
   NewLine.SmallIcon = TypeElement
   For intCount2 = 2 To rs.Fields.Count
    'Ajout des informations complémentaires (Report)
    NewLine.SubItems(intCount2 - 1) = _
        Nz(rs(intCount2 - 1).Value, "")
   Next intCount2
   rs.MoveNext
  Next intCount1

  OrderByCol 1, True
  'Définition du type d'affichage par défaut (Icon, SmallIcon, ...)
  lvwElements.View = cdrVisu

Sub OrderByCol(ByVal NumCol As Long, _
         ByVal NewFill As Boolean)
'------------------------------------
' Procedure : OrderByCol
' Créée le  : jeudi 10 mars 2005 22:55
' Auteur    : Maxence
' Objet     : Procédure gérant le tri
' Arguments : NumCol = N° de la colonne sélectionnée lors du clic
'             NewFill = VRAI s'il s'agit d'un remplissage de la liste, faux sinon
'------------------------------------
'
    Static Colonne As Long
debut:
    'La liste est triée
    lvwElements.Sorted = True
    'Si c'est un RECLIC
    If NumCol = Colonne And Not NewFill Then
        'Changer l'ordre de tri et 
        'l'affichage du petit logo qui va avec
        If lvwElements.SortOrder = 0 Then
            lvwElements.SortOrder = 1
            lvwElements.ColumnHeaders(NumCol).Icon = 2
        Else
            lvwElements.SortOrder = 0
            lvwElements.ColumnHeaders(NumCol).Icon = 1
        End If
    Else        'Sinon, remise à 0 de tous les affichage => tri croissant
        If Colonne <> 0 Then _
           lvwElements.ColumnHeaders(Colonne).Icon = 0
        Colonne = NumCol
        NewFill = False
        lvwElements.SortOrder = 1
        lvwElements.SortKey = _
          lvwElements.ColumnHeaders(NumCol).Index - 1
        'et on met à jour
        GoTo debut
    End If
 
End Sub

Private Sub lvwElements_ColumnClick _
    (ByVal ColumnHeader As Object)
'--------------------------------------
' Procedure : lvwElements_ColumnClick
' Créée le  : jeudi 10 mars 2005 22:54
' Auteur    : Maxence
' Objet     : Cette procédure se déclenche à 
'                 chaque fois qu'on clique sur un
'                 en-tete de colonne. 
'                 Elle sert à lancer la procédure de tri des données
'--------------------------------------
'
    OrderByCol ColumnHeader.Index, False
End Sub

FillListView cdrTypeElement

Private Sub ListeSports_AfterUpdate()
 ListEpreuve.RowSource = "Select [ID_Epreuves],[Epreuve],[IDSport] From T_Epreuves " & _
                          "where IDSport= " & ListeSports & ";"
 ListEpreuve.Requery
End Sub

Option Compare Database 
Option Explicit 
 
Private m_intActualValue As Integer 
 
Private Sub cmdDecrease_Click() 
  If IsNull(Me!txtValeur) Then Me!txtValeur = 0 
  m_intActualValue = Me!txtValeur 
  If m_intActualValue < 1 Then 
    m_intActualValue = 0 
    cmdIncrease.SetFocus 
    cmdDecrease.Enabled = False 
    Exit Sub 
  End If 
  cmdIncrease.Enabled = True 
  m_intActualValue = m_intActualValue - 1 
  Me!txtValeur = m_intActualValue 
End Sub 
 
Private Sub cmdIncrease_Click() 
  If IsNull(Me!txtValeur) Then Me!txtValeur = 0 
  m_intActualValue = Me!txtValeur 
  If m_intActualValue >= 15 Then 
    m_intActualValue = 15 
    cmdDecrease.SetFocus 
    cmdIncrease.Enabled = False 
    Exit Sub 
  End If 
  cmdDecrease.Enabled = True 
  m_intActualValue = m_intActualValue + 1 
  Me!txtValeur = m_intActualValue 
End Sub

SELECT NomPolice FROM Police ORDER BY NomPolice

Public Const LF_FACESIZE = 32
 
Public 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(LF_FACESIZE) As Byte
End Type
 
Public Declare Function GetDC Lib "user32" _
       (ByVal hwnd As Long) As Long
 
Public Declare Function EnumFonts Lib "gdi32" Alias _
       "EnumFontsA" (ByVal HDC As Long, ByVal lpsz As String, _
       ByVal lpFontEnumProc As Long, _
      ByVal lParam As Long) As Long
 
Public Declare Sub CopyMemory Lib "kernel32" Alias _
       "RtlMoveMemory" (pDst As Any, pSrc As Any, _
       ByVal ByteLen As Long)
 
 
Public Function EnumFontProc(ByVal lplf As Long, _
ByVal lptm As Long, ByVal dwType As Long, _
ByVal lpData As Long) As Long
    Dim LF As LOGFONT, FontName As String, FinNom As Long
    CopyMemory LF, ByVal lplf, LenB(LF)
    FontName = StrConv(LF.lfFaceName, vbUnicode)
    FinNom = InStr(1, FontName, Chr$(0))
    If FinNom > 0 Then FontName = Left$(FontName, FinNom - 1)
    'Ajoute la police dans la table
    CurrentDb.Execute ("Insert Into police (NomPolice) Values (" & _
       Chr(34) & FontName & Chr(34) & ")")
    EnumFontProc = 1
End Function

Dim HDC As Long
'vide la table
CurrentDb.Execute ("DELETE FROM police")
HDC = GetDC(Me.hwnd)
'Liste les polices
EnumFonts HDC, vbNullString, AddressOf EnumFontProc, 0

Sub sRafraîchirListes(ByRef unFORM As Form)
 
Dim unCTRL As Control
 
For Each unCTRL In unFORM.Controls
  Select Case Left(unCTRL.Name, 3)
    Case "LST"
      unCTRL.Requery
    Case "SF_"
      sRafraîchirListes unFORM
    End Select
Next unCTRL
 
End Sub

Dim unFORM As Form
 
For Each unFORM In Forms
  sRafraîchirListes unFORM
Next unFORM

Sub subRefreshLists(ByRef oForm As Form) 
Dim oControl As Control 
 
For Each oControl In oForm.Controls 
  Select Case oControl.ControlType 
    Case acListBox,acComboBox 
      oControl.Requery 
    Case acSubform 
      subRefreshListsoControl.Form 
  End Select 
Next oControl 
 
End Sub

Private Sub AjouterProduit_Click() 
  subRefreshLists Me 
End Sub

Dim oRstClient As DAO.Recordset  'Stocke le curseur
Dim intnbLus As Integer   'Stocke le nb d'enregistrements lus la dernière fois

Private Sub Form_Load()
Dim oDb As DAO.Database
'Instancie la base de données
Set oDb = CurrentDb
'Ouvre le recordset
Set oRstClient = oDb.OpenRecordset("Clients", dbOpenTable)
'Lit les 10 premiers
LectureVersLAvant
End Sub
 
Private Sub LectureVersLAvant()
On Error GoTo err
RemplirZoneTexte oRstClient.GetRows(10)
Exit Sub
err:
'Si on est sur le dernier enregistrement
'alors ne rien faire, sinon avertir
If err.Number <> 3021 Then
 MsgBox "Une erreur est survenue pendant la lecture des données", vbCritical, "Erreur"
End If
End Sub

Sub RemplirZoneTexte(Tableau As Variant)
Dim I As Integer
'Récupère le nombre d'enregistrements Lus
intnbLus = UBound(Tableau, 2) + 1
'affecte les valeurs aux zones de texte
For I = 0 To intnbLus - 1
  'Affiche le code client
  Controls("TCodeClient" & I + 1) = Tableau(0, I)
  Controls("TCodeClient" & I + 1).Visible = True
  'Affiche la societe
  Controls("TSociete" & I + 1) = Tableau(1, I)
  Controls("TSociete" & I + 1).Visible = True
  'Affiche la ville
  Controls("TVille" & I + 1) = Tableau(2, I)
  Controls("TVille" & I + 1).Visible = True
  'Affiche le pays
  Controls("TPays" & I + 1) = Tableau(3, I)
  Controls("TPays" & I + 1).Visible = True
Next I
'Masque les autres zones de textes
For I = intnbLus + 1 To 10
  'Masque le code client
  Controls("TCodeClient" & I).Visible = False
  'Masque la societe
  Controls("TSociete" & I).Visible = False
  'Masque la ville
  Controls("TVille" & I).Visible = False
  'Masque le pays
  Controls("TPays" & I).Visible = False
Next I
End Sub

Private Sub LectureVersLArriere()
On Error GoTo err
'Recule du nombre d'enregistrements nécessaire
oRstClient.Move -1 * intnbLus - 10
RemplirZoneTexte oRstClient.GetRows(10)
Exit Sub
err:
Select Case err.Number
  'Si on a trop reculé alors, se positionner sur le premier
  Case 3021: oRstClient.MoveFirst
  'Sinon, Avertir
  Case Else: MsgBox "Une erreur est survenue pendant la lecture des données", vbCritical, "Erreur"
End Select
End Sub

Public Sub Restriction(ByVal Chaine As String, _
         ByVal ChamP As String, ByVal matable As String, _
         ByRef ArGument As Integer, ByRef ClausE As String, ByRef astype As Integer)
 
' Choix du type : 0 pour un string, 1 pour un numérique ou booleen
' 2 pour une date
 
'Construit la requête au premier passage
If ArGument = 0 Then
  'Elimine les espaces
   matable = Trim$(matable)
  'Si table est une sous requete :(commence par select)
  If InStr(1, matable, "SELECT ", vbTextCompare) <> 0 Then
    'Enleve le ; s'il existe
    If Right(matable, 1) = ";" Then _
       matable = Left(matable, Len(matable) - 1)
    'encadre la sous requete avec des ()
    ClausE = "SELECT * FROM (" & matable & ")"
  Else
    ClausE = "SELECT * FROM " & matable
  End If
End If
If Chaine <> "" Then
    If ArGument = 0 Then
     ' Ajoute le WHERE
    ClausE = ClausE & " WHERE "
    ' Ajout de l'opérateur "AND" si le where existe déja
    Else: ClausE = ClausE & " AND "
    End If
    Select Case astype
      Case 0  'Ajoute le critère si le type est texte
        ClausE = ClausE & ChamP & " like " & Chr(34) & Chaine & "*" & Chr(34)
      Case 1  'Ajoute le critère si le type est Numerique
        ClausE = ClausE & ChamP & "=" & Chaine
      Case 2  'Ajoute le critère si le type est date
        ClausE = ClausE & ChamP & "=#" & Format(Chaine, "mm/dd/yyyy") & "#"
    End Select
    ArGument = ArGument + 1
End If
End Sub

Private Sub BRechercher_Click()
Dim SQL As String
Dim NomTable As String
Dim Compteur As Integer
NomTable = "Tbl_Materiel"
'Appel de la procedure de creation de requête
'pour le numero de série de type texte
Restriction Nz(Tserie, ""), "NumSerie", NomTable, Compteur, SQL, 0
'pour la date achat de type date (2)
Restriction Nz(TDate, ""), "DateAchat", NomTable, Compteur, SQL, 2
'Pour la marque de type texte
Restriction Nz(TMarque, ""), "Marque", NomTable, Compteur, SQL, 0
'Affecte la requête au sous formulaire
Me.Tbl_Materiel.Form.RecordSource = SQL
End Sub

NomTable = "SELECT * FROM Tbl_Materiel"

Option Compare Database
Option Explicit
 
'Mémorise le nombre d'enregistrements affichés par le formulaire
Dim mlngCpteEnr As Long
'Mémorise l'information d'utilisation du filtre
Dim mstrFiltré As String

Private Sub btcPrem_Click()
'Instruction à suivre en cas d'erreur :
'entrer dans le bloc de gestion d'erreurs
'nommé GestionErr
On Error GoTo GestionErr
 
'Atteindre le premier enregistrement :
 
  DoCmd.GoToRecord , , acFirst
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.btcPrem_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcPréc_Click()
 
On Error GoTo GestionErr
 
'Atteindre l'enregistrement précédent :
 
  DoCmd.GoToRecord , , acPrevious
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.btcPréc_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcSuiv_Click()
 
On Error GoTo GestionErr
 
'Atteindre l'enregistrement suivant :
 
  DoCmd.GoToRecord , , acNext
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.btcSuiv_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcDern_Click()
 
On Error GoTo GestionErr
 
'Atteindre le dernier enregistrement :
 
  DoCmd.GoToRecord , , acLast
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.btcDern_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcNouv_Click()
 
On Error GoTo GestionErr
 
'Créer un nouvel enregistrement :
 
  DoCmd.GoToRecord , , acNewRec
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " _
      & Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.btcNouv_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub txtAtteindre_BeforeUpdate(Cancel As Integer)
 
'Le code suivant sert à vérifier que la valeur spécifiée
'dans le contôle txtAtteindre est de type numérique :
 
On Error GoTo GestionErr
'Sélection du contôle de saisie de la valeur
'à vérifier (txtAtteindre)
  With Me!txtAtteindre
 
  'On applique la fonction IsNumeric à la valeur du
  'contôle sélectionné afin de vérifier si
  'le type est bien du numérique :
 
    If Not IsNumeric(.Value) Then
 
    'Si aucun nombre n'a été saisi, on avertit l'utilisateur :
      MsgBox "Vous devez saisir un numéro d'enregistrement valide." & _
      vbCrLf & _
        "Vous pouvez appuyer sur Echap pour annuler votre saisie.", _
        vbExclamation
 
    'Puis on repositionne le curseur sur le contrôle sélectionné :
    ' Positionne le curseur au début du champ
      .SelStart = 0
     ' Sélectionne l'ensemble des données affichées dans le champ
      .SelLength = Len(.Value)
 
    'Et on annule la mise à jour de l'événement
    'BeforeUpdate en utilisant son argument Cancel :
      Cancel = True
 
    End If
 
  End With
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.txtAtteindre_BeforeUpdate"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
 
Private Sub txtAtteindre_AfterUpdate()
 
On Error GoTo GestionErr
 
With Me
 
 If mlngCpteEnr = 0 Then
  !txtAtteindre = 1
  MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
   vbCrLf & _
   "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
   vbExclamation
 ElseIf !txtAtteindre > mlngCpteEnr Then
  !txtAtteindre = mlngCpteEnr
  MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
   vbCrLf & _
   "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
   vbExclamation
  ElseIf !txtAtteindre <= 0 Then
   !txtAtteindre = 1
   MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
    vbCrLf & _
    "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
    vbExclamation
  End If
   If !txtAtteindre <> .CurrentRecord Then DoCmd.GoToRecord , , _
    acGoTo, !txtAtteindre
 
End With
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & _
      " : " & Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.txtCourant_AfterUpdate"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub Form_Current()
 
On Error GoTo GestionErr
 
'On appel la procédure de mise à jour des
'données liées aux contrôles de navigation :
 
  sActivation
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.Form_Current"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub Form_BeforeInsert(Cancel As Integer)
 
On Error GoTo GestionErr
 
'Disponibilité des boutons de navigations :
 
  Me!btcSuiv.Enabled = True
  Me!btcNouv.Enabled = True
 
'Le nouvel enregistrement va être ajouté,
'on peut donc mettre à jour mlngCpteEnr :
 
  mlngCpteEnr = mlngCpteEnr + 1
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.Form_BeforeInsert"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub Form_AfterDelConfirm(Status As Integer)
 
Dim strInfosNavig As String
 
On Error GoTo GestionErr
 
'Si un ou plusieurs enregistrements ont été supprimés
If Status = acDeleteOK Then
  Select Case Me.NewRecord
    Case True
      strInfosNavig = "sur " & Me.CurrentRecord & mstrFiltré
      'Mise à jour des infos de navigation (affichées par étqCpteEnr)
    Case False
      sMajInfosNavig
      'Mise à jour des infos de navigation (affichées par étqCpteEnr)
      strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
  End Select
  étqCpteEnr.Caption = strInfosNavig
End If
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.Form_AfterDelConfirm"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub sActivation()
 
On Error GoTo GestionErr
 
Dim strInfosNavig As String
 
'Affiche le numéro de l'enregistrement en cours :
 
  Me!txtAtteindre = Me.CurrentRecord
 
'Disponibilité des boutons de navigations :
  'On ne peut aller vers l'enregistrement précédent
  'que si nous ne sommes pas déjà sur le premier.
  Me!btcPréc.Enabled = (Me.CurrentRecord > 1)
  Select Case Me.NewRecord
    Case True
      Me!btcSuiv.Enabled = False
      Me!btcNouv.Enabled = False
      'Mise à jour des infos de navigation
      '(affichées par étqCpteEnr)
      strInfosNavig = "sur " & Me.CurrentRecord
       'Mise à jour des infos de navigation
       '(affichées par étqCpteEnr)
      If Me.FilterOn Then strInfosNavig = strInfosNavig & " (Filtré)"
    Case False
      Me!btcSuiv.Enabled = True
      Me!btcNouv.Enabled = True
      If Me.CurrentRecord = 1 Then sMajInfosNavig
      'Mise à jour des infos de navigation
      '(affichées par étqCpteEnr)
      strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
  End Select
 
'Mise à jour des infos de navigation (suite) :
 
  étqCpteEnr.Caption = strInfosNavig
 
  Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.sActivation"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub sMajInfosNavig()
 
  Dim rs As DAO.Recordset
 
On Error GoTo GestionErr
 
  'On indique si le filtre est activé
  If Me.FilterOn Then mstrFiltré = " (Filtré)"
 
  'On compte le nombre d'enregistrements affichés
  Set rs = Me.RecordsetClone
  rs.MoveLast
  mlngCpteEnr = rs.RecordCount
  rs.Close
  Set rs = Nothing
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsAutorisés.sMajInfosNavig"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Option Compare Database
Option Explicit
'Mémorise le nombre d'enregistrements
'affichés par le formulaire
Dim mlngCpteEnr As Long
'Mémorise l'information d'utilisation du filtre
Dim mstrFiltré As String

Private Sub btcPrem_Click()
'Instruction à suivre en cas d'erreur :
'entrer dans le bloc de gestion d'erreurs
'nommé GestionErr
On Error GoTo GestionErr
 
'Atteindre le premier enregistrement :
 
  DoCmd.GoToRecord , , acFirst
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.btcPrem_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcPréc_Click()
 
On Error GoTo GestionErr
 
'Atteindre l'enregistrement précédent :
 
  DoCmd.GoToRecord , , acPrevious
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.btcPréc_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcSuiv_Click()
 
On Error GoTo GestionErr
 
'Atteindre l'enregistrement suivant :
 
  DoCmd.GoToRecord , , acNext
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.btcSuiv_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub btcDern_Click()
 
On Error GoTo GestionErr
 
'Atteindre le dernier enregistrement :
 
  DoCmd.GoToRecord , , acLast
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.btcDern_Click"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub txtAtteindre_BeforeUpdate(Cancel As Integer)
 
'Le code suivant sert à vérifier que la valeur spécifiée 
'dans le contôle txtAtteindre est de type numérique :
 
On Error GoTo GestionErr
'Sélection du contôle de saisie de la
'valeur à vérifier (txtAtteindre)
  With Me!txtAtteindre
 
  'On applique la fonction IsNumeric à valeur
  'du contôle sélectionné afin de vérifier
  'si le type est bien du numérique :
 
    If Not IsNumeric(.Value) Then
 
    'Si aucun nombre n'a été saisi,
    'on avertit l'utilisateur :
    MsgBox "Vous devez saisir un numéro d'enregistrement valide." & _
    vbCrLf & _
    "Vous pouvez appuyer sur Echap pour annuler votre saisie.", _
    vbExclamation
 
    'Puis on repositionne le curseur sur le contrôle sélectionné :
    ' Positionne le curseur au début du champ
      .SelStart = 0
    ' Sélectionne l'ensemble des données
    'affichées dans le champ
      .SelLength = Len(.Value)
 
    'Et on annule la mise à jour de l'événement
    'BeforeUpdate en utilisant son argument Cancel :
      Cancel = True
 
    End If
 
  End With
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.txtAtteindre_BeforeUpdate"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub txtAtteindre_AfterUpdate()
 
On Error GoTo GestionErr
 
With Me
 
  'Lorsque l'utilisateur souhaite atteindre un enregistrement, 
  'le numéro d'enregistrement demandé peut ne pas être valide. 
  'Dans ce cas il est nécessaire de mettre à jour ce 
  'numéro pour le rendre valide. 
  'Il y a ainsi 3 cas à considérer :
  'Cas 1 : s'il n'y a aucun enregistrement
  If mlngCpteEnr = 0 Then
  !txtAtteindre = 1
    MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
    vbCrLf & _
    "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
    vbExclamation
  'Cas 2 : s'il n'y a pas assez enregistrements
  ElseIf !txtAtteindre > mlngCpteEnr Then
   !txtAtteindre = mlngCpteEnr
   MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
   vbCrLf & _
   "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
   vbExclamation
  'Cas 3 : si le numéro demandé est inférieur à 1
  ElseIf !txtAtteindre < 1 Then
   !txtAtteindre = 1
   MsgBox "Impossible d'atteindre l'enregistrement spécifié." & _
   vbCrLf & _
   "Vous êtes peut-être à la fin du jeu d'enregistrement.", _
   vbExclamation
  End If
 
    'Une fois qu'on est sûr qu'un numéro 
    'd'enregistrement valide a été demandé, 
    'on se position sur le bon enregistrement, 
    'si ce n'est pas déjà le cas.
    If !txtAtteindre <> .CurrentRecord Then _
    DoCmd.GoToRecord , , acGoTo, !txtAtteindre
 
  End With
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.txtCourant_AfterUpdate"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub Form_Current()
 
On Error GoTo GestionErr
 
'On appel la procédure de mise à jour des 
'données liées aux contrôles de navigation :
 
  sActivation
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.Form_Current"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub Form_AfterDelConfirm(Status As Integer)
 
Dim strInfosNavig As String
 
On Error GoTo GestionErr
 
  'Si un ou plusieurs enregistrements 
  'ont été supprimés
  If Status = acDeleteOK Then
 
    'On recompte le nombre d'enregistrements 
    'suite à la suppression
    sMajInfosNavig
 
    'Mise à jour des infos de navigation 
    '(affichées par étqCpteEnr)
    strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
    étqCpteEnr.Caption = strInfosNavig
 
  End If
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.Form_AfterDelConfirm"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
Private Sub Form_Load()
'Traite le cas où il n'y a pas d'enregistrement
If Recordset.RecordCount = 0 Then
    btcDern.Enabled = False
    btcPrem.Enabled = False
    btcPréc.Enabled = False
    btcSuiv.Enabled = False
    txtAtteindre.Enabled = False
    étqCpteEnr.Caption = ""
End If
End Sub

Private Sub sActivation()
 
On Error GoTo GestionErr
 
Dim strInfosNavig As String
 
'Affiche le numéro de l'enregistrement en cours :
 
  Me!txtAtteindre = Me.CurrentRecord
 
'Disponibilité des boutons de navigations :
 
  Select Case Me.CurrentRecord
    Case 1
      Me!btcPréc.Enabled = False
      sMajInfosNavig
    Case Else
      Me!btcPréc.Enabled = True
  End Select
  'On ne peut aller vers l'enregistrement suivant 
  'que si nous ne sommes pas déjà sur le dernier.
  Me!btcSuiv.Enabled = (Me.CurrentRecord < mlngCpteEnr)
 
  'Mise à jour des infos de navigation (affichées par étqCpteEnr) :
 
  strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
  étqCpteEnr.Caption = strInfosNavig
 
  Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.sActivation"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub
 
 
Private Sub sMajInfosNavig()
 
  Dim rs As DAO.Recordset
 
On Error GoTo GestionErr
 
  'On indique si le filtre est activé
  If Me.FilterOn Then mstrFiltré = " (Filtré)"
 
  'On compte le nombre d'enregistrements affichés
  Set rs = Me.RecordsetClone
  rs.MoveLast
  mlngCpteEnr = rs.RecordCount
  rs.Close
  Set rs = Nothing
 
Exit Sub
 
' Bloc de gestion d'erreurs.
GestionErr:
  Select Case Err.Number
    Case Else
      MsgBox "Erreur " & Err.Number & " : " & _
      Err.Description, vbCritical, _
      "Form_frmNavigationAjoutsInterdits.sMajInfosNavig"
  End Select
' Fin du bloc de gestion d'erreurs.
 
End Sub

Private Sub TransposerElement(lstSource As ListBox, lstDestination As ListBox, _
  Optional LimiteSelection As Boolean = True)
 
Dim i As Integer
Dim strTemp As String
With lstSource
For i = 0 To .ListCount - 1
  'si l'élement est sélectionné dans la liste source
  If .Selected(i) Or Not LimiteSelection Then
    lstDestination.RowSource = lstDestination.RowSource & .Column(0, i) & ";"
  Else
  'sinon, le conserve dans la liste source
    strTemp = strTemp & .Column(0, i) & ";"
  End If
Next i
'Affecte la nouvelle source à lstSource
.RowSource = strTemp
End With
End Sub

'Copie les élements sélectionnés vers la liste de droite
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite
End Sub

'Copie les tous élements vers la liste de droite
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False
End Sub

'Copie les élements sélectionnés vers la liste de gauche
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche
End Sub

'Copie les tous élements vers la liste de gauche
Private Sub DroiteGaucheTous_Click()
TransposerElement lstDroite, lstGauche, False
End Sub

SELECT Code_Client, Societe FROM tblClients WHERE Not Selection

SELECT Code_Client, Societe FROM tblClients WHERE Selection

Private Sub TransposerElement(lstSource As ListBox, lstDestination As ListBox, _
  Optional LimiteSelection As Boolean = True, Optional bolSelection As Boolean = True)
 
Dim i As Integer
Dim Db As DAO.Database
Set Db = CurrentDb
With lstSource
'S'il ne faut déplacer que les élements sélectionnés,
If LimiteSelection Then
 For i = 0 To .ListCount - 1
  'si l'élement est sélectionné dans la liste source,
  'inverse le champ selection
  If .Selected(i) Then
    Db.Execute "UPDATE tblClients SET Selection=NOT Selection WHERE Code_Client=" & _
     Chr(34) & .Column(0, i) & Chr(34)
  End If
 Next i
'sinon, permutte la globalité
Else
Db.Execute "UPDATE tblClients SET Selection=" & CInt(bolSelection)
End If
'Rafraichit la zone de liste source
.Requery
End With
'Rafraichit la zone de liste destination
lstDestination.Requery
End Sub

'Copie les élements sélectionnés vers la liste de droite
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite
End Sub

'Copie les tous élements vers la liste de droite
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False, True
End Sub

'Copie les élements sélectionnés vers la liste de gauche
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche
End Sub

'Copie les tous élements vers la liste de gauche
Private Sub DroiteGaucheTous_Click()
TransposerElement lstDroite, lstGauche, False, False
End Sub

SELECT Code_Client, Societe 
FROM tblClients 
WHERE Code_Client NOT IN 
(SELECT Code_Client 
 FROM tblClientsSelectionnes);

SELECT tblClientsSelectionnes.Code_Client, tblClients.Societe
FROM tblClients INNER JOIN tblClientsSelectionnes 
ON tblClients.Code_client = tblClientsSelectionnes.Code_Client;

Private Sub TransposerElement(lstSource As ListBox, lstDestination As ListBox, _
  Optional LimiteSelection As Boolean = True, Optional bolSelection As Boolean = True)
 
Dim i As Integer
Dim Db As DAO.Database
Set Db = CurrentDb
With lstSource
'S'il ne faut déplacer que les élements sélectionnés,
If LimiteSelection Then
 For i = 0 To .ListCount - 1
  'si l'élement est sélectionné dans la liste source,
  'inverse le champ selection
  If .Selected(i) Then
    'Si bolselection, ajoute l'élement
    If bolSelection Then
     Db.Execute "INSERT INTO tblClientsSelectionnes (Code_Client) VALUES (" & _
      Chr(34) & .Column(0, i) & Chr(34) & ")"
    Else
    'Sinon, le supprime
     Db.Execute "DELETE FROM tblClientsSelectionnes WHERE Code_Client=" & _
      Chr(34) & .Column(0, i) & Chr(34)
    End If
  End If
 Next i
'sinon, permutte la globalité
Else
 If bolSelection Then
   Db.Execute "INSERT INTO tblClientsSelectionnes SELECT " & _
   "Code_Client FROM tblClients"
 Else
 'Sinon, le supprime
   Db.Execute "DELETE FROM tblClientsSelectionnes"
 End If
End If
'Rafraichit la zone de liste source
.Requery
End With
'Rafraichit la zone de liste destination
lstDestination.Requery
End Sub

'Copie les élements sélectionnés vers la liste de droite
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite, , True
End Sub
'Copie les tous élements vers la liste de droite
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False, True
End Sub
'Copie les élements sélectionnés vers la liste de gauche
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche, , False
End Sub
'Copie les tous élements vers la liste de gauche
Private Sub DroiteGaucheTous_Click()
TransposerElement lstDroite, lstGauche, False, False
End Sub

Sub sMajForm() 
Sub sMajForm()
Dim lngClé As Long
Dim lngEnrActif As Long
Dim rs As DAO.Recordset
 
On Error GoTo GestErr
 
'Désactive le rafraîchissement de l'écran
Echo False
 
'S'il n'y a pas d'enregistrement, on quitte la procédure
If Me.RecordsetClone.RecordCount = 0 Then Exit Sub
lngClé = Me!ChampCléPrimaire
lngEnrActif = Me.CurrentRecord
 
Me.Requery
Set rs = Me.RecordsetClone
With rs
 'S'il n'y a plus d'enregistrement, on quitte la procédure
  If rs.RecordCount = 0 Then Exit Sub
  .FindFirst "ChampCléPrimaire=" & lngClé
  Select Case .NoMatch
    Case True 'Si l'enregistrement qui était actif a disparu...
      DoCmd.GoToRecord , , acGoTo, lngEnrActif
    Case False
      Me.Bookmark = .Bookmark
  End Select
End With
rs.Close
Set rs = nothing
 
'Active le rafraîchissement de l'écran
Echo True
 
Exit Sub
 
GestErr:
Select Case Err
  Case 2105 'Si le numéro d'enregistrement n'est plus valide...
      'C'est qu'il y a moins d'enregistrements depuis le Requery,
      ' donc on active le dernier enregistrement
      DoCmd.GoToRecord , , aclast
  Case Else
    MsgBox Err.Description, Err.Number
End Select
rs.close
Set rs = nothing
 
'Active le rafraîchissement de l'écran
Echo True
 
End Sub

Option Compare Database 
Option Explicit 
 
Private Sub Form_Load() 
Dim strMsg As String 
Dim Dur As Integer 
Dim Argz As String 
Dim pos1 As Integer 
 
' récupère l'instruction openargs du type (TXT=salut|@|Dur=30) 
Argz = OpenArgs 
pos1 = InStr(Argz, "|@|") 
strMsg = left(Argz, pos1 - 1) 
strMsg = right(strMsg, Len(strMsg) - 4) 
Dur = CInt(right(Argz, Len(Argz) - pos1 - 6)) 
 
' attribue les propriétés Texte et durée d'affichage 
Me.lblMain.Caption = strMsg 
Me.OnTimer = "=xCloseFrm()" 
Me.TimerInterval = Dur * 1000 
 
End Sub 
 
' fonction de fermeture programmée 
Function xCloseFrm() 
 DoCmd.Close acForm, Me.Name 
End Function

Option Compare Database 
Option Explicit 
 
Function MyDialog(ByVal strTxt As String, ByVal Dur As Integer) 
 DoCmd.OpenForm "frmInfo", acNormal, , , , acDialog, "TXT=" & strTxt & "|@|Dur=" & Dur 
End Function

MyDialog "Attention cette fenêtre va se fermer dans 5 secondes",5

Private Sub bouton_Click()
 
  If IsNull(Me!MaZoneDeListe) Then
      MsgBox "Aucun élément sélectionné dans la liste.", vbCritical
  Else
      Docmd.Setwarnings False 'Facultatif
      DoCmd.RunSQL "DELETE MaTable.* FROM tbl WHERE MaTable.Id=""" & _
       Me!MaZoneDeListe & """;"
      Docmd.Setwarnings False 'Facultatif
      Me!MaZoneDeListe.SetFocus
      sMAJlst Me!MaZoneDeListe
  End If
 
End Sub
 
Sub sMAJlst(lst As ListBox)
 
Dim lngVal As Long
 
  With lst
    lngVal = Nz(.ListIndex, -1)
    .Requery
    If .ListCount > 0 Then
      If (lngVal >= 0) Then
        While lngVal > (.ListCount - 1)
          lngVal = lngVal - 1
        Wend
        .Value = .Column(0, lngVal)
      Else
        .Value = .Column(0, 0)
      End If
    End If
  End With
 
End Sub

If MonRTF.Text <> "" Then
    If MsgBox("Etes vous sûr de vouloir créer un nouveau document ?" _
      , vbQuestion + vbYesNo, "Nouveau...") = vbNo Then Exit Sub
End If
'Vide le controle RTF
MonRTF.TextRTF = ""
MonRTF.FileName = ""

Private Sub MnuOuvrir_Click()
'Gere les erreurs
On Error GoTo err
Dim fichier As String
If MonRTF.Text <> "" Then
    If MsgBox("Etes vous sûr de vouloir ouvrir un autre document ?" _
      , vbQuestion + vbYesNo, "Ouvrir...") = vbNo Then Exit Sub
End If
'Affiche la boite de dialogue ouvrir
fichier = OuvrirUnFichier(Me.hwnd, "Ouvrir un fichier rtf", 1, "Fichier RTF", "rtf")
'Charge le fichier
If fichier <> "" Then
    MonRTF.LoadFile (fichier)
End If
Exit Sub
err:
MsgBox "Impossible d'ouvrir le fichier", vbExclamation, "Ouvrir..."
End Sub

Private Sub enregistrer(fichier As String)
'Gere les erreurs
On Error GoTo err
If fichier = "" Then
    'Affiche une boite de dialogue enregistrer
    fichier = EnregistrerUnFichier(Me.hwnd, _
      "Enregistrer le document", "Document1.rtf", CurrentDb.Name)
End If
'Sauvegarde le fichier
If fichier <> "" Then
    MonRTF.SaveFile (fichier)
    MsgBox "Sauvegarde effectuée sous : " & vbCrLf & fichier, _
       vbInformation, "Enregistrer..."
    Exit Sub
End If
err:
MsgBox "Sauvegarde annulée", vbCritical, "Enregistrer..."
End Sub

'*********************************
'Changement de la police
Private Sub MPolice_AfterUpdate()
changerPolice
End Sub
 
Private Sub MPolice_Click()
changerPolice
End Sub
Private Sub changerPolice()
MonRTF.SelFontName = MPolice
MonRTF.SetFocus
End Sub
 
'*********************************
'Changement de la taille
Private Sub MTaille_AfterUpdate()
changerTaille
End Sub
Private Sub MTaille_Click()
changerTaille
End Sub
Private Sub changerTaille()
MonRTF.SelFontSize = MTaille
MonRTF.SetFocus
End Sub
'*********************************
'Met le texte en gras
Private Sub BGras_Click()
MonRTF.SelBold = BGras
MonRTF.SetFocus
End Sub
'*********************************
'Met le texte en italique
Private Sub BItalique_Click()
MonRTF.SelItalic = BItalique
MonRTF.SetFocus
End Sub
'*********************************
'Met le texte en souligné
Private Sub Bsouligne_Click()
MonRTF.SelUnderline = Bsouligne
MonRTF.SetFocus
End Sub
'*********************************
'Barre le texte
Private Sub BBarre_Click()
MonRTF.SelStrikeThru = BBarre
MonRTF.SetFocus
End Sub
'*********************************
'Change l'alignement
Private Sub MAlign_AfterUpdate()
ChangeAlign
End Sub
Private Sub MAlign_Click()
ChangeAlign
End Sub
Private Sub ChangeAlign()
MonRTF.SelAlignment = MAlign.ListIndex
MonRTF.SetFocus
End Sub
'**********************************
'Change la couleur
Private Sub BCouleur_Click()
Dim Couleur As Long
'Ouvre le boite de dialogue Couleur
Couleur = ShowColor(Me.hwnd)
If Couleur <> -1 Then MonRTF.SelColor = Couleur
MonRTF.SetFocus
End Sub
'**********************************
'Met à jour les boutons en fonction du
'style de la selection
Private Sub MonRTF_SelChange()
With MonRTF
    MPolice = .SelFontName
    MTaille = .SelFontSize
    MAlign = MAlign.ItemData(.SelAlignment)
    BGras = .SelBold
    BItalique = .SelItalic
    BBarre = .SelStrikeThru
    Bsouligne = .SelUnderline
End With
End Sub

dim Ssql as string 
dim rst as DAO.recordset 
 
Ssql ="SELECT Password FROM TableUser WHERE NomUser = " & chr(34) & me.USERNAME & chr(34) 
rst = currentdb.openrecrodset(Ssql) 
if (rst.Bof and rst.eof)=false then 
   if rst![Password]=me.PASSWORD then 
         msgbox "Password OK" 
   else 
         msgbox "Password invalide" 
   end if 
else 
   msgbox "Utilisateur invalide" 
end if 
rst.close

Function Fct_ReceptionFocus()
 
On Error GoTo Traitement
 
'Composition des noms des contrôles
    'TextBox    Txt_Nom
    'Label      Lbl_Txt_Nom
    'ListBox    Lst_Nom
    'Label      Lbl_Lst_Nom
'Fonctionnement
    'récupère le contrôle actif, modifie les apparences
 
    Dim Frm As Form
    Dim ctl As Control
    Dim TypeCtl As String
    Dim Lbl As String
    Dim CtlLst As String
 
    Set Frm = Screen.ActiveForm
    Set ctl = Screen.ActiveControl
 
    '********************
    'Type de contrôle
        'Zone de texte [Txt]
        'Liste modifiable [Lst]
        'Bouton de commande [Cmd]
    TypeCtl = left(ctl.name, 3)
 
    'Récupérer le nom du label associé au contrôle
     Lbl = "Lbl_" & ctl.name
 
    Select Case TypeCtl
        Case "Cmd"
        Case Else
            ctl.SpecialEffect = 2
            If TypeCtl = "Lst" Then
                ctl.Dropdown
            End If
    End Select
 
    'Police en italic
    Frm(Lbl).FontItalic = True
    'Couleur de la police
    Frm(Lbl).ForeColor = RGB(255, 255, 0)
    'Police souligner
    Frm(Lbl).FontUnderline = True
 
Traitement:
    Select Case err.Number
        Case 2475
            Exit Function
        Case Else
    End Select
 
End Function
 
Function Fct_PerteFocus()
 
On Error GoTo Traitement
 
'Composition des noms des contrôles
    'TextBox    Txt_Nom
    'Label      Lbl_Txt_Nom
    'ListBox    Lst_Nom
    'Label      Lbl_Lst_Nom
'Fonctionnement
    'récupère le contrôle actif, modifie les apparences
 
    Dim Frm As Form
    Dim ctl As Control
    Dim TypeCtl As String
    Dim Lbl As String
    Dim CtlLst As String
 
    Set Frm = Screen.ActiveForm
    Set ctl = Screen.ActiveControl
 
    '********************
    'Type de contrôle
        'Zone de texte [Txt]
        'Liste modifiable [Lst]
        'Bouton de commande [Cmd]
    TypeCtl = left(ctl.name, 3)
 
    'Récupérer le nom du label associé au contrôle
    Lbl = "Lbl_" & ctl.name
 
    Select Case TypeCtl
        Case "Cmd"
        Case Else
            ctl.SpecialEffect = 0
    End Select
 
    'Police en italic
    Frm(Lbl).FontItalic = False
    'Couleur de la police
    Frm(Lbl).ForeColor = RGB(204, 255, 255)
    'Police souligner
    Frm(Lbl).FontUnderline = False
 
Traitement:
    Select Case err.Number
        Case 2475
            Exit Function
    End Select
 
End Function

Private Sub cmdRecupNomOLE_Click()
 
    Dim strchaine As String
 
    strchaine = GetLinkedPath(Me.IndépendantOLE2)
    MsgBox strchaine
 
End Sub

Function GetLinkedPath(objOLE As Variant) As Variant
 
    Dim strChunk As String
    Dim pathStart As Long
    Dim pathEnd As Long
    Dim path As String
    If Not IsNull(objOLE) Then
    	'Converti la chaine string en UNICODE
        'Convert string to Unicode.
        strChunk = StrConv(objOLE.Name, vbUnicode)
        pathStart = InStr(1, strChunk, ":\", 1) - 1
 
    	'Si le chemin du disque n'est pas trouvé, essai d'un chemin UNC
        'If mapped drive path is not found, try UNC path.
        If pathStart <= 0 Then pathStart = InStr(1, strChunk, "\\", 1)
 
    	'Si un autre disque est trouvé, 
    	'détermination de la longueur du chemin
    	'en cherchant la 1ère valeur nulle
        'If either drive letter path or UNC path is found, determine
        'the length of the path by searching for the first null
        'character Chr(0) after the path was found.
        If pathStart > 0 Then
            pathEnd = InStr(pathStart, strChunk, Chr(0), 1)
            path = Mid(strChunk, pathStart, pathEnd - pathStart)
            GetLinkedPath = path
            Exit Function
        End If
    Else
        GetLinkedPath = Null
    End If
 
End Function

' Constantes
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS)
Private Const SB_CTL = 2
Private Const LOGPIXELSX = 88
' Formulaire
Private Form_Scroll As Form
' Collection contenant les contrôles à figer
Private Fixe_Ctrl As New Collection
' Structure pour API
Private Type ScrollInfo
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type
Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
'Déclarations d'API
Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, _
	ByVal fnBar As Integer, lpsi As ScrollInfo) As Boolean
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
	ByVal nIndex As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
	ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
'Recherche handle de la barre horizontale
Private Function GetScrollBarHwnd(ByVal FormhWnd As Long) As Long
    Dim CurrenthWnd As Long, lngret As Long
    Dim sClassname As String
    Dim MyRect As RECT
 
    CurrenthWnd = GetWindow(FormhWnd, GW_CHILD)
 
    Do Until CurrenthWnd = 0
        Call GetScrollBarHwnd(CurrenthWnd)
 
        sClassname = Space(255)
        lngret = GetClassName(CurrenthWnd, sClassname, 255)
        sClassname = left(sClassname, lngret)
 
        If sClassname = "Scrollbar" Then
            lngret = GetClientRect(CurrenthWnd, MyRect)
            If (MyRect.bottom < MyRect.right) Then
                GetScrollBarHwnd = CurrenthWnd
                Exit Function
            End If
        End If
 
        CurrenthWnd = GetWindow(CurrenthWnd, GW_HWNDNEXT)
    Loop
End Function
' Convertir les twips en pixels pour les APIs
Private Function PixelToTwips(X As Long) As Long
    Static mult As Long
    Dim hDC As Long
    If mult = 0 Then
        hDC = GetDC(0)
        mult = 1440 / GetDeviceCaps(hDC, LOGPIXELSX)
        ReleaseDC 0, hDC
    End If
    PixelToTwips = X * mult
End Function
 
Private Sub Class_Terminate()
    Set Form_Scroll = Nothing
End Sub
 
' Sur événement du Timer
Public Sub Form_scroll_Timer()
    Static pos As Long    ' Ancienne position de la barre horizontale
    Static hWnd As Long    ' Handle de la barre horizontale
    Dim lFormParent As String    ' Nom du parent d'un sous-formulaire
' Recherche le nom d'un éventuel parent du formulaire
    On Error Resume Next
    lFormParent = Form_Scroll.Parent.name
    On Error GoTo fin    ' Ne pas continuer si pas de formulaire actif
    If Screen.ActiveForm.name = Form_Scroll.name Or Screen.ActiveForm.name = lFormParent Then
        ' Si formulaire actif = le formulaire à traiter
        On Error GoTo 0
        If hWnd = 0 Then hWnd = GetScrollBarHwnd(Form_Scroll.hWnd)
        pos = ScrollForm(hWnd, pos)
    End If
fin:
End Sub
 
'Déplace les colonnes fixes
Private Function ScrollForm(ByVal hWnd As Long, oldpos As Long) As Double
    Dim ctrl As Control
    Dim SI As ScrollInfo
    Dim delta As Long
    Dim max_col As Double
    Dim lngret As Long
    Dim tabindex As Double
    Dim NameCtrl As Variant
 
    ' Lit les infos de l'ascenseur horizontal
    SI.cbSize = Len(SI)
    SI.fMask = SIF_ALL
    lngret = GetScrollInfo(hWnd, SB_CTL, SI)
    delta = PixelToTwips(SI.nPos) - oldpos
    ' Si on a pas bougé on sort
    If delta = 0 Then GoTo fin
    ' Recherche du contrôle figé le plus à droite de la section détail
    For Each ctrl In Form_Scroll.Section(acDetail).Controls
        On Error Resume Next
        NameCtrl = Fixe_Ctrl.item(ctrl.name)
        If Err.Number = 0 Then
            max_col = IIf(ctrl.left + ctrl.Width + delta > max_col, ctrl.left + _
						ctrl.Width + delta, max_col)
        End If
        On Error GoTo 0
    Next
    ' Déplace le focus sur le premier contrôle visible (dans la section détail)
    '   si le focus était sur un contrôle qui devient invisible
    On Error Resume Next
    If Form_Scroll.ActiveControl.left < max_col Then
        NameCtrl = Fixe_Ctrl.item(Form_Scroll.ActiveControl.name)
        If Err.Number <> 0 Then
            tabindex = Val(Form_Scroll.ActiveControl.tabindex)
            NameCtrl = ""
            For Each ctrl In Form_Scroll.Section(acDetail).Controls
                On Error Resume Next
                If ctrl.tabindex > tabindex And ctrl.left > max_col Then
                    If Err.Number = 0 Then    ' Si la propriété tabindex existe
                        If NameCtrl = "" Then
                            NameCtrl = ctrl.name
                        ElseIf ctrl.left < Form_Scroll.Controls(NameCtrl).left Then
                            NameCtrl = ctrl.name
                        End If
                    End If
                End If
            Next
            Form_Scroll.Controls(NameCtrl).SetFocus
        End If
    End If
    ' Déplace les contrôles pour les rendres "fixes"
    For Each NameCtrl In Fixe_Ctrl
        Form_Scroll.Controls(NameCtrl).left = Form_Scroll.Controls(NameCtrl).left + delta
    Next
    On Error GoTo 0
fin:
    ' Renvoie la position de l'ascenseur
    ScrollForm = PixelToTwips(SI.nPos)
End Function
 
' Initialisation
Public Sub Initialize(pForm As Access.Form)
    Dim ctrl As Control
    ' Formulaire
    Set Form_Scroll = pForm
    ' Ajoute les contrôles contenant <fixe> dans la remarque
    '   dans la collection de contrôles à figer
    For Each ctrl In Form_Scroll.Controls
        If ctrl.Tag Like "*FixeCtrl*" Then
            Fixe_Ctrl.Add ctrl.name, ctrl.name
        End If
    Next
End Sub
 
' Ajoute un contrôle fixe à la collection
Public Sub Fixe_Control(ctrl As String)
    On Error Resume Next
    Fixe_Ctrl.Add ctrl, ctrl
End Sub
 
' Retire un contrôle fixe à la collection
Public Sub CancelFixe_Control(ctrl As String)
    On Error Resume Next
    Fixe_Ctrl.Remove ctrl
End Sub

' La déclaration de la classe en-tête de module du formulaire :
Private FormScroll As New clScrollForm
 
'Préciser le formulaire sur lequel il faut agir :
Private Sub Form_Load()
FormScroll.Initialize Me
End Sub
 
'Commander le scrolling sur l'événement timer :
Private Sub Form_Timer()
FormScroll.Form_scroll_Timer
End Sub
 
'Et détruire la classe à la fermeture du formulaire :
Private Sub Form_Close()
Set FormScroll = Nothing
End Sub