Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaireFormulaires

Version : 2000 et supérieures

Cet exemple permet d'afficher un formulaire sur toute la surface de l'écran de la même façon qu'un diaporama sous Powerpoint.

Il supprime la barre de titre de la fenêtre Access, retire la barre des tâches et surtout, fait disparaitre l'ensemble des barres de menu. Afin de pouvoir restaurer ces dernières, nous avons besoin d'une table nommée tblBarre possédant un champ de type texte : NomBarre.

Afin d'utiliser ce code, vous devez ajouter les références suivantes à votre projet :

  • Microsoft Office X.0 Object Library (Gère les barres menu)
  • Microsoft DAO 3.X Object Library (Gère l'accès à la table tblBarre)

Dans un module, placez le code suivant :

 
Sélectionnez

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
 

Sur le formulaire concerné, vous devez déclarer une variable en entête afin de mémoriser l'état de l'affichage actuel.

 
Sélectionnez

Option Compare Database
Dim BolState As Boolean

Vous pouvez ensuite modifier l'affichage du formulaire à l'aide d'un bouton en utilisant l'instruction suivante :

 
Sélectionnez

Private Sub MonBouton_Click()
PleinEcran BolState
End Sub

N'hésitez pas à télechargez le fichier zip afin de visualiser en détails le résultat obtenu.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 2000 et supérieures

 
Sélectionnez

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 " & err.Number & " : " & err.Description, _
           vbInformation + vbOKOnly
        err.Clear
End Select
DoCmd.Close acForm, strForm, acSaveYes
DoCmd.OpenForm strForm, acNormal
End Function

Notez que le paramètre acHidden permet d'ouvrir le formulaire en mode caché afin de réaliser les modifications sur le formulaire. Ce paramètre n'est disponible que sur les versions 2000 et supérieures. Pour la version 97, vous devez enlever ce paramètre. Ce qui donne :

 
Sélectionnez
DoCmd.OpenForm strForm, acDesign

Utilisation :
Voici un appel de la fonction à mettre sur un bouton pour masquer l'entête et le pied du formulaire Test

 
Sélectionnez
DisplayHdrFtr("Test", false) 
Mis à jour le 1er mars 2005  par cafeine

Page de l'auteur

Versions : 97 et supérieures

Voici comment faire apparaître (dans une étiquette) un texte descriptif différent pour chacun de mes contrôles lorsque ma souris se déplace sur l'un d'eux.

 
Sélectionnez
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 

Sur les évènements MouseMove de chaque contrôle, on met la ligne de code suivante (en imaginant que l'étiquette s'appelle lblInfos et le contrôle ctl1)

 
Sélectionnez
AfficherInfo lblInfos, ctl1

Ce code est à mettre aussi sur l'évènement MouseMove de la section sur laquelle sont posés les contrôles.
Le texte à afficher doit être stocké dans la propriété Remarque (Tag), et puis voilà !

Créé le 28 janvier 2005  par Maxence Hubiche

Page de l'auteur

Versions : 2000 et supérieures et VB6

Ce code permet d'ajuster dynamiquement les colonnes d'un Contrôle Datagrid sur les lignes visibles.

Il n'existe effectivement pas de propriété AutoSize pour un DataGrid que vous l'utilisiez en VB6 ou en VBA.
Voici une proposition que vous pouvez mettre en place. Elle est bien évidemment à adapter selon vos besoins.

Dans le code du formulaire contenant le DataGrid (Office ou VB6) :

 
Sélectionnez
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 

Dans un module (mProperties par exemple) :

 
Sélectionnez

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 

Mode d'utilisation :

 
Sélectionnez
Private Sub cmdAutoSize_Click()
    AutoSizeGrid oRS1, DataGridCustomers, 1.09
End Sub 

Notes :

Le paramètre Tolérance est une valeur à définir selon vos préférences.

L'exemple est conçu ici pour 4 colonnes;
Si vous en avez davantage, il vous faudra ajouter une propriété incrémentielle (de manière à vous y retrouver) et adapter le code dans les deux procédures qui les exploitent.

Créé le 5 mars 2005  par Argyronet

Page de l'auteur

Versions : 97 et supérieures

Cet exemple permet d'animer la fermeture d'un formulaire en utilisant une fonctionnalité native de Windows. Il faut en effet utiliser l'API windows : AnimateWindows. Cette fonction fournit de nombreuses combinaisons possibles mais nous n'évoquerons que celles qui ont un rendu positif sur les formulaires Access.

Dans un module :

 
Sélectionnez
 '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

Puis pour replier un formulaire vers le coin en haut à gauche :

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

L'opérateur Or sert à cumuler les différentes animations. On replie donc vers la gauche puis vers le haut tout en masquant la fenêtre.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Voici un exemple de code qui permet d'afficher un menu contextuel sur une zone de texte lorsque l'utilisateur clique avec le bouton droit de la souris. Notre menu propose à l'utilisateur de :
1. Convertir le texte en majuscule
2. Convertir le texte en minuscule
3. Effacer le texte

Précisons tout de même que lorsque la zone de texte est vide, le menu doit être inactif.
En haut du module de formulaire, placer les déclarations suivantes :

 
Sélectionnez

'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

Puis sur l'événement Sur Souris Relâchée d'une zone de texte :

 
Sélectionnez

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

Quelques explications :

 
Sélectionnez
    AppendMenu hMenu, TypeMenu1, 1, "Majuscule"

Ici, le paramètre "1" correspond à la valeur qui sera retournée lorsque l'utilisateur cliquera sur la ligne intitulée "Majscule" du menu contextuel. Ce résultat est retourné par la methode TrackPopupMenuEx

De plus, l'ergonomie sera optimale si vous désactivez l'affichage des menu contextuels par défaut. (Options de démarrage de la base de données)

Créé le 5 février 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Ce code donne un exemple pour créer dynamiquement une flèche à partir de 3 traits (trCorps/trDroit/trGauche). Pour ceux que cela intéresse, l'auteur précise qu'il y aurait peut-être 2 ou 3 petites corrections à apporter, lorsqu'on est aux alentours des 90°...

 
Sélectionnez
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 :  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
Créé le 28 janvier 2005  par Maxence Hubiche

Page de l'auteur

Version : 97 et supérieures

Cet exemple de code utilise le composant ListView pour lister les enregistrements de plusieurs requêtes. Il nécessite que vous disposiez des controles listview et ImageList. Si ce n'est pas le cas, vous devrez installer les services packs de votre version Office (disponibles sur le site de microsoft). De plus, vous devez ajouter une référence Microsoft ActiveX Data Object à votre projet.

L'interface se compose :

- D'un groupe d'option nommé cdrTypeElement possédant 3 options (1,2,3) qui permettent de choisir la requête à afficher.

- D'un autre groupe d'option nommé cdrVisu possédant 4 options (0,1,2,3,4) qui permettent de choisir l'affichage de la ListView (icônes, petites icônes, liste, détails).

- D'une ListView nommée lvwElements.

- De trois ImageList proposant respectivement : Les grandes icones, les petites icones ainsi que deux flèches qui serviront à montrer l'ordre de tri d'une colonne.

- Nous disposons aussi de 3 requêtes :

  • rqtClient : Liste les clients
  • rqtCommande : Liste des commandes
  • rqtProduit : Liste des produits
Image non disponible

Pour faire la correspondance entre le groupe d'option et les requêtes, on utilise l'énumération suivante :

 
Sélectionnez

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

Cela va permettre quand l'utilisateur choisi une source de données, d'accéder en plus à l'icône correspondante dans l'ImageList. Il est donc nécessaire que les images des deux premières ImageList apparaissent dans le même ordre que les requêtes. Ici la première image est une poignée de main symbolisant un client, une pile de pièce symbolisant une commande, une roue dentée symbolisant un produit.

Ainsi, en choississant la première option dans le groupe d'option cdrVisu, la première icône est sélectionnée (c'est à dire la poignée de main).

