Auteur : Tofalu
| Version : 09/10/2005 | | |
| |
Versions : Toutes
Le module suivant permet de connecter et déconnecter un lecteur réseau.
La fonction ConnecterLecteur reçoit comme paramètres :
- strChemin : Chemin réseau du lecteur ("\\monpc\NomPartage")
- strLettre : Lettre à affecter au lecteur ("z:")
- strUtilisateur : Facultatif. Nom de l'utilisateur.
- strMotDePasse : Facultatif. Mot de passe de l'utilisateur.
La fonction DeconnecterLecteur reçoit comme paramètres :
- strLettre : Lettre du lecteur à déconnecter ("z:").
- bolForce : Facultatif (par défaut : False) .
Si la valeur de ce paramètre est égale à True, la déconnexion sera forcée même si un fichier est ouvert.
Les fonctions retournent True en cas de succès, False en cas d'échec.
Code du module :
Option Compare Database
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias _
"WNetAddConnection2A" (lpNetResource As NETRESOURCE, _
ByVal lpPassword As String, ByVal lpUserName As String, _
ByVal dwFlags As Long) As Long
Private Declare Function WNetCancelConnection Lib "mpr.dll" Alias _
"WNetCancelConnectionA" (ByVal lpszName As String, _
ByVal bForce As Long) As Long
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type
Public Function ConnecterLecteur(strChemin As String, strLettre As String, _
Optional strUtilisateur As String, Optional strMotDePasse As String) As Boolean
Dim RessourceReseau As NETRESOURCE
With RessourceReseau
.lpRemoteName = strChemin
.lpLocalName = strLettre
.dwType = RESOURCETYPE_DISK
End With
ConnecterLecteur = WNetAddConnection2(RessourceReseau, strMotDePasse, strUtilisateur, 0) = 0
End Function
Public Function DeconnecterLecteur(strLettre As String, _
Optional bolForce As Boolean = False) As Boolean
DeconnecterLecteurReseau = WNetCancelConnection(strLettre, IIf(bolForce, 1, 0)) = 0
End Function |
Exemple de connexion :
Sub test()
ConnecterLecteur "\\Secretariat01\DonneesPartagees", "z:", "secretaire", "secè[@po1"
End Sub |
Exemple de déconnexion :
Sub test()
DeconnecterLecteur "z:"
End Sub |
|
| |
Version : Access 97 et supérieures
Cet exemple de code permet de pinger une machine du réseau et d'afficher les informations
retournées.
Dans un module, placez le code suivant :
Option Compare Database
Option Explicit
Private Const IP_STATUS_BASE As Long = 11000
Private Const IP_SUCCESS As Long = 0
Private Const IP_BUF_TOO_SMALL As Long = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE As Long = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE As Long = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE As Long = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE As Long = (11000 + 5)
Private Const IP_NO_RESOURCES As Long = (11000 + 6)
Private Const IP_BAD_OPTION As Long = (11000 + 7)
Private Const IP_HW_ERROR As Long = (11000 + 8)
Private Const IP_PACKET_TOO_BIG As Long = (11000 + 9)
Private Const IP_REQ_TIMED_OUT As Long = (11000 + 10)
Private Const IP_BAD_REQ As Long = (11000 + 11)
Private Const IP_BAD_ROUTE As Long = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT As Long = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM As Long = (11000 + 14)
Private Const IP_PARAM_PROBLEM As Long = (11000 + 15)
Private Const IP_SOURCE_QUENCH As Long = (11000 + 16)
Private Const IP_OPTION_TOO_BIG As Long = (11000 + 17)
Private Const IP_BAD_DESTINATION As Long = (11000 + 18)
Private Const IP_ADDR_DELETED As Long = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE As Long = (11000 + 20)
Private Const IP_MTU_CHANGE As Long = (11000 + 21)
Private Const IP_UNLOAD As Long = (11000 + 22)
Private Const IP_ADDR_ADDED As Long = (11000 + 23)
Private Const IP_GENERAL_FAILURE As Long = (11000 + 50)
Private Const MAX_IP_STATUS As Long = (11000 + 50)
Private Const IP_PENDING As Long = (11000 + 255)
Private Const PING_TIMEOUT As Long = 500
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Type ICMP_OPTIONS
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address As Long
status As Long
RoundTripTime As Long
DataSize As Long
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Declare Function gethostbyname Lib "wsock32" _
(ByVal hostname As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Private Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Private Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32" () As Long
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
Private Declare Function inet_addr Lib "wsock32" _
(ByVal s As String) As Long
Public Function Ping(sAddress As String, _
sDataToSend As String, _
ECHO As ICMP_ECHO_REPLY) As Long
Dim hPort As Long
Dim dwAddress As Long
dwAddress = inet_addr(sAddress)
If dwAddress <> INADDR_NONE Then
hPort = IcmpCreateFile()
If hPort Then
Call IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
0, _
ECHO, _
Len(ECHO), _
PING_TIMEOUT)
Ping = ECHO.status
Call IcmpCloseHandle(hPort)
End If
Else:
Ping = INADDR_NONE
End If
End Function
Public Function GetStatusCode(status As Long) As String
Dim msg As String
Select Case status
Case IP_SUCCESS: msg = "ip success"
Case INADDR_NONE: msg = "inet_addr: bad IP format"
Case IP_BUF_TOO_SMALL: msg = "ip buf too_small"
Case IP_DEST_NET_UNREACHABLE: msg = "ip dest net unreachable"
Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
Case IP_NO_RESOURCES: msg = "ip no resources"
Case IP_BAD_OPTION: msg = "ip bad option"
Case IP_HW_ERROR: msg = "ip hw_error"
Case IP_PACKET_TOO_BIG: msg = "ip packet too_big"
Case IP_REQ_TIMED_OUT: msg = "ip req timed out"
Case IP_BAD_REQ: msg = "ip bad req"
Case IP_BAD_ROUTE: msg = "ip bad route"
Case IP_TTL_EXPIRED_TRANSIT: msg = "ip ttl expired transit"
Case IP_TTL_EXPIRED_REASSEM: msg = "ip ttl expired reassem"
Case IP_PARAM_PROBLEM: msg = "ip param_problem"
Case IP_SOURCE_QUENCH: msg = "ip source quench"
Case IP_OPTION_TOO_BIG: msg = "ip option too_big"
Case IP_BAD_DESTINATION: msg = "ip bad destination"
Case IP_ADDR_DELETED: msg = "ip addr deleted"
Case IP_SPEC_MTU_CHANGE: msg = "ip spec mtu change"
Case IP_MTU_CHANGE: msg = "ip mtu_change"
Case IP_UNLOAD: msg = "ip unload"
Case IP_ADDR_ADDED: msg = "ip addr added"
Case IP_GENERAL_FAILURE: msg = "ip general failure"
Case IP_PENDING: msg = "ip pending"
Case PING_TIMEOUT: msg = "ping timeout"
Case Else: msg = "unknown msg returned"
End Select
GetStatusCode = CStr(status) & " [ " & msg & " ]"
End Function
Public Function GetIPFromHostName(ByVal sHostName As String) As String
Dim nbytes As Long
Dim ptrHosent As Long
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String
sAddress = Space$(4)
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
ptrName = ptrHosent
ptrAddress = ptrHosent + 12
CopyMemory ptrName, ByVal ptrName, 4
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = IPToText(sAddress)
End If
End Function
Public Function IPToText(ByVal IPAddress As String) As String
IPToText = CStr(Asc(IPAddress)) & "." & _
CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function
Public Function ConvertIp(Ip As Long)
Dim i As Integer
Dim strTemp As String
strTemp = Format(Hex(Ip), "00000000")
For i = 7 To 1 Step -2
ConvertIp = ConvertIp & ConvertHexToDec(Mid(strTemp, i, 2)) & "."
Next i
ConvertIp = Left(ConvertIp, Len(ConvertIp) - 1)
End Function
Private Function ConvertHexToDec(N As String) As String
ConvertHexToDec = Format(CLng("&H" & N), "000")
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Erreur lors du nettoyage du socket.", vbCritical
End If
End Sub
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function |
Ensuite, vous pouvez créer une interface ressemblant à ceci :
Il suffit alors de placer le code suivant dans l'évènement Clic du bouton.
Dim ECHO As ICMP_ECHO_REPLY
Dim pos As Long
Dim success As Long
Dim sIPAddress As String
If Nz(txtHote, "") = "" And Nz(txtIPSend, "") = "" Then
MsgBox "Veuillez spécifié une destination"
Else
If SocketsInitialize() Then
If Nz(txtHote, "") <> "" Then
sIPAddress = GetIPFromHostName(txtHote)
Else
sIPAddress = txtIPSend
End If
success = Ping(sIPAddress, Nz(txtDataSend, vbNullString), ECHO)
txtResult = GetStatusCode(success)
txtIPReceive = ConvertIp(ECHO.Address)
txtTime = ECHO.RoundTripTime & " ms"
If Left$(ECHO.Data, 1) <> Chr$(0) Then
pos = InStr(ECHO.Data, Chr$(0))
txtDataReceive = Left$(ECHO.Data, pos - 1)
End If
txtMemory = ECHO.DataPointer
SocketsCleanup
Else
MsgBox "Les fonctionnalités de ping sont indisponibles"
End If
End If |
Afin de vider les zones de texte à l'ouverture, il est possible d'utiliser une boucle à l'ouverture du formulaire.
Dim ctltxt As Control
For Each ctltxt In Me.Controls
If TypeOf ctltxt Is TextBox And ctltxt.Name <> "txtHote" Then _
ctltxt = ""
Next |
|
| |
Versions : Toutes
La fonction ShellExecute de l'API Windows permet d'ouvrir le navigateur web défini par défaut. En revanche,
si Firefox n'est pas le navigateur par défaut,
le seul moyen de le lancer est d'éxecuter le fichier FireFox.exe.
Afin de trouver le chemin de cet exécutable, il est nécessaire d'analyser
l'entrée de Firefox dans la base des registres.
Code du module :
Private Function Lire(RegAddress As String)
On Error Resume Next
Dim WshShell As Object
Set WshShell = CreateObject("Wscript.Shell")
Lire = WshShell.RegRead(RegAddress)
End Function
Function GetFireFoxPath()
Dim strVersion As String
strVersion = Lire("HKEY_CURRENT_USER\Software\Mozilla\Mozilla Firefox\CurrentVersion")
strVersion = Left(strVersion, InStr(strVersion, " ") - 1)
GetFireFoxPath = Lire("HKEY_CURRENT_USER\Software\Mozilla\Mozilla Firefox " & _
strVersion & "\bin\PathToExe")
End Function |
Exemple d'utilisation :
Sub ouvrir()
Shell GetFireFoxPath & " " & Chr(34) & "http://www.developpez.com" & Chr(34)
End Sub |
|
Auteur :
| Version : 27/08/2004 | | |
| | Versions : 97 et supérieures Dim objWMIService As Object
Dim colAdapters As Object
Dim strComputer As String
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer &"\root\cimv2")
Set colAdapters = _
objWMIService.ExecQuery ("SELECT * FROM Win32_NetworkAdapterConfiguration" & _
"WHERE IPEnabled =True")
n = 1
For Each objAdapter In colAdapters
debug.print objAdapter.MACAddress
If Not IsNull(objAdapter.IPAddress) Then
For i = 0 To UBound(objAdapter.IPAddress)
debug.print objAdapter.IPAddress(i)
Next
End If
n = n + 1
Next |
|
| | Versions : 2000 et supérieures
Dans un module de classe MacAddress
Option Compare Database
Option Explicit
Public IPAdresses As New Collection
Public MacAddress As String |
Dans un module de classe MacAddresses
Option Compare Database
Option Explicit
Private mstrComputerName As String
Private mcolMacAddresses As New Collection
Function Search() As String
Dim objWMIService As Object
Dim colAdapters As Object
Dim objAdapter As Object
Dim objMacAddress As MacAddress
Dim i As Long
Dim s As String
Set objWMIService = GetObject("winmgmts:\\" & mstrComputerName & "\root\cimv2")
Set colAdapters = _
objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration " & _
"WHERE IPEnabled =True")
For Each objAdapter In colAdapters
Set objMacAddress = New MacAddress
objMacAddress.MacAddress = objAdapter.MacAddress
If Not IsNull(objAdapter.IPAddress) Then
For i = 0 To UBound(objAdapter.IPAddress)
s = s & objMacAddress.MacAddress & vbTab & objAdapter.IPAddress(i) & _
vbCrLf
objMacAddress.IPAdresses.Add objAdapter.IPAddress(i)
Next
End If
mcolMacAddresses.Add objMacAddress
Next
Search = Left(s, Len(s) - Len(vbCrLf))
End Function
Function Count() As Long
Count = mcolMacAddresses.Count
End Function
Function Item(index) As MacAddress
Set Item = mcolMacAddresses.Item(index)
End Function
Property Get ComputerName() As String
ComputerName = mstrComputerName
End Property
Property Let ComputerName(NomDuPC As String)
mstrComputerName = NomDuPC
End Property
Private Sub Class_Initialize()
mstrComputerName = "."
End Sub |
Pour utiliser ces classes (par exemple)
Dim x As New MacAddresses
Dim nMAC As Long
Dim nIP As Long
Debug.Print x.Search
For nMAC = 1 To x.Count
Debug.Print x.Item(nMAC).MacAddress
For nIP = 1 To x.Item(nMAC).IPAdresses.Count
Debug.Print vbTab & x.Item(nMAC).IPAdresses(nIP)
Next
Next |
|
| |
Version : Access 97 et supérieures & Visual Basic
Cet exemple de code permet de retourner le chemin UNC d'un fichier. Microsoft précise en effet :
Si vous souhaitez créer un lien avec un fichier situé sur un réseau local,
utilisez un chemin UNC (universal naming convention)
(convention d'affectation de noms (UNC) :
convention de dénomination de fichiers qui fournit un moyen de situer un fichier
quelle que soit la machine où il se trouve. Plutôt que de spécifier une lettre de lecteur et un chemin d'accès,
un nom UNC utilise la syntaxe \\serveur\partage\chemin\nom_fichier.),
au lieu de la lettre d'identification d'une unité réseau mappée dans l'Explorateur
Windows de Microsoft. La lettre de l'unité dépend de la configuration de l'ordinateur,
ou elle peut ne pas être définie, alors qu'un chemin UNC, fiable et cohérent,
permet à Microsoft Access de localiser la source de données contenant la table liée
Dans un module, placez le code suivant :
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
(ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Public Function fnctGetUNCPath(ByVal PathName As String) As String
Const MAX_UNC_LENGTH As Integer = 512
Dim strUNCPath As String
Dim strTempUNCName As String
Dim lngReturnErrorCode As Long
strTempUNCName = String(MAX_UNC_LENGTH, 0)
lngReturnErrorCode = WNetGetConnection(Left(PathName, 2), strTempUNCName, _
MAX_UNC_LENGTH)
If lngReturnErrorCode = 0 Then
strTempUNCName = Trim(Left(strTempUNCName, InStr(strTempUNCName, vbNullChar) - 1))
strUNCPath = strTempUNCName & Mid(PathName, 3)
End If
fnctGetUNCPath = strUNCPath
End Function |
Exemple d'utilisation :
MsgBox fnctGetUNCPath("U:\Argyronet\OneAnyFile.txt") |
Il est aussi possible de combiner la fonction GetOpenFileName à celle ci afin d'afficher une boîte de dialogue Windows
Ouvrir qui retourne le chemin UNC à la place du chemin courant.
Option Compare Database
Option Explicit
Private Declare Sub PathStripPath Lib "shlwapi.dll" Alias "PathStripPathA" _
(ByVal pszPath As String)
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _
(ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
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
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Public Function OuvrirUnFichier(Handle As Long, _
Titre As String, _
TypeRetour As Byte, _
Optional TitreFiltre As String, _
Optional TypeFichier As String, _
Optional RepParDefaut As String, _
Optional UNC As Boolean = False) As String
Dim StructFile As OPENFILENAME
Dim sFiltre As String
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)
With StructFile
.lStructSize = Len(StructFile)
.hwndOwner = Handle
.lpstrFilter = sFiltre
.lpstrFile = String$(254, vbNullChar)
.nMaxFile = 254
.lpstrFileTitle = String$(254, vbNullChar)
.nMaxFileTitle = 254
.lpstrTitle = Titre
.flags = OFN_HIDEREADONLY
If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
RepParDefaut = CurrentDb.Name
PathStripPath (RepParDefaut)
.lpstrInitialDir = Left(CurrentDb.Name, Len(CurrentDb.Name) - _
Len(Mid$(RepParDefaut, 1, InStr(1, RepParDefaut, vbNullChar) - 1)))
Else: .lpstrInitialDir = RepParDefaut
End If
End With
If (GetOpenFileName(StructFile)) Then
Select Case TypeRetour
Case 1
OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, _
InStr(1, StructFile.lpstrFile, vbNullChar) - 1))
If UNC Then OuvrirUnFichier = fnctGetUNCPath(OuvrirUnFichier)
Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, _
InStr(1, StructFile.lpstrFileTitle, vbNullChar) - 1))
End Select
End If
End Function
Private Function fnctGetUNCPath(ByVal PathName As String) As String
Const MAX_UNC_LENGTH As Integer = 512
Dim strUNCPath As String
Dim strTempUNCName As String
Dim lngReturnErrorCode As Long
strTempUNCName = String(MAX_UNC_LENGTH, 0)
lngReturnErrorCode = WNetGetConnection(Left(PathName, 2), strTempUNCName, MAX_UNC_LENGTH)
If lngReturnErrorCode = 0 Then
strTempUNCName = Trim(Left(strTempUNCName, InStr(strTempUNCName, vbNullChar) - 1))
strUNCPath = strTempUNCName & Mid(PathName, 3)
End If
fnctGetUNCPath = strUNCPath
End Function |
Exemple d'utilisation :
MsgBox OuvrirUnFichier(0, "Choisir un fichier", 1, , , , True) |
|
| |
Versions : Toutes
Ce code utilise les API wininet pour charger en mémoire une ressource du protocole HTTP.
Le code ainsi récupérer est écrit dans un fichier temporaire par bloc de 4096 octets. L'avantage de cette méthode,
comparée à celle utilisant la référence msxml, et de ne pas être limitée par la taille du code HTML reçu.
En effet, la méthode utilisant msxml retourne le résultat dans une variable de type string dont la taille est limitée à 64 Ko.
Code du module :
Option Compare Database
Option Explicit
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, _
ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Public Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
(ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, _
ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet.dll" _
(ByVal hFile As Long, ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Public Const INTERNET_FLAG_EXISITING_CONNECT = &H20000000
Public Const INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private total As Long
Private Nb As Long
Dim hSession As Long
Public Sub openInter()
hSession = InternetOpen("MonApp", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
total = 0
Nb = 0
End Sub
Public Sub closeInter()
InternetCloseHandle (hSession)
End Sub
Public Sub GetWeblog(ByVal url As String, ByVal strFic As String)
Dim hUrlFile As Long
Dim bBoucle As Boolean
Dim sReadBuf As String * 4096
Dim OctetsLus As Long
Dim localFile As Long
Dim t0 As Single, t1 As Single
t0 = GetTickCount()
openInter
localFile = FreeFile
If Len(Dir(strFic)) > 0 Then Kill strFic
Open strFic For Binary As #localFile
hUrlFile = InternetOpenUrl(hSession, url, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
bBoucle = True
While bBoucle
sReadBuf = ""
bBoucle = InternetReadFile(hUrlFile, sReadBuf, 4096&, OctetsLus)
Put #localFile, , Left(sReadBuf, OctetsLus)
If OctetsLus = 0 Then bBoucle = False
DoEvents
Wend
Close #localFile
closeInter
t1 = GetTickCount()
Debug.Print "téléchargement du xml : "; Format((t1 - t0) / 1000, "0.000") & " s"
xmlParser strFic
End Sub |
Exemple d'utilisation :
GetWeblog "http://www.developpez.com", "d:\fichierTemp.txt" |
La fenêtre d'éxecution affiche alors le temps mis pour télecharger le fichier et vous
pouvez ensuite l'analyser à l'aide des fonctions de traitement des fichiers texte.
|
| |
Versions : Access 2000 et supérieures
Cette fonction permet de récuperer le code HTML d'une page Web. Elle reçoit comme paramètre l'url de la page à analyser.
Function GetHTML(ByVal LinkHTTP As String) As String
Dim oHttp As MSXML2.ServerXMLHTTP50
Dim sTemp As String
Dim nLimite As Long
Const conStatutOK As Long = 200
Set oHttp = New MSXML2.ServerXMLHTTP50
With oHttp
.Open "GET", LinkHTTP, False
.Send
sTemp = .responseText
If Not .Status = conStatutOK Then Err.Raise 65000, "Procédure", "pas trouvé !"
End With
GetHTML = sTemp
On Error Resume Next
oHttp.abort
Set oHttp = Nothing
End Function |
N'hésitez pas à télécharger le fichier exemple afin de visualiser le traitement associé à cette fonction.
|
| |
Ce code utilise l'API Windows ISDestinationReachable pour déterminer si un PC est accessible via le réseau.
Const NETWORK_ALIVE_AOL = &H4
Const NETWORK_ALIVE_LAN = &H1
Const NETWORK_ALIVE_WAN = &H2
Private Type QOCINFO
dwSize As Long
dwFlags As Long
dwInSpeed As Long
dwOutSpeed As Long
End Type
Private Declare Function IsDestinationReachable Lib _
"SENSAPI.DLL" Alias "IsDestinationReachableA" _
(ByVal lpszDestination As String, ByRef lpQOCInfo As QOCINFO) As Long
Public function testReseau(Nom as String) as boolean
Dim Ret As QOCINFO
Ret.dwSize = Len(Ret)
testReseau= (IsDestinationReachable(Nom, Ret) <>0)
End Sub |
Utilisation :
If TestReseau("www.developpez.com") then
msgbox "Le meilleur site de developpement est accessible"
else
msgbox "Veuillez réessayer plus tard"
end if |
|
|