Discussion :

[macgiver1970]

Bonjour, je cherche une solution pour trouver l'adresse IP du poste sur lequel s'éxécute une application access.
En fait je voudrai me servir de cette adresse pour sécuriser mon application . Je travaille dans une entreprise avec un réseau intranet : si les 6 premiers chiffres de l'adresse IP sont pas bon, je ferme automatiquement l'application.
Qu'en pensez-vous ? (le but étant simplement d'empécher le fonctionnement de l'application en dehors de l'enreprise)

PS : vous l'avez compris : je débute ....

[francishop]

Bonsoir et Bienvenue,

Regarde ce bel outil--> http://access.developpez.com/faq/?page=API#ip

Cordialement.

[francishop]

Bonsoir,

Ha lala. On ne peut plus dormir tranquille. Et vlan, des MP. On se demande pourquoi on inscrit en accolade de sa signature des messages d'informations sur notre désir d'éviter ce genre d'intrusion. Il est pourtant simple sur le forum de laisser un nouveau message indiquant : J'ai fais ça et j'en suis là... Je "coince" à cet endroit. A partir de ce moment on prend plaisir à répondre voyant l'évolution du demandeur. Alors que là, on ne fait que répondre sans indice du besoin; Sans pouvoir véritablement aider. On informe..On communique.. C'est tout.

Bon, maintenant que j'y suis...

Pour ce qui est des adresses IP je préfère dans un formulaire deux champs :
txtIPLocale---->Source-->=IPLocale()
txtIPInternet-->Source-->=MonIpInternet()

Et voilà.

Comment, Il manque quelque chose? Ah oui. Un peu de code :
Dans un module qu'on peut baptiser ModIpLocale:

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
Option Compare Database
Option Explicit
 
Private Const MAX_ADAPTER_NAME_LENGTH         As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH  As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH      As Long = 8
Private Const ERROR_SUCCESS  As Long = 0
 
Private Type IP_ADDRESS_STRING
    IpAddr(0 To 15)  As Byte
End Type
 
Private Type IP_MASK_STRING
    IpMask(0 To 15)  As Byte
End Type
 
Private Type IP_ADDR_STRING
    dwNext     As Long
    IpAddress  As IP_ADDRESS_STRING
    IpMask     As IP_MASK_STRING
    dwContext  As Long
End Type
 
Private Type IP_ADAPTER_INFO
  dwNext                As Long
  ComboIndex            As Long  'réservé
  sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
  sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
  dwAddressLength       As Long
  sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
  dwIndex               As Long
  uType                 As Long
  uDhcpEnabled          As Long
  CurrentIpAddress      As Long
  IpAddressList         As IP_ADDR_STRING
  GatewayList           As IP_ADDR_STRING
  DhcpServer            As IP_ADDR_STRING
  bHaveWins             As Long
  PrimaryWinsServer     As IP_ADDR_STRING
  SecondaryWinsServer   As IP_ADDR_STRING
  LeaseObtained         As Long
  LeaseExpires          As Long