Code de remplissage de la ListView :

 
Sélectionnez

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  " & 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

Explications :

 
Sélectionnez

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

Cette partie permet de remplir un tableau avec le nom de requêtes. Ainsi, l'option 1 du groupe cdrTypeElement correspond à la requête rqtClient.

 
Sélectionnez

  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

Ici, on crée les entêtes de colonnes en bouclant sur les champs du recordset. Vous remarquerez que ColumHeaders est une collection d'objet ColumnHeader correspondant à un entête de colonne de la listview.

 
Sélectionnez

  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

Cette partie permet de remplir la listview avec les enregistrement du recordset. Pour se faire, on ajoute un objet ListItem à la collection ListItems du contrôle. Cet objet correspond à la valeur qui sera affiché dans la première colonne. Les autres colonnes correspondent à des objets SubItem que l'on ajoute à l'objet ListItem récemment créé.

 
Sélectionnez

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

Enfin, on fait appel à une procédure (OrderByCol) qui va trier la listview sur la colonne 1 puis on fixe le mode d'affichage du contrôle.

Voici le code de cette procédure :

 
Sélectionnez

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

Vous remarquerez que si la procédure est lancée deux fois sur la même colonne alors, l'ordre de tri est inversé.

Ce tri peut aussi être lancé lors d'un clic sur l'entête d'une colonne avec :

 
Sélectionnez

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
 

