| |
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 :
Option Compare Database
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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
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
Set Db = CurrentDb
If Not bolVisible Then _
Db.Execute "DELETE FROM TblBarre"
If Not bolVisible Then
For Each oBar In Application.CommandBars
If oBar.Visible Then
Db.Execute "INSERT INTO TblBarre VALUES (" & Chr(34) & oBar.Name & Chr(34) & ")"
oBar.Visible = bolVisible
End If
Next
Else
Set oRst = Db.OpenRecordset("TblBarre")
While Not oRst.EOF
Application.CommandBars(oRst.Fields(0).Value).Visible = bolVisible
oRst.MoveNext
Wend
oRst.Close
End If
DoCmd.ShowToolbar "Menu bar", IIf(bolVisible, acToolbarYes, acToolbarNo)
Application.SetOption "Show Status Bar", bolVisible
End Sub
Private Sub AfficherBarreTitre(bolVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
GetWindowRect Application.hWndAccessApp, vrWin
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
hwnd = FindWindow("Shell_traywnd", "")
GetWindowRect hwnd, rctTemp
inthauteur = rctTemp.Bottom - rctTemp.Top
intResolutionX = GetDeviceCaps(GetDC(0), 8)
intResolutionY = GetDeviceCaps(GetDC(0), 10)
If bolVisible Then
SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW
SetWindowPos Application.hWndAccessApp, 0, 0, 0, intResolutionX, _
intResolutionY - inthauteur, &H20
Else
SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW
SetWindowPos Application.hWndAccessApp, 0, 0, 0, intResolutionX, _
intResolutionY, &H20
End If
End Sub
Public Sub PleinEcran(bolEtat As Boolean)
DoCmd.Echo False
AfficherMenu bolEtat
AfficherBarreTitre bolEtat
AfficherBarreTache bolEtat
DoCmd.Maximize
err:
DoCmd.Echo True
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.
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 :
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.
|
Auteur : cafeine
| | Version : 05/03/2005 | | |
| | Versions : 2000 et supérieures Function DisplayHdrFtr(ByVal strForm As String, ByVal OnOff As Boolean)
On Error GoTo CatchHdrFtr
DoCmd.OpenForm strForm, acDesign, , , , acHidden
Forms(strForm).Section("EntêteFormulaire").Height = _
Forms(strForm).Section("EntêteFormulaire").Height
If Not (OnOff) Then
DoCmd.RunCommand acCmdFormHdrFtr
End If
DoCmd.Close acForm, strForm, acSaveYes
Exit Function
CatchHdrFtr:
Select Case err.Number
Case 2461
If OnOff Then
DoCmd.RunCommand acCmdFormHdrFtr
DoCmd.Close acForm, strForm, acSaveYes
End If
Case 2102
MsgBox "Le formulaire " & strForm & " n'existe pas.", _
vbCritical + vbOKOnly
Case Else
MsgBox "Erreur n°" & err.Number & " : " & err.Description, _
vbInformation + vbOKOnly
err.Clear
End Select
DoCmd.Close acForm, strForm, acSaveYes
DoCmd.OpenForm strForm, acNormal
End Function |
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 : 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
DisplayHdrFtr("Test", false) |
|
| | 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.
Public Function AfficherInfo(CtlLabel as Control, CtlSource as control) As Boolean
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) 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à !
|
| | 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) : 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()
Column0 = 0
Column1 = 0
Column2 = 0
Column3 = 0
End Sub |
Dans un module (mProperties par exemple) : 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 : 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.
|
| | 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 :
Public Const AW_HOR_POSITIVE = &H1
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_VER_NEGATIVE = &H8
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 : 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.
|
| | 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 :
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&
Private Type POINTAPI
X As Long
Y As Long
End Type
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 : Private Sub Texte1_MouseUp(Button As Integer, Shift As Integer _
, X As Single, Y As Single)
If Button = 2 Then
Dim Pt As POINTAPI
Dim result As Long
Dim hMenu As Long
Dim TypeMenu1 As Long
Dim TypeMenu2 As Long
Dim TypeMenu4 As Long
If Texte1.Text = "" Then
TypeMenu1 = MF_GRAYED Or MF_DISABLED
TypeMenu2 = MF_GRAYED Or MF_DISABLED
TypeMenu4 = MF_GRAYED Or MF_DISABLED
Else
TypeMenu4 = MF_STRING
TypeMenu1 = IIf(Texte1.Text = UCase(Texte1.Text), _
MF_CHECKED, MF_STRING)
TypeMenu2 = IIf(Texte1.Text = LCase(Texte1.Text), _
MF_CHECKED, MF_STRING)
End If
hMenu = CreatePopupMenu()
AppendMenu hMenu, TypeMenu1, 1, "Majuscule"
AppendMenu hMenu, TypeMenu2, 2, "Minuscule"
AppendMenu hMenu, MF_SEPARATOR, 3, ByVal 0&
AppendMenu hMenu, TypeMenu4, 4, "Effacer"
GetCursorPos Pt
result = TrackPopupMenuEx(hMenu, _
TPM_LEFTALIGN Or TPM_RETURNCMD _
Or TPM_RIGHTBUTTON, Pt.X, Pt.Y, Me.HWnd, ByVal 0&)
DestroyMenu hMenu
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 : 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)
|
| | 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°...
Function TraceFlch(ByVal Couleur As Long, ByVal Taille As Long, ByVal Angle As Double)
Dim v As Variant
Const CoeffTaille As Double = 0.1
Const DecalAngle As Double = 15
trCorps.BorderColor = Couleur
trGauche.BorderColor = Couleur
trDroit.BorderColor = Couleur
v = GetCoeff(Angle)
trCorps.Left = 500
trCorps.Top = 500
trCorps.Width = v(0) * Taille
trCorps.Height = v(1) * Taille
trCorps.LineSlant = TypeOrientation(Angle)
v = GetCoeff(Angle + DecalAngle)
trDroit.Width = v(0) * Taille * CoeffTaille
trDroit.Height = v(1) * Taille * CoeffTaille
trDroit.LineSlant = TypeOrientation(Angle)
v = GetCoeff(Angle - DecalAngle)
trGauche.Width = v(0) * Taille * CoeffTaille
trGauche.Height = v(1) * Taille * CoeffTaille
trGauche.LineSlant = TypeOrientation(Angle)
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
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
Dim x As Double
Dim y As Double
Dim Angle2 As Double
Const PI As Double = 3.14159265358979
Angle2 = (Angle Mod 90) * PI / 180
x = Abs(Cos(Angle2))
y = Abs(Sin(Angle2))
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
If Angle Mod 180 > 90 Then
TypeOrientation = False
Else
TypeOrientation = True
End If
End Function |
|
| | 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
Pour faire la correspondance entre le groupe d'option et les requêtes, on utilise l'énumération suivante :
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 :
Sub FillListView(ByVal TypeElement As mhTypeElement)
Dim rs As ADODB.Recordset
Dim sDataSources(3) As String
Dim intTotCount As Integer
Dim intCount1 As Integer
Dim intCount2 As Integer
Dim NewLine As Object
On Error GoTo GestErr
lvwElements.ListItems.Clear
lvwElements.ColumnHeaders.Clear
sDataSources(mhTypeElementClients) = "rqtClient"
sDataSources(mhTypeElementCommandes) = "rqtCommande"
sDataSources(mhTypeElementProduits) = "rqtProduit"
Set rs = New ADODB.Recordset
rs.Open sDataSources(TypeElement), _
CurrentProject.Connection, adOpenStatic, adLockReadOnly
For intCount1 = 0 To rs.Fields.Count - 1
lvwElements.ColumnHeaders.Add , , rs.Fields(intCount1).Name
Next intCount1
intTotCount = rs.RecordCount
For intCount1 = 1 To intTotCount
Set NewLine = lvwElements.ListItems.Add()
NewLine.Key = "ID" & CStr(rs(0).Value)
NewLine.Text = rs(0).Value
NewLine.Icon = TypeElement
NewLine.SmallIcon = TypeElement
For intCount2 = 2 To rs.Fields.Count
NewLine.SubItems(intCount2 - 1) = Nz(rs(intCount2 - 1).Value, "")
Next intCount2
rs.MoveNext
Next intCount1
OrderByCol 1, True
lvwElements.View = cdrVisu
Finprog:
On Error Resume Next
Exit Sub
GestErr:
Select Case Err.Number
Case 65000
MsgBox Err.Description, vbExclamation, "UBI"
Case Else
MsgBox "L'Erreur N° " & Err.Number & " (" & _
Err.Description & _
") s'est produite de manière inattendue dans la procédure" & _
" FillListView du module Document VBA Form_frmAccueil", _
vbCritical, "ERREUR INATTENDUE"
End Select
Resume Finprog
End Sub |
Explications : 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.
For intCount1 = 0 To rs.Fields.Count - 1
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.
For intCount1 = 1 To intTotCount
Set NewLine = lvwElements.ListItems.Add()
NewLine.Key = "ID" & CStr(rs(0).Value)
NewLine.Text = rs(0).Value
NewLine.Icon = TypeElement
NewLine.SmallIcon = TypeElement
For intCount2 = 2 To rs.Fields.Count
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éé.
OrderByCol 1, True
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 : Sub OrderByCol(ByVal NumCol As Long, _
ByVal NewFill As Boolean)
Static Colonne As Long
debut:
lvwElements.Sorted = True
If NumCol = Colonne And Not NewFill Then
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
If Colonne <> 0 Then _
lvwElements.ColumnHeaders(Colonne).Icon = 0
Colonne = NumCol
NewFill = False
lvwElements.SortOrder = 1
lvwElements.SortKey = _
lvwElements.ColumnHeaders(NumCol).Index - 1
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 : Private Sub lvwElements_ColumnClick _
(ByVal ColumnHeader As Object)
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.
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).
|
| | Versions : 2000 et supérieures
Pour fonctionner, ce code nécessite une référence Microsot ActiveX Data Object Dim WithEvents rsCli As ADODB.Recordset
Dim WithEvents rsEmp As ADODB.Recordset
Dim WithEvents rsCde As ADODB.Recordset
Private Sub cmdUpdate_Click()
Dim x As Node
If rsCli.State = adStateClosed Then rsCli.Open "Clients", _
CurrentProject.Connection, adOpenStatic
If rsEmp.State = adStateClosed Then rsEmp.Open "Employés", _
CurrentProject.Connection, adOpenStatic
rsCli.Requery: rsCli.MoveFirst
rsEmp.Requery: rsEmp.MoveFirst
ocxTree.Nodes.Clear
Set x = ocxTree.Nodes.Add(, , "c", "Clients", 1)
x.ExpandedImage = 2
Do Until rsCli.EOF
Set x = ocxTree.Nodes.Add("c", tvwChild, "C-" & rsCli(0), rsCli(1) & _
" (" & rsCli(2) & ")", 1)
rsCli.MoveNext
Loop
Set x = ocxTree.Nodes.Add(, , "e", "Employés", 1)
x.ExpandedImage = 2
Do Until rsEmp.EOF
Set x = ocxTree.Nodes.Add("e", tvwChild, "E-" & rsEmp(0), rsEmp(1) & _
" " & rsEmp(2), 1)
rsEmp.MoveNext
Loop
End Sub |
|
Auteur : Papilou
| | Version : 27/08/2004 | | |
| | 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 : Private Sub ListeSports_AfterUpdate()
ListEpreuve.RowSource = "Select [ID_Epreuves],[Epreuve],[IDSport] From T_Epreuves " & _
"where IDSport= " & ListeSports & ";"
ListEpreuve.Requery
End Sub |
|
| |
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 :
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...
|
| | 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 : 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 : 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)
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 :
Dim HDC As Long
CurrentDb.Execute ("DELETE FROM police")
HDC = GetDC(Me.hwnd)
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.
|
Auteur : GCUSSE
| | Version : 28/01/2005 | | |
| | 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éé..
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) : 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.
|
| |
Versions : Access 2000 et supérieures
Dans un module recopier la fonction suivante :
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 :
Private Sub AjouterProduit_Click()
subRefreshLists Me
End Sub |
|
| |
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 :
Nous utiliserons deux variables dans la portée du formulaire :
Dim oRstClient As DAO.Recordset
Dim intnbLus As Integer |
Le principe est simple, à l'ouverture du formulaire, nous chargons le Recordset
et affichons les 10 premiers enregistrements.
Private Sub Form_Load()
Dim oDb As DAO.Database
Set oDb = CurrentDb
Set oRstClient = oDb.OpenRecordset("Clients", dbOpenTable)
LectureVersLAvant
End Sub
Private Sub LectureVersLAvant()
On Error GoTo err
RemplirZoneTexte oRstClient.GetRows(10)
Exit Sub
err:
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.
Sub RemplirZoneTexte(Tableau As Variant)
Dim I As Integer
intnbLus = UBound(Tableau, 2) + 1
For I = 0 To intnbLus - 1
Controls("TCodeClient" & I + 1) = Tableau(0, I)
Controls("TCodeClient" & I + 1).Visible = True
Controls("TSociete" & I + 1) = Tableau(1, I)
Controls("TSociete" & I + 1).Visible = True
Controls("TVille" & I + 1) = Tableau(2, I)
Controls("TVille" & I + 1).Visible = True
Controls("TPays" & I + 1) = Tableau(3, I)
Controls("TPays" & I + 1).Visible = True
Next I
For I = intnbLus + 1 To 10
Controls("TCodeClient" & I).Visible = False
Controls("TSociete" & I).Visible = False
Controls("TVille" & I).Visible = False
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.
Private Sub LectureVersLArriere()
On Error GoTo err
oRstClient.Move -1 * intnbLus - 10
RemplirZoneTexte oRstClient.GetRows(10)
Exit Sub
err:
Select Case err.Number
Case 3021: oRstClient.MoveFirst
Case Else: MsgBox "Une erreur est survenue pendant la lecture des données", vbCritical, "Erreur"
End Select
End Sub |
Résultat :
N'hésitez pas à consulter le fichier zip joint et à consulter un cours complet sur DAO disponible ici.
|
| | 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 : Private Sub Restriction(ByVal Chaine As String, _
ByVal ChamP As String, ByVal matable As String, _
ByRef ArGument As Integer, ByRef ClausE As String, ByRef astype As Integer)
If ArGument = 0 Then
matable = Trim$(matable)
If InStr(1, matable, "SELECT ", vbTextCompare) <> 0 Then
If Right(matable, 1) = ";" Then _
matable = Left(matable, Len(matable) - 1)
ClausE = "SELECT * FROM (" & matable & ")"
Else
ClausE = "SELECT * FROM " & matable
End If
End If
If Chaine <> "" Then
If ArGument = 0 Then
ClausE = ClausE & " WHERE "
Else: ClausE = ClausE & " AND "
End If
Select Case astype
Case 0
ClausE = ClausE & ChamP & " like " & Chr(34) & Chaine & "*" & Chr(34)
Case 1
ClausE = ClausE & ChamP & "=" & Chaine
Case 2
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: Private Sub BRechercher_Click()
Dim SQL As String
Dim NomTable As String
Dim Compteur As Integer
NomTable = "Tbl_Materiel"
Restriction Nz(Tserie, ""), "NumSerie", NomTable, Compteur, SQL, 0
Restriction Nz(TDate, ""), "DateAchat", NomTable, Compteur, SQL, 2
Restriction Nz(TMarque, ""), "Marque", NomTable, Compteur, SQL, 0
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 :
NomTable = "SELECT * FROM Tbl_Materiel" |
|
| | 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 : Option Compare Database
Option Explicit
Dim mlngCpteEnr As Long
Dim mstrFiltré As String |
Code des boutons : Private Sub btcPrem_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acFirst
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.btcPrem_Click"
End Select
End Sub
Private Sub btcPréc_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acPrevious
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.btcPréc_Click"
End Select
End Sub
Private Sub btcSuiv_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acNext
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.btcSuiv_Click"
End Select
End Sub
Private Sub btcDern_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acLast
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.btcDern_Click"
End Select
End Sub
Private Sub btcNouv_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acNewRec
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " _
& Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.btcNouv_Click"
End Select
End Sub |
Code de la zone de texte txtAtteindre : Private Sub txtAtteindre_BeforeUpdate(Cancel As Integer)
On Error GoTo GestionErr
With Me!txtAtteindre
If Not IsNumeric(.Value) Then
MsgBox "Vous devez saisir un numéro d'enregistrement valide." & _
vbCrLf & _
"Vous pouvez appuyer sur Echap pour annuler votre saisie.", _
vbExclamation
.SelStart = 0
.SelLength = Len(.Value)
Cancel = True
End If
End With
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.txtAtteindre_BeforeUpdate"
End Select
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
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & _
" : " & Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.txtCourant_AfterUpdate"
End Select
End Sub |
Code sur les événements de formulaire : Private Sub Form_Current()
On Error GoTo GestionErr
sActivation
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.Form_Current"
End Select
End Sub
Private Sub Form_BeforeInsert(Cancel As Integer)
On Error GoTo GestionErr
Me!btcSuiv.Enabled = True
Me!btcNouv.Enabled = True
mlngCpteEnr = mlngCpteEnr + 1
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.Form_BeforeInsert"
End Select
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Dim strInfosNavig As String
On Error GoTo GestionErr
If Status = acDeleteOK Then
Select Case Me.NewRecord
Case True
strInfosNavig = "sur " & Me.CurrentRecord & mstrFiltré
Case False
sMajInfosNavig
strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
End Select
étqCpteEnr.Caption = strInfosNavig
End If
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.Form_AfterDelConfirm"
End Select
End Sub |
Procédures sub : Private Sub sActivation()
On Error GoTo GestionErr
Dim strInfosNavig As String
Me!txtAtteindre = Me.CurrentRecord
Me!btcPréc.Enabled = (Me.CurrentRecord > 1)
Select Case Me.NewRecord
Case True
Me!btcSuiv.Enabled = False
Me!btcNouv.Enabled = False
strInfosNavig = "sur " & Me.CurrentRecord
If Me.FilterOn Then strInfosNavig = strInfosNavig & " (Filtré)"
Case False
Me!btcSuiv.Enabled = True
Me!btcNouv.Enabled = True
If Me.CurrentRecord = 1 Then sMajInfosNavig
strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
End Select
étqCpteEnr.Caption = strInfosNavig
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.sActivation"
End Select
End Sub
Private Sub sMajInfosNavig()
Dim rs As DAO.Recordset
On Error GoTo GestionErr
If Me.FilterOn Then mstrFiltré = " (Filtré)"
Set rs = Me.RecordsetClone
rs.MoveLast
mlngCpteEnr = rs.RecordCount
rs.Close
Set rs = Nothing
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsAutorisés.sMajInfosNavig"
End Select
End Sub |
|
| | 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 : Option Compare Database
Option Explicit
Dim mlngCpteEnr As Long
Dim mstrFiltré As String |
Code des boutons : Private Sub btcPrem_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acFirst
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.btcPrem_Click"
End Select
End Sub
Private Sub btcPréc_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acPrevious
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.btcPréc_Click"
End Select
End Sub
Private Sub btcSuiv_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acNext
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.btcSuiv_Click"
End Select
End Sub
Private Sub btcDern_Click()
On Error GoTo GestionErr
DoCmd.GoToRecord , , acLast
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.btcDern_Click"
End Select
End Sub |
Code de la zone de texte txtAtteindre : Private Sub txtAtteindre_BeforeUpdate(Cancel As Integer)
On Error GoTo GestionErr
With Me!txtAtteindre
If Not IsNumeric(.Value) Then
MsgBox "Vous devez saisir un numéro d'enregistrement valide." & _
vbCrLf & _
"Vous pouvez appuyer sur Echap pour annuler votre saisie.", _
vbExclamation
.SelStart = 0
.SelLength = Len(.Value)
Cancel = True
End If
End With
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.txtAtteindre_BeforeUpdate"
End Select
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 < 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
If !txtAtteindre <> .CurrentRecord Then _
DoCmd.GoToRecord , , acGoTo, !txtAtteindre
End With
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.txtCourant_AfterUpdate"
End Select
End Sub |
Code sur les événements de formulaire : Private Sub Form_Current()
On Error GoTo GestionErr
sActivation
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.Form_Current"
End Select
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
Dim strInfosNavig As String
On Error GoTo GestionErr
If Status = acDeleteOK Then
sMajInfosNavig
strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
étqCpteEnr.Caption = strInfosNavig
End If
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.Form_AfterDelConfirm"
End Select
End Sub
Private Sub Form_Load()
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 : Private Sub sActivation()
On Error GoTo GestionErr
Dim strInfosNavig As String
Me!txtAtteindre = Me.CurrentRecord
Select Case Me.CurrentRecord
Case 1
Me!btcPréc.Enabled = False
sMajInfosNavig
Case Else
Me!btcPréc.Enabled = True
End Select
Me!btcSuiv.Enabled = (Me.CurrentRecord < mlngCpteEnr)
strInfosNavig = "sur " & mlngCpteEnr & mstrFiltré
étqCpteEnr.Caption = strInfosNavig
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.sActivation"
End Select
End Sub
Private Sub sMajInfosNavig()
Dim rs As DAO.Recordset
On Error GoTo GestionErr
If Me.FilterOn Then mstrFiltré = " (Filtré)"
Set rs = Me.RecordsetClone
rs.MoveLast
mlngCpteEnr = rs.RecordCount
rs.Close
Set rs = Nothing
Exit Sub
GestionErr:
Select Case Err.Number
Case Else
MsgBox "Erreur " & Err.Number & " : " & _
Err.Description, vbCritical, _
"Form_frmNavigationAjoutsInterdits.sMajInfosNavig"
End Select
End Sub |
|
| |
Version : 2000 et supérieures
Cet exemple permet de transposer les élements d'une liste de type "Liste de valeur" vers une autre.
Exemple :
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 :
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
If .Selected(i) Or Not LimiteSelection Then
lstDestination.RowSource = lstDestination.RowSource & .Column(0, i) & ";"
Else
strTemp = strTemp & .Column(0, i) & ";"
End If
Next i
.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 :
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite
End Sub |
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False
End Sub |
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche
End Sub |
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.
|
| |
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.
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 :
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 :
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 :
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
If LimiteSelection Then
For i = 0 To .ListCount - 1
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
Else
Db.Execute "UPDATE tblClients SET Selection=" & CInt(bolSelection)
End If
.Requery
End With
lstDestination.Requery
End Sub |
Il ne reste plus qu'alors à appeler cette procédure sur chaque bouton :
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite
End Sub |
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False, True
End Sub |
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche
End Sub |
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 :
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 :
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 :
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
If LimiteSelection Then
For i = 0 To .ListCount - 1
If .Selected(i) Then
If bolSelection Then
Db.Execute "INSERT INTO tblClientsSelectionnes (Code_Client) VALUES (" & _
Chr(34) & .Column(0, i) & Chr(34) & ")"
Else
Db.Execute "DELETE FROM tblClientsSelectionnes WHERE Code_Client=" & _
Chr(34) & .Column(0, i) & Chr(34)
End If
End If
Next i
Else
If bolSelection Then
Db.Execute "INSERT INTO tblClientsSelectionnes SELECT " & _
"Code_Client FROM tblClients"
Else
Db.Execute "DELETE FROM tblClientsSelectionnes"
End If
End If
.Requery
End With
lstDestination.Requery
End Sub |
Puis l'appel sur chaque bouton :
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite, , True
End Sub
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False, True
End Sub
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche, , False
End Sub
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.
|
Auteur : Fred.G
| | Version : 28/01/2005 | | |
| | 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 Sub sMajForm()
Sub sMajForm()
Dim lngClé As Long
Dim lngEnrActif As Long
Dim rs As DAO.Recordset
On Error GoTo GestErr
Echo False
If Me.RecordsetClone.RecordCount = 0 Then Exit Sub
lngClé = Me!ChampCléPrimaire
lngEnrActif = Me.CurrentRecord
Me.Requery
Set rs = Me.RecordsetClone
With rs
If rs.RecordCount = 0 Then Exit Sub
.FindFirst "ChampCléPrimaire=" & lngClé
Select Case .NoMatch
Case True
DoCmd.GoToRecord , , acGoTo, lngEnrActif
Case False
Me.Bookmark = .Bookmark
End Select
End With
rs.Close
Set rs = nothing
Echo True
Exit Sub
GestErr:
Select Case Err
Case 2105
DoCmd.GoToRecord , , aclast
Case Else
MsgBox Err.Description, Err.Number
End Select
rs.close
Set rs = nothing
Echo True
End Sub |
Pour fonctionner, ce code nécessite une référence Microsoft DAO.
|
Auteur : cafeine
| | Version : 28/01/2005 | | |
| | 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
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
Argz = OpenArgs
pos1 = InStr(Argz, "|@|")
strMsg = left(Argz, pos1 - 1)
strMsg = right(strMsg, Len(strMsg) - 4)
Dur = CInt(right(Argz, Len(Argz) - pos1 - 6))
Me.lblMain.Caption = strMsg
Me.OnTimer = "=xCloseFrm()"
Me.TimerInterval = Dur * 1000
End Sub
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 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 MyDialog "Attention cette fenêtre va se fermer dans 5 secondes",5 |
|
Auteur : Fred.G
| | Version : 27/08/2004 | | |
| | 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".
Private Sub bouton_Click()
If IsNull(Me!MaZoneDeListe) Then
MsgBox "Aucun élément sélectionné dans la liste.", vbCritical
Else
Docmd.Setwarnings False
DoCmd.RunSQL "DELETE MaTable.* FROM tbl WHERE MaTable.Id=""" & _
Me!MaZoneDeListe & """;"
Docmd.Setwarnings False
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 |
|
| | 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 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
MonRTF.TextRTF = ""
MonRTF.FileName = "" |
Ouvrir un document Private Sub MnuOuvrir_Click()
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
fichier = OuvrirUnFichier(Me.hwnd, "Ouvrir un fichier rtf", 1, "Fichier RTF", "rtf")
If fichier <> "" Then
MonRTF.LoadFile (fichier)
End If
Exit Sub
err:
MsgBox "Impossible d'ouvrir le fichier", vbExclamation, "Ouvrir..."
End Sub |
Enregistrer le contenu Private Sub enregistrer(fichier As String)
On Error GoTo err
If fichier = "" Then
fichier = EnregistrerUnFichier(Me.hwnd, _
"Enregistrer le document", "Document1.rtf", CurrentDb.Name)
End If
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 :
Private Sub MPolice_AfterUpdate()
changerPolice
End Sub
Private Sub MPolice_Click()
changerPolice
End Sub
Private Sub changerPolice()
MonRTF.SelFontName = MPolice
MonRTF.SetFocus
End Sub
Private Sub MTaille_AfterUpdate()
changerTaille
End Sub
Private Sub MTaille_Click()
changerTaille
End Sub
Private Sub changerTaille()
MonRTF.SelFontSize = MTaille
MonRTF.SetFocus
End Sub
Private Sub BGras_Click()
MonRTF.SelBold = BGras
MonRTF.SetFocus
End Sub
Private Sub BItalique_Click()
MonRTF.SelItalic = BItalique
MonRTF.SetFocus
End Sub
Private Sub Bsouligne_Click()
MonRTF.SelUnderline = Bsouligne
MonRTF.SetFocus
End Sub
Private Sub BBarre_Click()
MonRTF.SelStrikeThru = BBarre
MonRTF.SetFocus
End Sub
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
Private Sub BCouleur_Click()
Dim Couleur As Long
Couleur = ShowColor(Me.hwnd)
If Couleur <> -1 Then MonRTF.SelColor = Couleur
MonRTF.SetFocus
End Sub
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 |
|
Auteur : Lucifer
| | Version : 28/01/2005 | | |
| | 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 : 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.
|
 
|
