Création d'un fichier xml ineffacable

**pijaku** · 26/10/2017, 17h37

Bonjour,

Je souhaite créer, via VBA, un fichier de sauvegarde de type xml.
Je souhaite pouvoir lire et écrire dans ce fichier à volonté.
Jusqu'ici, tout va bien, je sais faire.

Par contre, je voudrais que personne, y compris l'utilisateur/créateur, ne puisse effacer, de son répertoire, ce fichier involontairement et surtout volontairement !

Si cela est impossible, quel conseil pourriez-vous me donner pour une sauvegarde fiable ?
Un envoi à chaque modification sur un site ftp ?
Un envoi à chaque modification par email sur une boîte réservée à cet effet ?
Autre ?

Merci par avance de toute réponse permettant de faire avancer mon Schmilblick.

**Marc-L** · 26/10/2017, 17h56

Salut !

Le cacher via l'attribut de fichier ?
En créer un double à un endroit particulier ou te l'envoyer directement par mail.
Sinon ce serait jouable via les autorisations, à tester mais faudrait-il encore un utilisateur non administrateur …

___________________________________________________________________________________________________________

Je suis Paris, Mogadicio, Barcelone, London, Manchester, Egypte, Stockholm, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

**unparia** · 26/10/2017, 18h01

Bonjour Franck
Peut-être ainsi ? -->>
https://www.developpez.net/forums/d1...ssier-fichier/

**pijaku** · 26/10/2017, 20h40

Salut Marc et Jacques,
Merci.
Ok. Donc, au niveau developpeur, il n'y a pas énormément de choix pour assurer une sauvegarde fiable.
Et par conséquent, ce choix, cette décision, incombe à l'utilisateur.
En restant ouvert à toutes propositions, je vous remercie et vous souhaite une bonne soirée.

**patricktoulon** · 26/10/2017, 23h35

bonjour franck