Enfin, le remplissage de la listview est réalisé lorsque l'utilisateur ouvre le formulaire ou bien quand il change d'option dans le premier groupe. Il suffit alors d'appeler la procédure FillListView avec l'argument cdrTypeElement.

 
Sélectionnez
FillListView cdrTypeElement

N'hésitez pas à télecharger le fichier zip afin de visualiser le comportement de ce contrôle. Attention, il se peut que la ListView reste vide à la première exécution. Dans ce cas, passez en mode création et affichez les propriétés spécififiques à la ListView (en haut du menu contextuel - clic droit).

Créé le 20 mai 2005  par Maxence Hubiche

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

Dans une liste (ListeSports) on fait le choix d'un sport, il faut filtrer dans l'autre liste (ListEpreuve) les épreuves propres au sport en question :

 
Sélectionnez
Private Sub ListeSports_AfterUpdate()
 ListEpreuve.RowSource = "Select [ID_Epreuves],[Epreuve],[IDSport] From T_Epreuves " & _
                          "where IDSport= " & ListeSports & ";"
 ListEpreuve.Requery
End Sub 
Créé le 27 août 2004  par Papilou

Versions : Access 2000 et supérieures

Soit une zone de texte nommée txtValeur et 2 boutons nommés cmdDecrease et cmdIncrease.

Un clic sur le bouton cmdIncrease incrémentera la valeur de txtValeur. Un clic sur le bouton cmdDecrease diminuera la valeur d'une unité.

Le code du formulaire est le suivant :

 
Sélectionnez

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

N.B : Cet exemple plafonne les valeurs entre 0 et 15, à vous de les adapter selon vos besoins...

Créé le 12 novembre 2005  par Argyronet

Page de l'auteur

Versions : 2000 et supérieures

Cet exemple montre comment lister les polices disponibles et les afficher dans une zone de liste modifiable comme le fond la plupart des logiciels de traitement de textes.

Nous allons créer une table police avec un champ nommé NomPolice de type texte.
Puis sur un formulaire, créer une zone de liste nommée MPolice dont le type de contenu est une requête :

 
Sélectionnez

SELECT NomPolice FROM Police ORDER BY NomPolice

Cette requête nous permet de lister les éléments de la table police dans l'ordre alphabétique.

Ensuite dans un module :

 
Sélectionnez

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

La fonction EnumFontProc ajoute le nom d'une police à la table Police.

Sur l'événement load du formulaire :

 
Sélectionnez

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

