Discussion :

[jff42]

Bonjour,
Je fournis à un utilisateur une base accdR avec Accessruntime.
Au lancement j'ai toujours un "avis de sécurité Access"

Un problème de sécurité potentiel...

Comme on n'a que le runtime, comment définir un emplacement approuvé ?

NB : j'ai tenté de mettre une signature sur le code, j'ai un message de blocage me disant que je ne peux signer qu'un paquetage accdc. Je l'ai fait, mais à l'install, ça ne fait que contrôler le décompactage, et ensuite je retrouve mon accdb (ou accdr) avec son avis de sécurité.
Une suggestion ? Merci.

[RobiPMS]

Bonjour.
Ces deux discussions devraient te permettre de régler ce problème :
http://www.developpez.net/forums/d98...rosoft-access/ et http://www.developpez.net/forums/d12...rouve-runtime/
Cordialement.

[jff42]

Bonjour,
J'ai récupéré le script pour ajouter mon dossier approuvé dans la base de registre.

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
Public Sub EmplacementApprouve()
On Error GoTo err:
Const KEY As String = "HKCU\Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\Location0\"
Dim s As String
    s = CurrentProject.Path
    WriteIntoReg KEY, "AllowSubFolders", 0, "REG_DWORD"  '0 = n'autorise pas les sub_folders
    WriteIntoReg KEY, "Date", Date, "REG_SZ"
    WriteIntoReg KEY, "Description", "ArtisonsFi", "REG_SZ"
    WriteIntoReg KEY, "Path", s, "REG_SZ"
err:
End Sub
Private Function WriteIntoReg(ByVal KEY As String, ByVal Value As String, ByVal Data, ByVal DataType As String) As Boolean
Dim WshShell                                           As Object
 
    On Error GoTo WriteIntoReg_Error
 
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.RegWrite KEY & Value, Data, DataType
    WriteIntoReg = True
    On Error GoTo 0
WriteIntoReg_Exit:
    Set WshShell = Nothing
    Exit Function
WriteIntoReg_Error:
    WriteIntoReg = False
    Resume WriteIntoReg_Exit
End Function

Ca marche bien, sauf que ça écrase Location0, donc je ne peux pas utiliser le même script pour deux applis dans deux dossiers différents sur le même poste.

Y a-t-il une astuce pour tester les emplacements approuvés existant ? (faire + 1, je sais faire)

[RobiPMS]

Bonjour.
Personnellement, je me contente d'approuver un emplacement particulier pour chaque appli avec une ligne différente dans le registre : Location10, Location11, etc. Et j'utilise des chiffres plus élevés pour éviter (si possible...) d'écraser des emplacements antérieurement approuvés par d'autres. Et on ne m'a pas rapporté de souci...
Cordialement.

[argyronet]

Le code exemple que j'ai écris est un exemple.

Il est évident que si tu mets (ainsi que le suggère RobiPMS) Location999, tu as de fortes chances à ce que ça marche mais le risque 0 n'existe pas. Imagine que quelqu'un d'autre ait eut la même idée que toi !!!

Il t'appartient d'aller énumérer dans le Regsitre les clefs existantes commençant par l'occurence Location et d'indexer à +1 la dernière trouvée.

Ensuite, tu poses ta valeur est ses paramètres.

Argy

[jff42]

Donc avec ça, l'utilisateur tombe une fois sur le message de sécurité, il autorise, et ensuite ça le dossier de l'appli est en emplacement approuvé.

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
Sub ContrôleEmplacementApprouve()
   Dim WshShell As Object, mondossier As String, cle As String
   Dim key As String
   Dim positionlibre As Integer
   positionlibre = 0
   mondossier = CurrentProject.Path
   On Error Resume Next
   i% = 0
   Const KEYbase As String = "HKCU\Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\Location"
   ' recherche si le dossier est déjà référencé et en même temps de la première place disponible
   Do
      key = KEYbase & i% & "\Path"
      cle = lectureREG(key)
      If cle = "" Then
         ' place libre, on incrémente
         If positionlibre = 0 Then positionlibre = i%
      ElseIf cle = mondossier Then
         'le dossier est déjà référencé, rien à faire
         Exit Sub
      End If
      i% = i% + 1
   Loop While i% < 100
   '
   On Error GoTo err:
      key = KEYbase & positionlibre & "\"
      Set WshShell = CreateObject("WScript.Shell")
      WshShell.RegWrite key & "AllowSubFolders", 0, "REG_DWORD"  '0 = n'autorise pas les sub_folders
      WshShell.RegWrite key & "Date", Date, "REG_SZ"
      WshShell.RegWrite key & "Description", "Export contacts Outlook", "REG_SZ"
      WshShell.RegWrite key & "Path", mondossier, "REG_SZ"
   Exit Sub
err:
   MsgBox err.Description
End Sub
Function lectureREG(key As String) As String
   ' lecture dans le registre
   Dim WshShell As Object
   lectureREG = ""
   On Error Resume Next
   Set WshShell = CreateObject("WScript.Shell")
   lectureREG = WshShell.regread(key)
   'regread plante si la clé n'existe pas, mais pas toujours pareil, donc je retourne seulement un ""
   WshShell.Close
End Function

merci à ceux qui m'ont mis sur la piste.

[argyronet]

Euh, mais tu postes sur combien de threads pour le même sujet ?
Je t'ai répondu ici :
http://www.developpez.net/forums/d98...s/#post6806128

Argy