End Type
 
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
  (pTcpTable As Any, _
   pdwSize As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (dst As Any, _
   src As Any, _
   ByVal bcount As Long)
 
 
Public Function IPLocale() As String
 
  'api vars
   Dim cbRequired  As Long
   Dim buff()      As Byte
   Dim Adapter     As IP_ADAPTER_INFO
   Dim AdapterStr  As IP_ADDR_STRING
 
  'working vars
   Dim ptr1        As Long
   Dim ptr2        As Long
   Dim sIPAddr     As String
   Dim found       As Boolean
 
   Call GetAdaptersInfo(ByVal 0&, cbRequired)
 
   If cbRequired > 0 Then
 
      ReDim buff(0 To cbRequired - 1) As Byte
 
      If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
 
        'obtenez un indicateur des données stockées
         ptr1 = VarPtr(buff(0))
 
         Do While (ptr1 <> 0) And (found = False)
 
           'copie les données de l'indicateur au
           ' premier adapteur dans le type d'IP_ADAPTER_INFO
            CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
 
            With Adapter
 
               If .uDhcpEnabled Then
 
                 'l'information de DHCP est dans le DhcpServer
                 'membre d'IP_ADAPTER_INFO. C'est
                 'dans le format d'IP_ADDR_STRING, ainsi
                 'il doit être copié au
                 'Type d'IP_ADDR_STRING
                  ptr2 = VarPtr(.DhcpServer)
 
                 'encore, le type d'IP_ADDR_STRING a
                 'membre de dwNext, indiquant que plus
                 'qu'un serveur de DHCP peut être énuméré,
                 'une autre boucle est nécessaire
                  Do While (ptr2 <> 0)
 
                     CopyMemory AdapterStr, ByVal ptr2, LenB(AdapterStr)
 
                     With AdapterStr
 
                       'l'IP address du DHCP
                       'serveur pour cet adapteur.
                        sIPAddr = TrimNull(StrConv(.IpAddress.IpAddr, vbUnicode))
 
                       'si quelque chose est retourné, sortez de la boucle
                        If Len(sIPAddr) > 0 Then
                           found = True
                           Exit Do
                        End If
 
                       'vérifiez un autre serveur
                        ptr2 = .dwNext
 
                     End With  'Avec AdapterStr
                  Loop  'Do While (ptr2 <> 0)
 
                 'vérifiez un autre adapteur
                  ptr1 = .dwNext
 
               End If  'If .uDhcpEnabled
 
            End With  'With Adapter
 
        'ptr1 est à 0 quand (plus d'adapteur)
         Loop  'Do While (ptr1 <> 0)
 
      End If  'If GetAdaptersInfo
   End If  'If cbRequired > 0
 
  'renvoyer la chaîne trouvée
   IPLocale = sIPAddr
 
End Function
 
 
Private Function TrimNull(item As String)
 
    Dim pos As Integer
 
   'vérifions une deuxième fois qu'il y a des chr$ (0) dans la chaîne
    pos = InStr(item, Chr$(0))
    If pos Then
          TrimNull = Left$(item, pos - 1)
    Else: TrimNull = item
    End If
 
End Function

Un autre module-->ModIpInternet :

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
Option Compare Database
Option Explicit
 
Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Public Const INTERNET_OPEN_TYPE_DIRECT = 1
Public Const INTERNET_OPEN_TYPE_PROXY = 3
 
Public Const scUserAgent = "VB OpenUrl"
Public Const INTERNET_FLAG_RELOAD = &H80000000
 
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
 
Public Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
(ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, _
ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
 
Public Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
 
Public Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
 
Private Declare Function URLDownloadToFile Lib "urlmon" _
   Alias "URLDownloadToFileA" _
  (ByVal pCaller As Long, _
   ByVal szURL As String, _
   ByVal szFileName As String, _
   ByVal dwReserved As Long, _
   ByVal lpfnCB As Long) As Long
 
Public Declare Function InternetGetConnectedState _
              Lib "wininet.dll" (ByRef lpdwFlags As Long, _
              ByVal dwReserved As Long) As Long
 
Private Const ERROR_SUCCESS As Long = 0
 
Public Function GetHTMLFromURL(sUrl As String) As String
Dim S                  As String
Dim hOpen              As Long
Dim hOpenUrl           As Long
Dim bDoLoop            As Boolean
Dim bRet               As Boolean
Dim sReadBuffer        As String * 2048
Dim lNumberOfBytesRead As Long
 
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
 
bDoLoop = True
 
While bDoLoop
    sReadBuffer = vbNullString
    bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
    S = S & Left$(sReadBuffer, lNumberOfBytesRead)
    If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
 
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
 
GetHTMLFromURL = S
 
End Function
 
Public Function IsConnected() As Boolean
 
    On Error GoTo err
    IsConnected = InternetGetConnectedState(0&, 0&)
 
Exit Function
 
err:
    IsConnected = True
 
End Function
 
 
Public Function MonIpInternet() As String
Dim strHTML        As String
Dim StringPosition As Long
Dim FindString     As String
 
If IsConnected = False Then
   MsgBox "Vous devez être connecté à Internet pour récupérer votre adress IP.", vbInformation, "FH Adresse IP"
End If
 
strHTML = GetHTMLFromURL("http://www.showip.com")
FindString = "Your IP address is <b><big><big>"
 
StringPosition = InStr(1, strHTML, _
                 FindString, vbTextCompare)
MonIpInternet = Left(Mid(strHTML, StringPosition + Len(FindString)), 13)
 
End Function

Cordialement.

[Ric500]

Bonjour,

Une autre méthode passant par l'utilisation d'une clé de licence ici.