Le principe est simple. La fonction GetHDC récupère le contexte graphique. Ici il s'agit du formulaire. Ensuite, l'API EnumFonts liste les polices disponibles pour ce contexte graphique. Cela correspond aux polices utilisables sur l'écran puisque le contexte graphique est un formulaire qui s'affiche à l'écran. Puis pour chaque police, elle appelle la fonction EnumFontProc à l'aide de l'opérateur AddressOf. Cela peut paraitre étrange du fait qu'il n'y ait pas de boucle pour parcourir l'ensemble des polices. En fait, c'est l'API EnumFonts qui gère la boucle toute seule. Il s'agit d'une fonction asynchrone qui se déroule jusqu'à temps que la fonction appelée par AddressOf retourne la valeur 0.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Je plante le décor :
J'ai un formulaire et plusieurs sous-formulaires. Dans le principal se trouve une liste de sélection d'enregistrements. Dans les sous formulaires se trouvent également des listes de sélection qui vont changer selon l'enregistrement sélectionné dans le principal. Toutes mes listes dans le form principal et les sous-form ont un nom qui commence par LST. Tous mes sous formulaires commencent par SF_ . Cette charte sera respectée dans tous les formulaires que je vais créer pour cette base.
Je désire mettre au point un module de mise à jour qui va actualiser toutes les listes et ce quel que soit le formulaire qui soit chargé car je ne vais pas m'amuser à en faire un pour chaque formulaire créé..

 
Sélectionnez

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
 

Si vous voulez appliquer le traitement à tous les formulaires ouverts (par exemple sur l'événement clic d'un bouton) :

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

Et voilà, il est maintenant possible d'appeler le module de mise à jour par n'importe quel formulaire, avec n'importe quel sous-formulaire, sans les spécifier explicitement.
Tout ce qu'il faut faire, c'est bien respecter le protocole d'appellation des listes en "LST" et des sous form en "SF_".
Ce code est bien évidement dérivable pour d'autres choses sur les contrôles.
Je le mets donc à disposition à toute fin utile pour les membres du forum (on ne sait jamais) parce qu'il me semble que ce module est très intéressant pour tous ceux qui en ont marre de ce coltiner 2 lignes de code pour l'actualisation d'un contrôle de sous-formulaire et ce pour chaque contrôle de chaque formulaire.

Créé le 28 janvier 2005  par GCUSSE

Versions : Access 2000 et supérieures

Dans un module recopier la fonction suivante :

 
Sélectionnez

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 

Mode d'utilisation :

Dans un contexte particulier comme l'ajout d'un nouvel enregistrement dans un autre formulaire dont la modification de la source de données influe sur le contenu des zones de listes du formulaire courant, il est possible d'utiliser le code suivant afin de réactualiser les listes :

 
Sélectionnez

Private Sub AjouterProduit_Click() 
  subRefreshLists Me 
End Sub 
Créé le 8 octobre 2005  par vmolines

Version : Access 97 et supérieures

Pour que cet exemple fonctionne, vous devez ajouter la référence Microsoft DAO Object à votre projet.

