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
Const AW_HOR_POSITIVE = &H1
 'Replie la fenêtre de la droite vers la gauche
Const AW_HOR_NEGATIVE = &H2
 'Replie la fenêtre du haut vers le bas
Const AW_VER_POSITIVE = &H4 
 'Replie la fenêtre du bas vers le haut
Const AW_VER_NEGATIVE = &H8 
'Masque la fenêtre
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

Dim WithEvents rsCli As ADODB.Recordset
Dim WithEvents rsEmp As ADODB.Recordset
Dim WithEvents rsCde As ADODB.Recordset

Private Sub cmdUpdate_Click()
        'déclaration des variables
        Dim x As Node
        'Réaffectation des recordsets pour mise à jour
        If rsCli.State = adStateClosed Then rsCli.Open "Clients", _
           CurrentProject.Connection, adOpenStatic
        If rsEmp.State = adStateClosed Then rsEmp.Open "Employés", _
           CurrentProject.Connection, adOpenStatic
        rsCli.Requery: rsCli.MoveFirst
        rsEmp.Requery: rsEmp.MoveFirst
        'Définition du treeview
       
        ocxTree.Nodes.Clear
        '--Clients
        Set x = ocxTree.Nodes.Add(, , "c", "Clients", 1)
        x.ExpandedImage = 2
        Do Until rsCli.EOF
            Set x = ocxTree.Nodes.Add("c", tvwChild, "C-" & rsCli(0), rsCli(1) & _
              " (" & rsCli(2) & ")", 1)
            rsCli.MoveNext
        Loop
        '--Employés
        Set x = ocxTree.Nodes.Add(, , "e", "Employés", 1)
        x.ExpandedImage = 2
        Do Until rsEmp.EOF
            Set x = ocxTree.Nodes.Add("e", tvwChild, "E-" & rsEmp(0), rsEmp(1) & _
              " " & rsEmp(2), 1)
            rsEmp.MoveNext
        Loop
End Sub

Private Sub ListeSports_AfterUpdate()
 ListEpreuve.RowSource = "Select [ID_Epreuves],[Epreuve],[IDSport] From T_Epreuves " & _
                          "where IDSport= " & ListeSports & ";"
 ListEpreuve.Requery
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

Private 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 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

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