Les meilleures sources Access
Les meilleures sources AccessConsultez toutes les sources
Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013
Sommaire→Access- Création d'un thread dans access
- Définir les options de démarrage en VBA
- Désactiver/Activer le bouton fermeture du menu système de la fenêtre Access.
- Importer des données depuis un fichier texte qui ne possède pas de délimiteur
- Importer une table depuis une base de données sécurisée
- Importer un fichier texte où les champs apparaissent en ligne
- Supprimer le menu système de la barre de titre Access
Versions : 2000 et supérieures
Même si VB n'est pas fait pour cela, il peut être utile parfois de créer un ou plusieurs thread. Ceci doit bien entendu être limité car VB n'est pas du tout à l'aise dans la gestion des threads (pas plus de 2 ou 3). De plus la gestion de ces derniers étant directement confiée à windows, cela peut rendre votre système instable.
Formulaire:
Private Sub Commande0_Click()
hThread = CreateThread(ByVal 0&, ByVal 0&, AddrOf("CallBackFunc"), _
ByVal 0&, ByVal 0&, hThreadID)
hThread2 = CreateThread(ByVal 0&, ByVal 0&, AddrOf("CallBackFunc2"), _
ByVal 0&, ByVal 0&, hThreadID2)
CloseHandle hThread 'ferme le handle
CloseHandle hThread2
Dim e As Long
e = TerminateThread(hThread, 0) 'ferme le thread
e = TerminateThread(hThread2, 0)
End SubModule:
Option Compare Database
Option Explicit
Public i, i2 As Integer
Public hThread As Long, hThreadID As Long
Public hThread2 As Long, hThreadID2 As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function IsWindowVisible Lib "user32" _
(ByVal hwnd As Long) As Long
Public Declare Function GetCurrentVbaProject _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hProject As Long) As Long
Public Declare Function GetFuncID _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long
Public Declare Function GetAddr _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long
Public Declare Function CreateThread Lib "kernel32" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, lpParameter As Any, _
ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Public Declare Function TerminateThread Lib "kernel32" _
(ByVal hThread As Long, ByVal dwExitCode As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Function CallBackFunc() As Long
i = i + 1
End Function
Public Function CallBackFunc2() As Long
i2 = i2 + 2
End Function
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
Call GetCurrentVbaProject(hProject)
If hProject <> 0 Then
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End FunctionNoter que addrof sert uniquement dans access97, depuis access2000 addressof est pris en compte.Comment le prouver ?: Placez un point d'arrêt sur callbackfunc ensuite exécuter le code via le bouton et regardez la valeur de i2, celle-ci est incrémentée de 2 alors que normalement sans thread, il aurait fallu attendre la fin de l'instruction avant de passer à une autre ligne de commande, c'est ce qu'on appelle la programmation séquentielle. Ici l'appel de callbackfunc et callbackfunc2 se font en même temps. Maintenant essayez ceci:
Private Sub Commande0_Click()
Dim e As Long
e = CallBackFunc
e = CallBackFunc2
End SubRemarque : I2 n'est pas incrémenté quand on exécute la procédure callbackfunc. Normal puisque ce code est séquentiel.
Versions : 2000 et supérieures
Tout d'abord, ajouter une référence Microsoft DAO à votre projet (sous VBA, outils, références)
Dans un module :
Public Enum Demarrage
AutoriserMenuContextuel
NomTitreApplication
AutoriserMenuComplet
AutoriserTouchesSpeciales
AfficherFenetreBD
AfficherBarreEtat
AfficherBarreOutils
AutoriserModificationBarreOutils
NomIcone
NomFormualireDemarrage
NomMenuContextuel
NomBarreMenu
End Enum
Public Sub ChangerPropriete(Nom As Demarrage, Valeur)
Dim db As DAO.Database
Set db = CurrentDb
Dim NomProp As String
NomProp = NomPropriete(Nom)
If testProperty(db, NomProp) Then
db.Properties(NomProp).Value = Valeur
Else
db.Properties.Append db.CreateProperty(NomProp, TypePropriete(Nom), _
Valeur, False)
End If
'Si on modifie le titre, alors prendre la modification
' en compte immédiatement
If NomProp=1 then Application.RefreshTitleBar
End Sub
Private Function testProperty(Objet As Object, Nom As String) As Boolean
On Error GoTo err
Dim Prop As DAO.Property
Set Prop = Objet.Properties(Nom)
testProperty = True
err:
End Function
Private Function NomPropriete(Valeur As Demarrage) As String
Select Case Valeur
Case 0
NomPropriete = "AllowShortcutMenus"
Case 1
NomPropriete = "AppTitle"
Case 2
NomPropriete = "AllowFullMenu"
Case 3
NomPropriete = "AllowBypassKey"
Case 4
NomPropriete = "StartupShowDBWindow"
Case 5
NomPropriete = "StartupShowStatusBar"
Case 6
NomPropriete = "AllowBuiltInToolbars"
Case 7
NomPropriete = "AllowToolbarChanges"
Case 8
NomPropriete = "AppIcon"
Case 9
NomPropriete = "StartupForm"
Case 10
NomPropriete = "StartupShortcutMenuBar"
Case 11
NomPropriete = "StartupMenuBar"
End Select
End Function
Private Function TypePropriete(Valeur As Demarrage) As Integer
Select Case Valeur
Case 1, 8, 9, 10, 11
TypePropriete = dbText
Case Else
TypePropriete = dbBoolean
End Select
End FunctionVoici un exemple d'utilisation :
'choisir l'icone
ChangerPropriete NomIcone, "c:\fich.ico"
'Choisir la barre de menu
ChangerPropriete NomBarreMenu, "MaBarre"
'Choisir le nom de l'application
ChangerPropriete NomTitreApplication, "MonApplication"
'masquer le fenêtre de BD au démarrage
ChangerPropriete AfficherFenetreBD, False
'interdire la modification des barres d'outils
ChangerPropriete AutoriserModificationBarreOutils, False
Même si les informations sont enregistrées à la fin de ce traitement, celles-ci ne prendront effet qu'au prochain démarrage de l'application. Exception : la modification du titre de la fenêtre Access peut être prise en compte immédiatement grâce à la méthode RefreshTitleBar.
Versions : 97 et supérieures
Pour désactiver
Déclarer dans un module indépendant :
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Const SC_CLOSE = &HF060&
Public Const MF_BYCOMMAND = &H0&
Public Sub DesacFermeture()
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(Application.hWndAccessApp, False)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
End SubEnsuite, utiliser par exemple sur chargement d'un formulaire (idéalement le menu général) :
DesacFermeturePour activer
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Sub ReactiveFermeture()
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(Application.hWndAccessApp, True)
DrawMenuBar hSysMenu
End SubCet exemple de code permet d'importer des données depuis un fichier texte. La caractéristique de ce fichier texte est que les enregistrements sont mis les uns à la suite des autres sans séparateur. Nous ne connaissons que la taille des différents champs.
Un exemple de fichier texte :
0001WARIN Christophe0002BALTAZARD Marie
0004DUPONT Jacques 0005PIERRE Louis 0006HUGUES Hugo
0007PARQ PatricePour importer un tel fichier, nous allons créer une table correspondante avec les mêmes champs, à savoir :
- Un champ Numero de type entier.
- Un champ Nom de type texte.
- Un champ Prénom de type texte
Puis dans un module, nous allons créer un type Enregistrement qui correspondra à une occurence dans notre fichier texte.
Private Type enregistrement
Num As String * 4 'Numero sur 4 caractères
Nom As String * 10 'Nom sur 10 caractères
Prenom As String * 10 'prenom sur 10 caractères
End TypePuis une procédure pour lire le fichier en accés direct :
Public Sub lireFichier(chemin As String)
On Error GoTo err
Dim Fichier As Integer, numenr As Long
Dim Client As enregistrement
Dim NbErreur As Long
Dim Stopper as boolean
stopper = False
'recupere un numero de fichier libre
Fichier = FreeFile
'Ouvre le fichier
Open chemin For Random As Fichier Len = Len(Client)
numenr = 1
'parcours le fichier
While Not EOF(Fichier) And Not stopper
Get 1, numenr, Client
'si l'enregistrement n'est pas vide
With Client
If .Nom <> "" Then
'inserer dans la table
NbErreur = NbErreur + Insererdanstable(CLng(.Num), _
.Nom, .Prenom, stopper)
End If
End With
'augmente le numero de l'enregistrement à lire
numenr = numenr + 1
Wend
'Affiche le resume
MsgBox "Insertion terminée avec : " & _
NbErreur & " erreur(s)", vbInformation, _
"Insertion..."
GoTo fin
err:
'si erreur avertit l'utilisateur
MsgBox "Echec" & vbCrLf & vbCrLf & _
err.Description, vbCritical, "Insertion..."
fin:
'Ferme le fichier
Close Fichier
End SubL'ouverture se fait en mode direct grâce à l'instruction Open for random. Ensuite, il faut passer à la même instruction la longueur en octet d'un enregistrement. Cela correspond à la longueur de la variable Client. Enfin, il faut lire chaque enregistrement grâce à l'instruction Get en passant le numéro de l'enregsitrement en question (NumEnr), jusqu'à atteindre la fin du fichier (fonction EOF).
Dans l'instruction Get, le premier paramètre correspond à l'octet de l'enregistrement concerné à lire. En général, on s'interresse à la globalité des données. La lecture commence donc à l'octet 1. Le second est, comme nous l'avons dit plus haut, le numéro de l'enregistrement. Enfin le troisième est une variable qui va recevoir les données.
Il faut ensuite rajouter une procédure qui enregistrera les données dans notre base de données :
Private Function Insererdanstable(VNumero As Long, _
VNom As String, VPrenom As String,ByRef Stopper as Boolean ) As Long
On Error GoTo err
Dim SQL As String
'Créer la requête d'insertion
SQL = "INSERT INTO Tbl_Client (Numero,nom,prenom) VALUES " & _
"(" & VNumero & "," & AjouterQuote(VNom) & "," & _
AjouterQuote(VPrenom) & ")"
CurrentDb.Execute SQL
Exit Function
err:
Insererdanstable = 1
MsgBox "impossible d'insérer : " & vbcrl & _
VNumero & vbCrLf & _
VNom & vbCrLf & _
VPrenom & vbCrLf & vbCrLf & _
err.Description, vbCritical, "Insertion"
If MsgBox("voulez vous continuer ?", vbQuestion + vbYesNo, _
"Insertion") = vbNo Then stopper = True
End Function
Private Function AjouterQuote(Chaine As String) As String
'enleve les caractère nuls
Chaine = Replace(Chaine, Chr(0), "")
'Ajoute " de chaque coté de la chaine et
'double les guillemets à l'intérieur de
'la chaine et elimine les espaces
AjouterQuote = Chr(34) & Trim$(Replace(Chaine, Chr(34), _
Chr(34) & Chr(34))) & Chr(34)
End FunctionEn cas d'erreur d'insertion, un message demande à l'utilisateur s'il veut continuer. Si il répond Non, le booléen Stopper est fixé à true ce qui aura pour effet de faire sortir le programme de la boucle de lecture ici :
While Not EOF(Fichier) And Not stopperPour comprendre d'avantage le fonctionnement, je vous invite à télecharger le fichier zip qui contient l'ensemble de l'application.
Version : Access 2000 et supérieures
Lorsque vous souhaitez importer une table depuis une autre application à l'aide de la méthode Docmd.TransferDatabase, il est impossible de le faire avec une base de données distante protégée par mot de passe. De même il est impossible d'utiliser les informations de connexion : mot de passe et login du fichier System.mdw.
Pour réaliser une telle opération, vous devez utiliser DAO. Pour cela, ajouter une référence Microsoft DAO 3.6 Object Library à votre projet.
A l'aide du code source suivant : Ouvrir un objet DAO.Database en s'identifiant dans un groupe de travail, vous allez pouvoir ouvrir un objet DAO.Database correspondant à la base de données où prélever la table.
Ensuite, il suffit de recopier à l'identique chacunes des caractèristiques de la table à importer vers la base de données courante. Le code va ainsi parcourir chaque champ, chaque index, chaque propriété, etc ...
Pour cela vous pouvez utiliser la liste des procédures suivante :
Cette procédure est la procédure principale à appeler. Les arguments sont d'une part l'objet database précedement ouvert et d'autre part le nom de la table à importer. Elle appelle chacune des sous-procédures destinées à copier les objets.
Private Sub DupliquerTable(oDbSource As DAO.Database, strNomTable As String)
Dim oDbDestination As DAO.Database
Dim oTblSource As DAO.TableDef
Dim oTblDest As DAO.TableDef
'Instancie la base de données courant
Set oDbDestination = CurrentDb
Set oTblSource = oDbSource.TableDefs(strNomTable)
'Crée la table destination
Set oTblDest = oDbDestination.CreateTableDef(strNomTable, oTblSource.Attributes)
'Duplique les propriétés de la table
DupliquerToutesProprietes oTblSource, oTblDest
'Duplique les champs
DupliquerChamp oTblSource, oTblDest
'Duplique les index
DupliquerIndex oTblSource, oTblDest
'Ajoute la table à la base de données
oDbDestination.TableDefs.Append oTblDest
'Copie les données
CopierDonnees oTblSource, oTblDest
MsgBox "fini"
End SubCette procédure recopie les champs de la table source vers la table de destination.
Private Sub DupliquerChamp(oTblSource As Object, oTblDest As Object)
Dim oFld As DAO.Field
Dim oFldDest As DAO.Field
'Pour chaque champ de la table source
For Each oFld In oTblSource.Fields
'Crée le champ correspondant dans la table de destination
Set oFldDest = oTblDest.CreateField
'Duplique les propriétés du champ
DupliquerToutesProprietes oFld, oFldDest
'Ajoute le champ à la table
oTblDest.Fields.Append oFldDest
DoEvents
Next
End Subla même opération est effectuée sur les index :
Private Sub DupliquerIndex(oTblSource As DAO.TableDef, oTblDest As DAO.TableDef)
Dim oInd As DAO.Index
Dim oIndDest As DAO.Index
'Pour chaque index de la table source
For Each oInd In oTblSource.Indexes
'Crée l'index correspondant dans la table de destination
Set oIndDest = oTblDest.CreateIndex
'Duplique les propriétés de l'index
DupliquerToutesProprietes oInd, oIndDest
'Ajoute l'index à la table
DupliquerChamp oInd, oIndDest
oTblDest.Indexes.Append oIndDest
DoEvents
Next
End SubLes procédures suivantes dupliquent les propriétés spécifiques des objets.
Private Sub DupliquerToutesProprietes(oSource As Object, oDestination As Object)
Dim oProp As DAO.Property
'Pour chaque propriété de oSource, la dupliquer
For Each oProp In oSource.Properties
DupliquerUnePropriete oProp, oDestination
DoEvents
Next
End Sub
Private Sub DupliquerUnePropriete(oProp As DAO.Property, oDestination As Object)
On Error GoTo err
'si la propriété existe, on change sa valeur, sinon
'on la crée
If ExistProperty(oDestination, oProp.Name) Then
oDestination.Properties(oProp.Name).Value = oProp.Value
Else
oDestination.Properties.Append _
oDestination.CreateProperty(oProp.Name, oProp.Type, oProp.Value)
End If
err:
End SubLa procédure suivante teste l'existence d'une propriété suivant son nom.
Public Function ExistProperty(oObjet As Object, strNom As String) As Boolean
On Error GoTo err
Dim oPropTemp As DAO.Property
'Tente un accès à la propriété
Set oPropTemp = oObjet.Properties(strNom)
'Renvoie true si la propriété a été trouvée
ExistProperty = True
err:
End FunctionEnfin, ces deux procédures permettent d'injecter les données depuis la table source vers la nouvelle table.
Private Sub CopierDonnees(oTblSource As DAO.TableDef, oTblDest As DAO.TableDef)
Dim oRstSource As DAO.Recordset
Dim oRstDest As DAO.Recordset
Dim oFld As DAO.Field
Set oRstSource = oTblSource.OpenRecordset
Set oRstDest = oTblDest.OpenRecordset
While Not oRstSource.EOF
oRstDest.AddNew
For Each oFld In oRstSource.Fields
CopierValeur oFld, oRstDest.Fields(oFld.Name)
Next
oRstDest.Update
oRstSource.MoveNext
DoEvents
Wend
End Sub
Private Sub CopierValeur(oFldSource As DAO.Field, oFldDest As DAO.Field)
On Error GoTo err
oFldDest.Value = oFldSource.Value
err:
End SubVous vous demandez surement pourquoi ce code est divisé en de nombreuses procédures. Et bien non seulement, cela rend le code plus lisible et plus maintenable qu'un gros bloc mais surtout, cela évite que l'exécution de la procédure principale s'arrête à la première erreur. Prenons un exemple simple. Si un champ est de type NuméroAuto, il est impossible de définir sa valeur. Aussi si la table en contenait un, une erreur serait levée dés la première tentative d'écriture et le code s'arrêterait. Ici, ce n'est pas le cas, puisque seule la procédure CopierValeur sera interrompue et non la globalité du programme.
Etant donné le nombre important de boucle For...Each, il va de soi que le processus peut être assez lent. Aussi, il est nécessaire de prévenir l'utilisateur que le traitement peut s'avérer assez long.
N'hésitez pas à télecharger le fichier zip afin de tester par vous-même le fonctionnement et de comprendre l'interraction avec le code source cité plus haut.
Versions : 2000 et supérieures
Parfois, vous souhaitez importer un fichier texte qui ne respecte pas la norme des fichiers texte compris par Access à savoir : les champs doivent apparaître en colonne. C'est notamment le cas de certains fichier de rapport de log de serveur. Voici un exemple d'un tel fichier :
NAME : 03dbw1
REALNAME : 03dbw1
OS : POWER_604 (4 cpu) AIX 4.3
--------------------------------
NAME : 03pbdd
REALNAME : 03pbdd
OS : Xeon 2.80GHz HT (4 cpu) NT Server 5.0
--------------------------------
NAME : 05eapp2
REALNAME : 05eapp2
OS : POWER_604 (4 cpu) AIX 4.3
--------------------------------
NAME : 30dapp1
REALNAME : 30dapp1
OS : POWER_630 (4 cpu) AIX 4.3
--------------------------------
NAME : 30eapp1
REALNAME : 30eapp1
OS : POWER_630 (4 cpu) AIX 4.3Nous constatons que les champs sont les uns en dessous des autres et que les enregistrements sont séparés par une ligne de tirets.
Un moyen simple d'importer un tel fichier est de créer une table possédant les mêmes champs que ceux qui apparaissent dans le texte.
Ici, nous aurons donc la table suivante :
Tbl_Import(Numero,NAME,REALNAME,OS)
Numero est une clé primaire de type NumeroAuto afin d'identifier chaque enregistrement dans votre application.
Pour enregistrer les données dans la table, il est nécessaire de créer un code qui va lire le fichier texte ligne par ligne et d'envoyer les données dans le champ correspondant. Enfin, quand on rencontre une ligne commançant par ---, cela signifie qu'il s'agit d'un nouvel enregistrement.
Avant d'écrire le code, vous devez ajouter les références Microsoft Scripting Runtime (pour lire le fichier texte) et Microsoft DAO Object Library (pour accéder à la table) à votre projet (Sous VBA/Outils/Références)
Dans un module, placez le code suivant :
Public Sub Importer(strNomFichier As String)
Dim FSO As New Scripting.FileSystemObject
Dim oFichier As Scripting.TextStream
Dim strLigne As String
Dim strNomChamp As String
Dim strValeur As String
Set oFichier = FSO.OpenTextFile(strNomFichier, ForReading)
Dim oRst As DAO.Recordset
Dim I As Integer
'Charge la table en mémoire
Set oRst = CurrentDb.OpenRecordset("tbl_Import", dbOpenTable)
'Tant que non fin de fichier
While Not oFichier.AtEndOfStream
'lit la ligne
strLigne = oFichier.ReadLine
'Si elle n'est pas vide
If Trim(strLigne) <> "" Then
'Si c'est une ligne de --------
If Left(strLigne, 3) = "---" Then
'Si on est sur un nouvel enregistrement, on le valide
If oRst.EditMode = dbEditAdd Then oRst.Update
Else
'Sinon, si on est pas en mode ajout, on ajoute un nouvel enregistrement
If Not oRst.EditMode = dbEditAdd Then
oRst.AddNew
'Fixe le numéro
oRst.Fields("Numero") = oRst.RecordCount + 1
End If
'Récupère la position des :
I = InStr(1, strLigne, ":", vbTextCompare)
If I > 0 Then
'Récupère le nom du champ et la valeur
strNomChamp = Left(strLigne, I - 3)
strValeur = Trim(Mid(strLigne, I + 2))
'Remplit la table
oRst.Fields(strNomChamp).Value = strValeur
End If
End If
End If
Wend
'Ferme tout
oFichier.Close
oRst.Close
Set oRst = Nothing
Set oFichier = Nothing
Set FSO = Nothing
End SubEnfin, l'import se fait tout simplement à l'aide de l'instruction :
Importer "D:\clients.txt"N'hésitez pas à consulter le fichier Zip pour visualiser en détail le comportement de l'application.
Versions : 97 et supérieures
Dans un module :
'Declaration de l'API
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
' Déclare les constantes
Global Const GWL_STYLE = (-16)
Global Const WS_SYSMENU = &H80000
' Structure Rect utilisée par l'api
Type RECT
Left As Long
top As Long
Right As Long
Bottom As Long
End Type
Function RemoveSystemMenu(hwnd As Long)
Dim OldStyle As Long, NewStyle As Long
On Error Resume Next
' Recupere le style de la fenêtre
OldStyle = GetWindowLong(hwnd, GWL_STYLE)
' Créer le style l'identique sans la croix
NewStyle = OldStyle And Not WS_SYSMENU
'Affecte le nouveau style
OldStyle = SetWindowLong(hwnd, GWL_STYLE, NewStyle)
End FunctionAppel de la procédure pour supprimer la menu système de la barre de titre Access:
RemoveSystemMenu(Application.hWndAccessApp)