Le but de cet exemple est de créer un formulaire permettant de consulter les enregistrements 10 par 10. Les données proviennent de la table Clients de la base de données Comptoir.mdb (Répertoire samples d'Access). De cette table, nous conserverons uniquement les champs suivants :

Code Client, Société, Ville, Pays

Le formulaire se compose ainsi :

Image non disponible

Nous utiliserons deux variables dans la portée du formulaire :

 
Sélectionnez

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

Le principe est simple, à l'ouverture du formulaire, nous chargons le Recordset et affichons les 10 premiers enregistrements.

 
Sélectionnez

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

La procédure RemplirZonetexte boucle sur chaque ligne du tableau et affiche la valeur du champ dans la zone de texte correspondante pour la ligne sélectionnée. Les autres lignes sont ensuites masquées.

 
Sélectionnez

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

Les déplacements vers l'arrière sont plus complexes étant donné que si nous avons lu les 20 premiers, la position courante du Recordset est définie à 21 et les enregistrements 11 à 20 sont affichés. Or, la plage souhaitée est celle des lignes 1 à 10. Nous devons donc reculer du nombre d'enregistrements lus la précédente fois et nous positionner 10 enregistrements en arrière pour commencer la lecture. Toutefois, il se peut que ce nombre de sauts excède le nombre d'enregistrements disponibles vers l'arrière. Le plus simple est alors d'intercepter l'erreur levée (3021) afin de ne pas stopper l'éxecution et de se positionner sur le premier enregistrement du curseur.

 
Sélectionnez

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

Résultat :

Image non disponible

N'hésitez pas à consulter le fichier zip joint et à consulter un cours complet sur DAO disponible ici.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

Je vous propose une méthode qui permet de créer dynamiquement des requêtes pour réaliser des formulaires de recherche multi critères.

Voici le code de la procédure en question à mettre dans un module :

 
Sélectionnez

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
  • L'argument chaine correspond à la valeur recherchée.
  • L'argument champ correspond au champ sur lequelle doit se faire la restriction.
  • L'argument matable correspond au nom de la table ou d'une requête
  • L'argument Argument est un entier.
  • L'argument Clause est une chaine qui acceptera le résultat.
  • L'argument astype correspond à un entier représentant le type du champ. 0 pour du texte, 1 pour du numérique, 2 pour une date.

Voici un exemple qui va rechercher des informations dans ma table tbl_matériel en fonction des zones de texte Tserie, TMarque et TDate:

 
Sélectionnez

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

Notons que le paramètre MaTable peut aussi être une requête SQL. Dans ce cas, on aurait pu avoir dans notre exemple :

 
Sélectionnez

NomTable = "SELECT * FROM Tbl_Materiel"
Mis à jour le 1er mars 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

Pour utiliser ce code il faut créer 5 boutons (btcPrem, btcPréc, btcSuiv, btcDern, btcNouv), une zone de texte (txtAtteindre) et une étiquette (étqCpteEnr)

En tête du module du formulaire :

 
Sélectionnez

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

Code des boutons :

 
Sélectionnez

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
 
 

Code de la zone de texte txtAtteindre :

 
Sélectionnez

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

Code sur les événements de formulaire :

 
Sélectionnez

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
 

Procédures sub :

 
Sélectionnez

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
Mis à jour le 26 février 2005  par Fred.G

Téléchargez le zip

Versions : 97 et supérieures

Pour utiliser ce code il faut créer 4 boutons (btcPrem, btcPréc, btcSuiv, btcDern), une zone de texte (txtAtteindre) et une étiquette (étqCpteEnr)

En tête du module du formulaire :

 
Sélectionnez

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

Code des boutons :

 
Sélectionnez

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
 

Code de la zone de texte txtAtteindre :

 
Sélectionnez

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
 

Code sur les événements de formulaire :

 
Sélectionnez

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

Procédures sub :

 
Sélectionnez

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
Mis à jour le 26 février 2005  par Fred.G

Téléchargez le zip

Version : 2000 et supérieures

Cet exemple permet de transposer les élements d'une liste de type "Liste de valeur" vers une autre.

Exemple :

Image non disponible

Les zones de listes ont comme propriétés :

  • Origine source : Liste de valeur
  • Sélection multiple : Etendue

Pour copier les données d'une liste vers une autre, il est possible d'utiliser la procédure suivante :

 
Sélectionnez

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

Le paramètre optionnel permet de restreindre la copie à la sélection de la liste. Ainsi lorsqu'il est égal à False, l'ensemble de la liste source est copié dans la liste de destination. Dans le cas contraire, seuls les enregistrements sélectionnés seront concernés.

Il suffit alors d'appeler cette procédure sur chacun des quatres boutons :

 
Sélectionnez

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

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

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

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

N'hésitez pas à télecharger le fichier zip afin de visualiser le comportement de l'application.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Version : 2000 et supérieures

Pour que ce code fonctionne, vous devez ajouter la référence Microsoft DAO 3.6 Object Library à votre projet.

Cet exemple vous présente comment transposez des élements d'une liste vers une autre lorsque ces listes ont pour origine une table ou une requête.

Prenons comme exemple une table tblClients possédant les champs suivants :

  • Code_Client : Texte
  • Societe : Texte
  • Contact : Texte

L'objectif de l'application est de permettre à l'utilisateur de prélever des clients à sélectionner dans la liste de gauche qui seront regroupés dans la liste de droite.

Image non disponible

Cas d'une application monoposte

Dans le cas d'une application monoposte, il suffit de rajouter un champ de type Oui/Non dans la table Code_Client qui indiquera l'état de la sélection. Lorsque ce champ est égal à Oui (True), l'élement est sélectionné, il doit donc apparaître dans la liste de droite.

Nommez ce champ : Selection

Il est maintenant possible de passer au développement du formulaire.

La zone de liste de gauche ne devant afficher que les clients non sélectionnés, son contenu sera :

 
Sélectionnez

SELECT Code_Client, Societe FROM tblClients WHERE Not Selection

Cette zone de liste à sélection multiple étendue possède deux colonnes dont la première sera la colonne liée. Afin de n'afficher que le nom du client, vous pouvez définir la propriété Largeur Colonnes à : 0cm. Access fixera automatiquement la largeur de la deuxième colonne de telle sorte quelle soit égale à la largeur de la zone de liste.

La deuxième zone de liste est une copie de la première si ce n'est que sa propriété Contenu vaut :

 
Sélectionnez

SELECT Code_Client, Societe FROM tblClients WHERE Selection

Pour passer un élément d'une zone à l'autre, il suffit d'inverser la valeur du champ Selection et de raffraichir les deux zones de listes.

Afin de rendre le code le plus réutilisable possible, dans le module du formulaire, copier la procédure suivante :

 
Sélectionnez

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

Il ne reste plus qu'alors à appeler cette procédure sur chaque bouton :

 
Sélectionnez

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

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

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

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

Cas d'une application multi-utilisateurs

Dans le cas d'une application mutli-utilisateurs, il est impossible de rajouter un champs sur la table source. En effet si le champ Selection est égal à True, il l'est pour tous les utilisateurs. Ils auront donc tous la même sélection dans leur zones de listes.

L'idée est alors de rajouter une table tblClientsSelectionnes dans l'application frontale. Je vous rappelle que l'application frontale est celle qui se trouve sur chaque poste client et qui contient entre autres : les formulaires, les états, ainsi que les tables permettant de stocker les préférences de l'utilisateur. La base dorsale quant à elle se trouve sur le serveur et contient les données partagées. Le lien entre les deux se fait par l'intermédiaire des tables liées.

Cette table tblClientsSelectionnes, ne possèdera qu'un seul champ : code_client (de même type que celui de la table tblClients)

La zone de liste de gauche reçoit donc la liste des clients non présent dans tblClientsSelectionnes. Son contenu est donc :

 
Sélectionnez

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

La zone de liste de droite n'affichant que les clients sélectionnés, son contenu sera :

 
Sélectionnez

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

Pour passer un élément d'une zone de liste à l'autre, il suffit soit de l'ajouter ou de le supprimer de la table tblClientsSelectionnes.

La procédure devient :

 
Sélectionnez

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

Puis l'appel sur chaque bouton :

 
Sélectionnez

'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

N'hésitez pas à télecharger le fichier zip où vous trouverez un exemple des deux modes d'utilisation.

Créé le 20 mai 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

La méthode Requery d'un formulaire repositionne systématiquement celui-ci sur le premier enregistrement. Pour revenir sur l'enregistrement qui était actif avant l'appel du Requery, on peut utiliser un code comme celui-ci (exemple avec un formulaire dont la source contient une clé primaire numérique) :

Important : Cette procédure est à utiliser en lieu et place de la méthode Me.Requery

 
Sélectionnez
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

Pour fonctionner, ce code nécessite une référence Microsoft DAO.

Créé le 28 janvier 2005  par Fred.G

Versions : 2000 et supérieures

L'intérêt est de pouvoir définir du code dans le module du formulaire. On peut donc enrichir cette méthode à volonté, mais le principe est là.

Je fais un formulaire avec un seul contrôle (pour afficher le message) de type Label : lblMain.


Code du formulaire nommé : frmInfo

 
Sélectionnez
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  

Ensuite je crée une fonction d'appel dans un module avec les arguments que je vais passer dans la chaîne OpenArgs

 
Sélectionnez

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  

Ensuite par du code il me suffit de faire

 
Sélectionnez
MyDialog "Attention cette fenêtre va se fermer dans 5 secondes",5  
Créé le 28 janvier 2005  par cafeine

Page de l'auteur

Versions : 97 et supérieures

Ce code permet de supprimer des enregistrements correspondant aux éléments affichés par une zone de liste, en cliquant sur un bouton. La liste se met automatiquement à jour, en conservant si possible, le même item sélectionné. Ici la liste s'appelle "MaZoneDeListe". Sa propriété colonne liée est égale à 1. Dans la plupart des cas, la colonne liée correspondra à une clé primaire, celle de l'enregistrement à supprimer. Dans cet exemple, les enregistrements sont issus de la table "MaTable", et le champ correspondant à la colonne liée de MaZoneDeListe, s'appelle "Id".

 
Sélectionnez
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
Créé le 27 août 2004  par Fred.G

Versions : 2000 et supérieures

Cet exemple illustre l'utilisation du contrôle RichTextBox, pour afficher du texte au format RTF. Ce contrôle, contrairement à la simple zone de texte permet de mettre en forme le texte du composant. Par exemple, un mot d'une couleur, un autre en gras, etc .... Le contrôle RichTextBox est disponible dans la boite à outils des composant ActiveX.
Cet exemple utilise aussi un certains nombre d'API windows regroupées au sein d'un même module. Ces API sont documentées dans d'autres pages sources ou bien dans la FAQ Access, n'hésitez donc pas à aller les consulter.

Voici en détail l'ensemble des fonctions et procédures utilisées pour mettre en forme un texte à l'aide de ce contrôle :

Créer un nouveau document RTF

 
Sélectionnez

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 = ""

Ouvrir un document

 
Sélectionnez
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

Enregistrer le contenu

 
Sélectionnez
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

Accéder aux propriétés de mise en forme :

 
Sélectionnez

'*********************************
'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
Créé le 5 mars 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

Versions : 97 et supérieures

Ce code a été créée pour répondre au besoin suivant :

J'ai crée un Formulaire avec un champ NOM et un champ PASSWORD. De plus, j'ai une table USER avec les champs nom et password . Je voudrais que mon champ PASSWORD du formulaire ne soit valide que si il correspond au PASSWORD de la table pour un NOM donné.

Sur l'événement After Update du contrôle Password ou sur l'événement Click d'un bouton :

 
Sélectionnez
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  

Pour que ce code fonctionne, il vous faut ajouter la référence Microsoft DAO à votre projet

Cette solution a été proposée uniquement pour répondre directement à une question qui hélas est récurrente, cependant, Developpez.com recommande d'éviter à tout prix cette solution et de s'orienter plutôt vers la solution de sécurisation au niveau utilisateur telle que présentée dans la FAQ. En effet, cette solution n'est pas du tout sécurisée, et son efficacité en matière de protection est proche du zéro.

Mis à jour le 20 mai 2005  par Lucifer

Versions : toutes. Pour les versions supérieures à 97, préférez la mise en forme conditionnelle.

Voici deux fonctions permettant de modifier l'apparence d'un champ.
La fonction Fct_ReceptionFocus() est à placer sur l'évènement "Sur réception focus", Fct_PerteFocus() sur "Sur perte focus" des contrôles.
Afin de repérer les contrôles à modifier, ils sont nommés de cette façon :

  • TextBox Txt_Nom
  • Label Lbl_Txt_Nom
  • ListBox Lst_Nom
  • Label Lbl_Lst_Nom
 
Sélectionnez

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

Mise en forme conditionnelle

Créé le 16 janvier 2007  par Gdal

Le code ci-dessous vous permet de récupérer le chemin d'un objet OLE.
Pour l'exemple, dans un formulaire, créez un bouton qui appellera la fonction GetLinkedPath

Utilisable qu'à partir de la version 2000

Le code à placer sur l'évènement Sur clic du bouton :

 
Sélectionnez

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

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
Créé le 16 janvier 2007  par Argyronet

Suite à une question sur le forum, voici le code qui va vous permettre de synchroniser 2 sous formulaires et d'afficher dans le second sous formulaire des informations en relation avec le premier sous formulaire.

Dans un premier temps, placez le code ci-dessous dans un module de classe et sauvegardez-le sous le nom suivant : clScrollForm.

 
Sélectionnez

' 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

Ensuite dans le module du formulaire, placez ce code :

 
Sélectionnez

' 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

Remarques :
Pour préciser les contrôles à figer :
- soit mettre FixeCtrl dans la remarque
- soit les figer dans le code avec la fonction Fixe_Control("LeNomduContrôle")

On peut arrêter de figer un contrôle avec la fonction CancelFixe_Control("LeNomduContrôle")

Créé le 15 mai 2007  par Arkham46
  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.