Raccourci d'une base de données sécurisée.

**rabine** · 21/04/2006, 23h12

Bonjour,
J'ai une application ACCESS qui est sécurisée, ce qui implique qu'il faut utiliser un raccourci pour y accéder.
exemple :
C:\access2000\Office\MSACCESS.EXE "C:\projet\projet.mdb" /WRKGRP C:\projet\Sécurisé.mdw"
Je veut savoir s'il y a un moyen pour créer un racccourci automatiquement en fonction de l'emplacement d'ACCESS et de l'application.
Parfois des utilisateurs changent le répertoire de l'application oubien celui d'ACCESS(en le réinstallant par exemple) et ne savent pas comment modifier le raccourci!

merci.

**Arkham46** · 22/04/2006, 17h28

slt,

à priori il faut créer un utilitaire indépendant

tu peux mettre le module suivant dans une base access vierge.
dans ma base j'ai mis une macro AutoExec avec :
- ExécuterCommande --> RéduireEnIcône
- ExécuterCode --> CreateShortCut()
- Quitter

le module demande le chemin de la base de données et du fichier de sécurité, et crée un raccourci sur le bureau

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
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