[VB6] Sécurité, droit d'utilisation ?

**marsup54** · 16/06/2006, 16h57

Bonjour,

La fonction ci dessous stocke sur le poste client certaines informations qui me sont envoyer ensuite en cas de problème.
De cette manière, je peux connaitre la config des utilisateurs et donc mieux corriger les problèmes.

Cela fonctionne bien dans 80 % des config utilisateur/ entreprise, mais dans certain cas, cette fonction tue complètement l'application

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
Public Function CreateInfoConfigLogFile(sFileName As String, sMacAdress As String, sIsModeDebug As String)
    Dim Nc As Integer
    Dim sFile As String
    Dim Nf As Integer
    Dim strComputer As String, iUser As Integer, iGroup As Integer
    Dim colGroups As Object, objGroup As Object, objUser As Object
    Dim sServicePack As String
 
On Error GoTo ErrHandler
 
    'Gestion du fichier log : InfoConfig.log
    If LCase(sModeDebug) = LCase("True") Then
        sFile = app.Path & "\Logs\" & sFileName
        Nf = FreeFile + 1
        Open sFile For Output As #Nf
        'Génération du fichier résultats
        Print #Nf, "Date du jour: " & FormatDateTime(Date, vbLongDate)
        Print #Nf, ""
        Print #Nf, "Numéro de version : " & Global_NumeroVersion & Chr$(9) & "Date de la version : " & Global_DateVersion
        'Print #Nf, "Version de l'OS : " & Environ("OS")
        Print #Nf, "Version de l'OS : " & VersionWindows(sServicePack)
        'Print #Nf, "Version d'Office : " & VersionOffice
        Print #Nf, "Service Pack : " & sServicePack
        Print #Nf, "Résolution : " & ResolutionX & " * " & ResolutionY
        Print #Nf, "Nom du PC : " & Environ("COMPUTERNAME")
        Print #Nf, "Adresse(s) MAC : " & vbTab & sMacAdress
        Print #Nf, "Nom de l'utilisateur : " & Environ("USERNAME")
        Print #Nf, "Nom DNS du Domaine : " & Environ("USERDNSDOMAIN")
        Print #Nf, "Nom du domaine : " & Environ("USERDOMAIN")
        If VersionWindows(sServicePack) <> "98" Or VersionWindows(sServicePack) <> "95" Then
            Print #Nf, "IsAdministrator : " & IsAdministrator
            Print #Nf, "IsNTAdmin : " & CBool(IsNTAdmin(ByVal 0&, ByVal 0&))
        Else
            Print #Nf, "IsAdministrator : Pas de notion d'administrateur sur ce type d'OS"
            Print #Nf, "IsNTAdmin : Pas de notion d'administrateur sur ce type d'OS"
        End If
        Print #Nf, "ConnexionInternetActive : " & ConnexionInternetActive
        Print #Nf, ""
        'Vérification de la version : si Windows 95, version non supportée
        If VersionWindows(sServicePack) = "95" Then
            If MsgBox("Le système d'exploitation de votre poste (Windows 95) ne correspond pas au pré-requis du logiciel" & vbCrLf & _
                    "L'application AltrexChimie risque de ne pas fonctionner correctement." & vbCrLf & _
                    "Voulez-vous tout de même continuer à utiliser le logiciel ?", _
                    vbQuestion + vbYesNo, "Résolution insuffisante") = vbYes Then
                'On continue
            Else
                End
            End If
        End If
        'Affichage des logs
        If VersionWindows(sServicePack) <> "98" Or VersionWindows(sServicePack) <> "95" Then
            Print #Nf, "****************************************************************"
            Print #Nf, "Liste des groupes locaux et utilisateurs"
            strComputer = Environ("COMPUTERNAME")
            Set colGroups = GetObject("WinNT://" & strComputer & "")
            colGroups.Filter = Array("group")
            iGroup = 1
            For Each objGroup In colGroups
                Print #Nf, iGroup & ") Groupe : " & objGroup.name
                iUser = 1
                For Each objUser In objGroup.Members
                    Print #Nf, Chr$(9) & iUser & ") Utilisateur : " & objUser.name
                    iUser = iUser + 1
                Next
                iGroup = iGroup + 1
            Next
            Print #Nf, "****************************************************************"
        End If
        Close #Nf
    End If
 
    Exit Function
