IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

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 

 
OuvrirSommaireAccess

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:

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

Module:

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

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

Créé le 27 août 2004  par Shwin

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 :

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

Voici un exemple d'utilisation :

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

Créé le 28 janvier 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Pour désactiver
Déclarer dans un module indépendant :

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

 
Sélectionnez
DesacFermeture

Pour activer

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

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 :

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

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

Puis une procédure pour lire le fichier en accés direct :

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

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

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

Créé le 5 mars 2005  par Tofalu

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

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.

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

Cette procédure recopie les champs de la table source vers la table de destination.

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

la même opération est effectuée sur les index :

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

Les procédures suivantes dupliquent les propriétés spécifiques des objets.

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

La procédure suivante teste l'existence d'une propriété suivant son nom.

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

Enfin, ces deux procédures permettent d'injecter les données depuis la table source vers la nouvelle table.

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

Créé le 20 mai 2005  par Tofalu

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

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 :

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

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

Enfin, l'import se fait tout simplement à l'aide de l'instruction :

 
Sélectionnez
Importer "D:\clients.txt"

N'hésitez pas à consulter le fichier Zip pour visualiser en détail le comportement de l'application.

Créé le 20 mai 2005  par Tofalu

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

Versions : 97 et supérieures

Dans un module :

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

Appel de la procédure pour supprimer la menu système de la barre de titre Access:

 
Sélectionnez
RemoveSystemMenu(Application.hWndAccessApp)
Créé le 27 août 2004  par extros

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