Auteur : Shwin
| | Version : 27/08/2004 | | |
| | 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
CloseHandle hThread2
Dim e As Long
e = TerminateThread(hThread, 0)
e = TerminateThread(hThread2, 0)
End Sub |
Module:
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 Function |
Noter 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 Sub |
Remarque : 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
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 Function |
Voici un exemple d'utilisation :
ChangerPropriete NomIcone, "c:\fich.ico"
ChangerPropriete NomBarreMenu, "MaBarre"
ChangerPropriete NomTitreApplication, "MonApplication"
ChangerPropriete AfficherFenetreBD, False
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.
|
Auteur : Thogal
| | Version : 27/08/2004 | | |
| | 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 Sub |
Ensuite, utiliser par exemple sur chargement d'un formulaire (idéalement le menu général) :
Pour 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 Sub |
|
| | Cet 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 Patrice |
Pour 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
Nom As String * 10
Prenom As String * 10
End Type |
Puis 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
Fichier = FreeFile
Open chemin For Random As Fichier Len = Len(Client)
numenr = 1
While Not EOF(Fichier) And Not stopper
Get 1, numenr, Client
With Client
If .Nom <> "" Then
NbErreur = NbErreur + Insererdanstable(CLng(.Num), _
.Nom, .Prenom, stopper)
End If
End With
numenr = numenr + 1
Wend
MsgBox "Insertion terminée avec : " & _
NbErreur & " erreur(s)", vbInformation, _
"Insertion..."
GoTo fin
err:
MsgBox "Echec" & vbCrLf & vbCrLf & _
err.Description, vbCritical, "Insertion..."
fin:
Close Fichier
End Sub |
L'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
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
Chaine = Replace(Chaine, Chr(0), "")
AjouterQuote = Chr(34) & Trim$(Replace(Chaine, Chr(34), _
Chr(34) & Chr(34))) & Chr(34)
End Function |
En 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 stopper |
Pour 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.TransfertDatabase,
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.
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
Set oDbDestination = CurrentDb
Set oTblSource = oDbSource.TableDefs(strNomTable)
Set oTblDest = oDbDestination.CreateTableDef(strNomTable, oTblSource.Attributes)
DupliquerToutesProprietes oTblSource, oTblDest
DupliquerChamp oTblSource, oTblDest
DupliquerIndex oTblSource, oTblDest
oDbDestination.TableDefs.Append oTblDest
CopierDonnees oTblSource, oTblDest
MsgBox "fini"
End Sub |
Cette 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
For Each oFld In oTblSource.Fields
Set oFldDest = oTblDest.CreateField
DupliquerToutesProprietes oFld, oFldDest
oTblDest.Fields.Append oFldDest
DoEvents
Next
End Sub |
la 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
For Each oInd In oTblSource.Indexes
Set oIndDest = oTblDest.CreateIndex
DupliquerToutesProprietes oInd, oIndDest
DupliquerChamp oInd, oIndDest
oTblDest.Indexes.Append oIndDest
DoEvents
Next
End Sub |
Les 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
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
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 Sub |
La 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
Set oPropTemp = oObjet.Properties(strNom)
ExistProperty = True
err:
End Function |
Enfin, 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 Sub |
Vous 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.3 |
Nous 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
Set oRst = CurrentDb.OpenRecordset("tbl_Import", dbOpenTable)
While Not oFichier.AtEndOfStream
strLigne = oFichier.ReadLine
If Trim(strLigne) <> "" Then
If Left(strLigne, 3) = "---" Then
If oRst.EditMode = dbEditAdd Then oRst.Update
Else
If Not oRst.EditMode = dbEditAdd Then
oRst.AddNew
oRst.Fields("Numero") = oRst.RecordCount + 1
End If
I = InStr(1, strLigne, ":", vbTextCompare)
If I > 0 Then
strNomChamp = Left(strLigne, I - 3)
strValeur = Trim(Mid(strLigne, I + 2))
oRst.Fields(strNomChamp).Value = strValeur
End If
End If
End If
Wend
oFichier.Close
oRst.Close
Set oRst = Nothing
Set oFichier = Nothing
Set FSO = Nothing
End Sub |
Enfin, 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.
|
Auteur : extros
| | Version : 27/08/2004 | | |
| | Versions : 97 et supérieures
Dans un module :
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
Global Const GWL_STYLE = (-16)
Global Const WS_SYSMENU = &H80000
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
OldStyle = GetWindowLong(hwnd, GWL_STYLE)
NewStyle = OldStyle And Not WS_SYSMENU
OldStyle = SetWindowLong(hwnd, GWL_STYLE, NewStyle)
End Function |
Appel de la procédure pour supprimer la menu système de la barre de titre Access:
RemoveSystemMenu(Application.hWndAccessApp) |
|
 
|