oui moi aussi je ne vois que ca
une copie de sauvegarde que tu recopie et colle si il est inexistant(au cas ou un malin l'aurait viré)

autrement dans la macro qui te sert a ouvrir et modifier et sauver tu l'enregistre 2 fois dont une fois en attrubut caché
et pour l'ouverture mettre un test de la présence avec dir si non present copie du caché a l'endroit ou il doit être en attribut non caché
reste a protéger le code vba par MDP

**pijaku** · 09/11/2017, 08h08

Bonjour tout le monde,

Je ne laisse pas tomber ce sujet, mais suis toujours en attente de réponses de la part du "client'".

J'ai trouvé, sur le net, un code VB6 qui permet de gérer la sécurité NTFS comme le suggère Jacques.
A grand renfort de fonctions de l'api, c'est assez imparable.

Je vous le communique pour info et pour d'autres éventuels forumeurs.
Tout d'abord, le lien vers la discussion source : https://www.experts-exchange.com/que...suing-VB6.html

Le code de la Sub principale et des fonctions : (Jacques : ne rit pas de mon Espagnol stp. Ce sera traduit par un vrai bilingue)

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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
Public Const DELETE = 65536
Public Const GENERIC_READ = -2147483648#
Public Const GENERIC_ALL = 268435456
Public Const GENERIC_EXECUTE = 536870912
Public Const GENERIC_WRITE = 1073741824
 
Private Const ACL_INFO = 4
Private Const SD_REV = 1
Private Const OBJECT_INHERIT_ACE = 1
Private Const CONTAINER_INHERIT_ACE = 2
Private Const INHERIT_ONLY_ACE = 8
Private Const ACL_REV = 2
Private Const MAXDWORD = -1
 
Private Const MSG_UN_USER As String = "Error:" & vbCrLf & "no se puede buscar la cuenta de usuario : "
Private Const MSG_UN_FSD As String = "Error:" & vbCrLf & "no se puede obtener el descriptor de seguridad de archivos"
Private Const MSG_UN_NSD As String = "Error:" & vbCrLf & "no se puede inicializar el nuevo descriptor de seguridad"
Private Const MSG_UN_DACL As String = "Error:" & vbCrLf & "no se puede obtener una lista de control de acceso discrecional" & vbCrLf & "desde el descriptor de seguridad de archivos"
Private Const MSG_NO_ACLINFOS As String = "Error: " & vbCrLf & "ninguna lista de control de acceso información disponible" & vbCrLf & "para este archivo"
Private Const MSG_UN_ACL As String = "Error:" & vbCrLf & "no se puede obtener la lista de control de acceso" & vbCrLf & "del descriptor de seguridad de archivos"
Private Const MSG_UN_NEWACL As String = "Error:" & vbCrLf & "no se puede inicializar una nueva lista de control de acceso"
Private Const MSG_UN_GETACE As String = "Error:" & vbCrLf & "no se puede obtener la entrada de control de acceso ("
Private Const MSG_UN_ADDACE As String = "Error:" & vbCrLf & "no se puede agregar la entrada de control de acceso" & vbCrLf & "a la nueva lista de control de acceso"
Private Const MSG_UN_ADDACL As String = "Error:" & vbCrLf & "no se puede agregar  la nueva lista de control de acceso" & vbCrLf & "a la lista de control de acceso discrecional"
Private Const MSG_UN_SETDACL As String = "Error:" & vbCrLf & "no se puede establecer una nueva lista de control de acceso discrecional" & vbCrLf & "en el descriptor de seguridad"
Private Const MSG_UN_SETNSD As String = "Error:" & vbCrLf & "no se puede establecer el nuevo descriptor de seguridad en el archivo : "
Private Const MSG_RESULT_OK As String = "Descriptor de seguridad actualizado en el archivo : "
 
Private Type ACE_HEADER
   AceType As Byte
   AceFlags As Byte
   AceSize As Integer
End Type
 
Private Type ACL_SIZE_INFORMATION
   AceCount As Long
   AclBytesInUse As Long
   AclBytesFree As Long
End Type
 
Private Type ACCESS_ALLOWED_ACE
   Header As ACE_HEADER
   Mask As Long
   SidStart As Long
End Type
 
Private Type ACL
   AclRevision As Byte
   Sbz1 As Byte
   AclSize As Integer
   AceCount As Integer
   Sbz2 As Integer
End Type
 
Private Type SECURITY_DESCRIPTOR
   Revision As Byte
   Sbz1 As Byte
   Control As Long
   Owner As Long
   Group As Long
   sACL As ACL
   Dacl As ACL
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function LookupAccountName Lib "advapi32.dll" Alias "LookupAccountNameA" (lpSystemName As String, ByVal lpAccountName As String, sid As Any, cbSid As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
Private Declare Function GetFileSecurity Lib "advapi32.dll" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, ByVal nLength As Long, lpnLengthNeeded As Long) As Long
Private Declare Function GetFileSecurityN Lib "advapi32.dll" Alias "GetFileSecurityA" (ByVal lpFileName As String, ByVal RequestedInformation As Long, ByVal pSecurityDescriptor As Long, ByVal nLength As Long, lpnLengthNeeded As Long) As Long
Private Declare Function GetAclInformation Lib "advapi32.dll" (ByVal pAcl As Long, pAclInformation As Any, ByVal nAclInformationLength As Long, ByVal dwAclInformationClass As Long) As Long
Private Declare Function GetSecurityDescriptorDacl Lib "advapi32.dll" (pSecurityDescriptor As Byte, lpbDaclPresent As Long, pDacl As Long, lpbDaclDefaulted As Long) As Long
Private Declare Function GetAce Lib "advapi32.dll" (ByVal pAcl As Long, ByVal dwAceIndex As Long, pAce As Any) As Long
Private Declare Function EqualSid Lib "advapi32.dll" (pSid1 As Byte, ByVal pSid2 As Long) As Long
Private Declare Function AddAce Lib "advapi32.dll" (ByVal pAcl As Long, ByVal dwAceRevision As Long, ByVal dwStartingAceIndex As Long, ByVal pAceList As Long, ByVal nAceListLength As Long) As Long
Private Declare Function AddAccessAllowedAce Lib "advapi32.dll" (pAcl As Byte, ByVal dwAceRevision As Long, ByVal AccessMask As Long, pSid As Byte) As Long
Private Declare Function InitializeSecurityDescriptor Lib "advapi32.dll" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal dwRevision As Long) As Long
Private Declare Function GetLengthSid Lib "advapi32.dll" (pSid As Any) As Long
Private Declare Function InitializeAcl Lib "advapi32.dll" (pAcl As Byte, ByVal nAclLength As Long, ByVal dwAclRevision As Long) As Long
Private Declare Function SetSecurityDescriptorDacl Lib "advapi32.dll" (pSecurityDescriptor As SECURITY_DESCRIPTOR, ByVal bDaclPresent As Long, pDacl As Byte, ByVal bDaclDefaulted As Long) As Long
Private Declare Function SetFileSecurity Lib "advapi32.dll" Alias "SetFileSecurityA" (ByVal lpFileName As String, ByVal SecurityInformation As Long, pSecurityDescriptor As SECURITY_DESCRIPTOR) As Long
 
