Salut et merci pour vos réponses. J'ai trouvé la solution ailleurs et je la transmet pour ceux qui sont intéressés:
On crée une base access vierge.
dans cette base on crée une macro AutoExec avec :
- ExécuterCommande --> RéduireEnIcône
- ExécuterCode --> CreateShortCut()
- Quitter
Ensuite on crée un nouveau module dans le quel on copie le code suivant:
(je ne sais pas si c'est comme ça qu'on présente un code... je suis nouvelle dans le monde des forum!!!) :
Option Compare Database
Option Explicit
'Déclaration d'API
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (pidl As Long, ByVal pszPath As String) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Const MAX_PATH = 260
Private Const CSIDL_DESKTOP = &H0
'Structure du fichier
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Dialogue Choix Fichier
Private Function GetFileName(handle As Long, Titre As String, Optional TitreFiltre As String, Optional TypeFichier As String, Optional RepParDefaut As String) As String
Dim StructFile As OPENFILENAME
Dim sFiltre As String
'Construction du filtre en fonction des arguments spécifiés
If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & "*." & TypeFichier & Chr$(0)
End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)
'Configuration de la boîte de dialogue
With StructFile
.lStructSize = Len(StructFile)
.hwndOwner = handle
.lpstrFilter = sFiltre
.lpstrFile = String$(254, vbNullChar)
.nMaxFile = 254
.lpstrFileTitle = String$(254, vbNullChar)
.nMaxFileTitle = 254
.lpstrTitle = Titre
.flags = 0
.lpstrInitialDir = RepParDefaut
End With
If (GetOpenFileName(StructFile)) Then
GetFileName = Trim$(Left(StructFile.lpstrFile, InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
End If
End Function
' Chemin du bureau
Public Function GetDesktopPath() As String
Dim lIDl As Long
Dim ls As String
If SHGetSpecialFolderLocation(0&, CSIDL_DESKTOP, lIDl) = 0 Then
ls = String(MAX_PATH + 2, 0)
If SHGetPathFromIDList(ByVal lIDl, ls) <> 0 Then
GetDesktopPath = Left(ls, InStr(1, ls, vbNullChar) - 1)
End If
End If
If lIDl <> 0 Then GlobalFree lIDl
End Function
' Création d'un raccourci
Public Function CreateShortCut()
Dim WshShell As Object
Dim oShellLink As Object
Dim lFullPath As String
Dim lPath As String
Dim lFileName As String
Dim i As Integer
Dim lLenPath As Integer
Dim lLenExt As Integer
On Error GoTo gestion_erreurs
' Chemin de l'application à ajouter dans le raccourci
lFullPath = GetFileName(Application.hWndAccessApp, "Chemin de la base Access", "Base de données Access", "MDB", CurrentProject.Path)
' Recherche de la position du "\" pour le chemin et du "." pour l'extension
For i = 1 To Len(lFullPath)
If Mid(lFullPath, i, 1) = "\" Then lLenPath = i
If Mid(lFullPath, i, 1) = "." Then lLenExt = Len(lFullPath) - i + 1
Next
' Chemin
lPath = Left(lFullPath, lLenPath)
' Fichier (sans l'extension
lFileName = Left(Right(lFullPath, Len(lFullPath) - lLenPath), Len(lFullPath) - lLenPath - lLenExt)
' Objet Shell
Set WshShell = CreateObject("WScript.Shell")
' Création du lien sur le bureau
Set oShellLink = WshShell.CreateShortCut(GetDesktopPath & "\" & lFileName & ".lnk")
' Chemin de access
oShellLink.TargetPath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
' Chemin de l'application
oShellLink.WorkingDirectory = lPath
' Application à ouvrir et fichier de travail
oShellLink.Arguments = lFullPath & " /WRKGRP " & GetFileName(Application.hWndAccessApp, "Chemin du fichier de sécurité", "Fichier de sécurité", "MDW")
oShellLink.Save
MsgBox "Raccourci créé sur le bureau"
gestion_erreurs:
If Err.Number <> 0 Then MsgBox Err.Description
End Function