ErrHandler:
    'On désactive la gestion des logs
'If Not (GetAttr(MonFichier) And vbReadOnly) = 0 Then
'SetAttr "MonFichier", GetAttr(MonFichier) - 1
    Dim ErrMsg As String
    ErrMsg = "Error Description: " & Err.Description & Chr(10)
    MsgBox "Impossible d'écrire dans le fichier de logs 'InfoConfig.log' !" & Chr(10) _
            & "La gestion des erreurs ne pourra pas être activé" & Chr(10) _
            & ErrMsg, vbCritical, "Gestion des logs impossible !"
    sModeDebug = "False"
    'Paramètre ModeDebug
    Nc = WriteIni("Preferences", "ModeDebug", Trim(sModeDebug), app.Path & "\AltrexChimie.ini")
    Exit Function
End Function

Voici le module pour la MAC Adress :

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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
Option Explicit
 
' Declarations needed for GetAdaptersInfo & GetIfTable
Private Const MIB_IF_TYPE_OTHER                   As Long = 1
Private Const MIB_IF_TYPE_ETHERNET                As Long = 6
Private Const MIB_IF_TYPE_TOKENRING               As Long = 9
Private Const MIB_IF_TYPE_FDDI                    As Long = 15
Private Const MIB_IF_TYPE_PPP                     As Long = 23
Private Const MIB_IF_TYPE_LOOPBACK                As Long = 24
Private Const MIB_IF_TYPE_SLIP                    As Long = 28
 
Private Const MIB_IF_ADMIN_STATUS_UP              As Long = 1
Private Const MIB_IF_ADMIN_STATUS_DOWN            As Long = 2
Private Const MIB_IF_ADMIN_STATUS_TESTING         As Long = 3
 
Private Const MIB_IF_OPER_STATUS_NON_OPERATIONAL  As Long = 0
Private Const MIB_IF_OPER_STATUS_UNREACHABLE      As Long = 1
Private Const MIB_IF_OPER_STATUS_DISCONNECTED     As Long = 2
Private Const MIB_IF_OPER_STATUS_CONNECTING       As Long = 3
Private Const MIB_IF_OPER_STATUS_CONNECTED        As Long = 4
Private Const MIB_IF_OPER_STATUS_OPERATIONAL      As Long = 5
 
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH      As Long = 128
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH_p    As Long = MAX_ADAPTER_DESCRIPTION_LENGTH + 4
Private Const MAX_ADAPTER_NAME_LENGTH             As Long = 256
Private Const MAX_ADAPTER_NAME_LENGTH_p           As Long = MAX_ADAPTER_NAME_LENGTH + 4
Private Const MAX_ADAPTER_ADDRESS_LENGTH          As Long = 8
Private Const DEFAULT_MINIMUM_ENTITIES            As Long = 32
Private Const MAX_HOSTNAME_LEN                    As Long = 128
Private Const MAX_DOMAIN_NAME_LEN                 As Long = 128
Private Const MAX_SCOPE_ID_LEN                    As Long = 256
 
Private Const MAXLEN_IFDESCR                      As Long = 256
Private Const MAX_INTERFACE_NAME_LEN              As Long = MAXLEN_IFDESCR * 2
Private Const MAXLEN_PHYSADDR                     As Long = 8
 
' Information structure returned by GetIfEntry/GetIfTable
Private Type MIB_IFROW
    wszName(0 To MAX_INTERFACE_NAME_LEN - 1) As Byte    ' MSDN Docs say pointer, but it is WCHAR array
    dwIndex             As Long
    dwType              As Long
    dwMtu               As Long
    dwSpeed             As Long
    dwPhysAddrLen       As Long
    bPhysAddr(MAXLEN_PHYSADDR - 1) As Byte
    dwAdminStatus       As Long
    dwOperStatus        As Long
    dwLastChange        As Long
    dwInOctets          As Long
    dwInUcastPkts       As Long
    dwInNUcastPkts      As Long
    dwInDiscards        As Long
    dwInErrors          As Long
    dwInUnknownProtos   As Long
    dwOutOctets         As Long
    dwOutUcastPkts      As Long
    dwOutNUcastPkts     As Long
    dwOutDiscards       As Long
    dwOutErrors         As Long
    dwOutQLen           As Long
    dwDescrLen          As Long
    bDescr As String * MAXLEN_IFDESCR
End Type
 
Private Type TIME_t
    aTime As Long
End Type
 
Private Type IP_ADDRESS_STRING
    IPadrString     As String * 16
End Type
 
Private Type IP_ADDR_STRING
    AdrNext         As Long
    IpAddress       As IP_ADDRESS_STRING
    IpMask          As IP_ADDRESS_STRING
    NTEcontext      As Long
End Type
 
' Information structure returned by GetIfEntry/GetIfTable
Private Type IP_ADAPTER_INFO
    Next As Long
    ComboIndex As Long
    AdapterName         As String * MAX_ADAPTER_NAME_LENGTH_p
    Description         As String * MAX_ADAPTER_DESCRIPTION_LENGTH_p
    MACadrLength        As Long
    MACaddress(0 To MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
    AdapterIndex        As Long
    AdapterType         As Long             ' MSDN Docs say "UInt", but is 4 bytes
    DhcpEnabled         As Long             ' MSDN Docs say "UInt", but is 4 bytes
    CurrentIpAddress    As Long
    IpAddressList       As IP_ADDR_STRING
    GatewayList         As IP_ADDR_STRING
    DhcpServer          As IP_ADDR_STRING
    HaveWins            As Long             ' MSDN Docs say "Bool", but is 4 bytes
    PrimaryWinsServer   As IP_ADDR_STRING
    SecondaryWinsServer As IP_ADDR_STRING
    LeaseObtained       As TIME_t
    LeaseExpires        As TIME_t
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
 
Public Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (ByRef pAdapterInfo As Any, ByRef pOutBufLen As Long) As Long
Public Declare Function GetNumberOfInterfaces Lib "iphlpapi.dll" (ByRef pdwNumIf As Long) As Long
Public Declare Function GetIfEntry Lib "iphlpapi.dll" (ByRef pIfRow As Any) As Long
Private Declare Function GetIfTable Lib "iphlpapi.dll" _
        (ByRef pIfTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
 
'-----------------------------------------------------------------------------------
' Get the system's MAC address(es) via GetAdaptersInfo API function (IPHLPAPI.DLL)
'
' Note: GetAdaptersInfo returns information about physical adapters
'-----------------------------------------------------------------------------------
Public Function GetMACs_AdaptInfo() As String
    Dim AdapInfo As IP_ADAPTER_INFO, bufLen As Long, sts As Long
    Dim retStr As String, numStructs%, i%, IPinfoBuf() As Byte, srcPtr As Long
 
On Error GoTo ErrHandler
    ' Get size of buffer to allocate
    sts = GetAdaptersInfo(AdapInfo, bufLen)
    If (bufLen = 0) Then Exit Function
    numStructs = bufLen / Len(AdapInfo)
    'retStr = numStructs & " Adapter(s):" & vbCrLf
    retStr = ""
 
    ' reserve byte buffer & get it filled with adapter information
    ' !!! Don't Redim AdapInfo array of IP_ADAPTER_INFO,
    ' !!! because VB doesn't allocate it contiguous (padding/alignment)
    ReDim IPinfoBuf(0 To bufLen - 1) As Byte
    sts = GetAdaptersInfo(IPinfoBuf(0), bufLen)
    If (sts <> 0) Then Exit Function
 
    ' Copy IP_ADAPTER_INFO slices into UDT structure
    srcPtr = VarPtr(IPinfoBuf(0))
    For i = 0 To numStructs - 1
        If (srcPtr = 0) Then Exit For
'        CopyMemory AdapInfo, srcPtr, Len(AdapInfo)
        CopyMemory AdapInfo, ByVal srcPtr, Len(AdapInfo)
 
        ' Extract Ethernet MAC address
        With AdapInfo
            If (.AdapterType = MIB_IF_TYPE_ETHERNET) Then
                'retStr = retStr & vbCrLf & "[" & i & "] " & sz2string(.Description) _
                '        & vbCrLf & vbTab & MAC2String(.MACaddress) & vbCrLf
                If i = 0 Then
                    retStr = "[" & i & "] : " & MAC2String(.MACaddress)
                Else
                    retStr = retStr & " | " & "[" & i & "] : " & MAC2String(.MACaddress)
                End If
            End If
        End With
        srcPtr = AdapInfo.Next
    Next i
 
    ' Return list of MAC address(es)
    GetMACs_AdaptInfo = retStr
    Exit Function
ErrHandler:
    GetMACs_AdaptInfo = "NC"
    Exit Function
End Function
 
'-----------------------------------------------------------------------------------
' Get the system's MAC address(es) via GetIfTable API function (IPHLPAPI.DLL)
'
' Note: GetIfTable returns information also about the virtual loopback adapter
'-----------------------------------------------------------------------------------
Public Function GetMACs_IfTable() As String
    Dim NumAdapts As Long, nRowSize As Long, i%, retStr As String
    Dim IfInfo As MIB_IFROW, IPinfoBuf() As Byte, bufLen As Long, sts As Long
 
On Error GoTo ErrHandler
    ' Get # of interfaces defined (sometimes 1 more than GetIfTable)
    sts = GetNumberOfInterfaces(NumAdapts)
 
    ' Get size of buffer to allocate
    sts = GetIfTable(ByVal 0&, bufLen, 1)
    If (bufLen = 0) Then Exit Function
 
    ' reserve byte buffer & get it filled with adapter information
    ReDim IPinfoBuf(0 To bufLen - 1) As Byte
    sts = GetIfTable(IPinfoBuf(0), bufLen, 1)
    If (sts <> 0) Then Exit Function
 
    NumAdapts = IPinfoBuf(0)
    nRowSize = Len(IfInfo)
    retStr = NumAdapts & " Interface(s):" & vbCrLf
 
    For i = 1 To NumAdapts
        ' copy one IfRow chunk of byte data into an MIB_IFROW structure
        Call CopyMemory(IfInfo, IPinfoBuf(4 + (i - 1) * nRowSize), nRowSize)
 
        ' Take adapter address if correct type
        With IfInfo
            retStr = retStr & vbCrLf & "[" & i & "] " & left$(.bDescr, .dwDescrLen - 1) & vbCrLf
            If (.dwType = MIB_IF_TYPE_ETHERNET) Then
                retStr = retStr & vbTab & MAC2String(.bPhysAddr) & vbCrLf
            End If
        End With
    Next i
 
    GetMACs_IfTable = retStr
    Exit Function
ErrHandler:
    GetMACs_IfTable = "NC"
    Exit Function
 
End Function
 
' Convert a byte array containing a MAC address to a hex string
Private Function MAC2String(AdrArray() As Byte) As String
    Dim aStr As String, hexStr As String, i%
 
    For i = 0 To 5
        If (i > UBound(AdrArray)) Then
            hexStr = "00"
        Else
            hexStr = Hex$(AdrArray(i))
        End If
 
        If (Len(hexStr) < 2) Then hexStr = "0" & hexStr
        aStr = aStr & hexStr
        If (i < 5) Then aStr = aStr & "-"
    Next i
 
    MAC2String = aStr
 
End Function
 
' Convert a zero-terminated fixed string to a dynamic VB string
Private Function sz2string(ByVal szStr As String) As String
    sz2string = left$(szStr, InStr(1, szStr, Chr$(0)) - 1)
End Function

Le problème vient-il d'une histoire de droit sur les répertoire, ...

Bref, merci d'avance pour votre aide

++

**marsup54** · 16/06/2006, 17h25

Je viens de me dire que pour des très grosses sociétés, la recherche des groupes et des utilisateurs locaux n'est peut-être pas judicieuse ...

C'est sûrement cela le problème. A vérifier toutefois.

++

EDIT :
Le problème ne vient apparemment pas des groupes locaux !
J'ai une piste cependant :

Les personnes chez qui cela plante ont des W2000 version Multilangue avec anglais de base.
Est-ce que les variables d'environnements ci dessus fonctionne dans ce cas là ?
Merci d'avance pour votre aide.

[VB6] Sécurité, droit d'utilisation ?

VB 6 et antérieur

Discussions similaires

Partager

Partager