Public Sub DarAcceso(Nom As String, NomFic As String, Mask As Long)
Dim SD As SECURITY_DESCRIPTOR, AclI As ACL_SIZE_INFORMATION, Courant As ACCESS_ALLOWED_ACE
Dim Temp As Long, Dnl As Long, SidT As Long, Siz As Long, Pres As Long
Dim Def As Long, pAcl As Long, cAce As Long, cpt As Long, Msg As String
Dim NomDom As String, i As Integer, Usid(255) As Byte, SDsiz() As Byte, bAcl() As Byte
 
    If GetSidUser(Nom, Usid, NomDom, Dnl, SidT) = 0 Then Msg = MSG_UN_USER & Nom: GoTo Fin
    If GetFS(NomFic, Siz, SDsiz) = 0 Then Msg = MSG_UN_FSD: GoTo Fin
    If InitializeSecurityDescriptor(SD, SD_REV) = 0 Then Msg = MSG_UN_NSD: GoTo Fin
    If GetSecurityDescriptorDacl(SDsiz(0), Pres, pAcl, Def) = 0 Then Msg = MSG_UN_DACL: GoTo Fin
    If Pres = False Then Msg = MSG_NO_ACLINFOS: GoTo Fin
    If GetAclInformation(pAcl, AclI, Len(AclI), 2&) = 0 Then Msg = MSG_UN_ACL: GoTo Fin
    If InitACL(Courant, Usid, bAcl, AclI) = 0 Then Msg = MSG_UN_NEWACL: GoTo Fin
    If AclI.AceCount > 0 Then
        cpt = 0
        For i = 0 To AclI.AceCount - 1
            If GetAce(pAcl, i, cAce) = 0 Then MsgBox MSG_UN_GETACE & i & ")": GoTo Fin
            CopyMemory Courant, cAce, LenB(Courant)
            Temp = cAce + 8
            If EqualSid(Usid(0), Temp) = 0 Then
                If AddAce(VarPtr(bAcl(0)), ACL_REV, MAXDWORD, cAce, Courant.Header.AceSize) = 0 Then MsgBox MSG_UN_ADDACE: GoTo Fin
                cpt = cpt + 1
            End If
        Next i
        If AddAccessAllowedAce(bAcl(0), ACL_REV, Mask, Usid(0)) = 0 Then MsgBox MSG_UN_ADDACL: GoTo Fin
        If GetAttr(NomFic) And vbDirectory Then
            If GetAce(VarPtr(bAcl(0)), cpt, cAce) = 0 Then MsgBox MSG_UN_GETACE & i & ")": GoTo Fin
            PlaceIntoStruct Courant, cAce, OBJECT_INHERIT_ACE + INHERIT_ONLY_ACE
            If AddAccessAllowedAce(bAcl(0), ACL_REV, Mask, Usid(0)) = 0 Then MsgBox MSG_UN_ADDACL: GoTo Fin
            If GetAce(VarPtr(bAcl(0)), cpt + 1, cAce) = 0 Then MsgBox MSG_UN_GETACE & i & ")"
            PlaceIntoStruct Courant, cAce, CONTAINER_INHERIT_ACE
        End If
        If SetSecurityDescriptorDacl(SD, 1, bAcl(0), 0) = 0 Then MsgBox MSG_UN_SETDACL: GoTo Fin
        If SetFileSecurity(NomFic, ACL_INFO, SD) = 0 Then MsgBox MSG_UN_SETNSD & NomFic: GoTo Fin
    End If
    Msg = MSG_RESULT_OK & NomFic
Fin:
    MsgBox Msg
End Sub
 
Private Function GetSidUser(N As String, U() As Byte, ND As String, D As Long, S As Long) As Long
    GetSidUser = LookupAccountName(vbNullString, N, U(0), 255, ND, D, S)
    ND = Space(D)
    GetSidUser = LookupAccountName(vbNullString, N, U(0), 255, ND, D, S)
End Function
 
Private Function GetFS(NF As String, S As Long, SD() As Byte) As Long
    GetFS = GetFileSecurityN(NF, ACL_INFO, 0, 0, S)
    ReDim SD(S)
    GetFS = GetFileSecurity(NF, ACL_INFO, SD(0), S, S)
End Function
 
Private Function InitACL(C As ACCESS_ALLOWED_ACE, U() As Byte, B() As Byte, A As ACL_SIZE_INFORMATION) As Long
Dim S As Long
    S = A.AclBytesInUse + (Len(C) + GetLengthSid(U(0))) * 2 - 4
    ReDim B(S)
    InitACL = InitializeAcl(B(0), S, ACL_REV)
End Function
 
Private Sub PlaceIntoStruct(C As ACCESS_ALLOWED_ACE, A As Long, F As Byte)
    CopyMemory C, A, LenB(C)
    C.Header.AceFlags = F
    CopyMemory ByVal A, VarPtr(C), LenB(C)
End Sub

Un exemple d'appel pour un fichier :

Code :

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

1
2
3
Sub test_fichier()
    DarAcceso Environ("UserName"), ThisWorkbook.FullName, GENERIC_ALL
End Sub

Exemple d'appel pour un répertoire :

Code :

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

1
2
3
Sub test_repertoire()
    DarAcceso Environ("UserName"), "N:\Communs\Users\" & Environ("UserName") & "\Documents\Travaux en cours", GENERIC_READ
End Sub

J'ai bien intégré le principe (même si je me documente encore sur l'action de CopyMemory), testé, cela semble bien fonctionner dans l'état.
Me reste encore une question relative à ce projet, mais ce sera du côté conception.

Bonne journée.

ps : Je mettrais en résolu après vos éventuelles réponses/remarques et dès le retour de mon "client".

Création d'un fichier xml ineffacable

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager