| auteur : Romain Puyfoulhoux | Private Declare Function mciSendString Lib " winmm.dll " Alias " mciSendStringA " _
(ByVal lpstrCommand As String , ByVal lpstrReturnString As Any, _
ByVal wReturnLength As Integer, ByVal hCallback As Integer) As Long
Public Sub Ejecte ()
mciSendString " Set CDAudio Door Open Wait " , 0 & , 0 , 0
End Sub
|
|
lien : FAQ VB
|
| auteurs : Romain Puyfoulhoux, Alexandre Lokchine | Voici une fonction qui vous renvoie le premier lecteur qui contient un CD, ou une chaîne vide s'il n'y en a aucun.
Vous devez ajouter le FileSystemObject dans les références du projet. Public Function LecteurAvecCD () As String
Dim fso As FileSystemObject, lecteur As Drive
Dim strPath As String , strLecteurCD As String
Set fso = New FileSystemObject
For Each lecteur In fso. Drives
If lecteur. DriveType = 4 Then
On Error GoTo suite
strPath = Dir (lecteur. path )
strLecteurCD = lecteur. path
Exit For
End If
suite :
Next
Set fso = Nothing
LecteurAvecCD = strLecteurCD
End Function
|
|
lien : FAQ VB
|
| auteurs : Alexandre Lokchine, Romain Puyfoulhoux | Le FileSystemObject vous permet de le faire facilement : Public Function TypeLecteur (ByVal drvpath) As String
Dim fs As FileSystemObject, d As drive, t As String
Set fs = New FileSystemObject
On Error GoTo fail
Set d = fs. GetDrive (drvpath)
Select Case d. DriveType
Case 0 : t = " Inconnu "
Case 1 : t = " Amovible "
Case 2 : t = " Fixe "
Case 3 : t = " Réseau "
Case 4 : t = " CD-ROM "
Case 5 : t = " Disque RAM "
End Select
fin :
TypeLecteur = t
Exit Function
fail :
t = " Introuvable "
Resume fin
End Function
|
Cette fonction attend en argument la lettre d'un lecteur et renvoie son type en toutes lettres. Par exemple : |
lien : FAQ VB
|
| auteur : Lucifer | Voici le code :
Dim fso As FileSystemObject [Lucifer]
Dim d As Drive
Set fso = New FileSystemObject
For Each d In fso. Drives
MsgBox d. DriveLetter
Next d
Set fso = Nothing
|
|
| auteurs : Alexandre Lokchine, Romain Puyfoulhoux | Pour obtenir tous les paramètres relatifs à la mémoire, placez ce code dans un module standard : Public Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Public Declare Sub GlobalMemoryStatus Lib " kernel32 " (lpBuffer As MEMORYSTATUS)
|
Voici comment utiliser la fonction GlobalMemoryStatus : Dim MS As MEMORYSTATUS
Dim chaine As String
MS. dwLength = Len (MS)
GlobalMemoryStatus MS
chaine = " Pourcentage RAM utilisé: " & Format$(MS. dwMemoryLoad , " ###,###,###,### " ) & " % " & vbCrLf
chaine = chaine & " Taille de la mémoire physique totale: " & _
Format$(MS. dwTotalPhys / 1024 , " ###,###,###,### " ) & " Ko " & vbCrLf
chaine = chaine & " Mémoire physique disponible: " & _
Format$(MS. dwAvailPhys / 1024 , " ###,###,###,### " ) & " Ko " & vbCrLf
chaine = chaine & " Mémoire virtuelle totale: " & _
Format$(MS. dwTotalVirtual / 1024 , " ###,###,###,### " ) & " Ko " & vbCrLf
chaine = chaine & " Mémoire virtuelle disponible: " & _
Format$(MS. dwAvailVirtual / 1024 , " ###,###,###,### " ) & " Ko " & vbCrLf
|
|
lien : FAQ VB
|
| auteurs : Tofalu, Abelman |
Première solution en utilisant les variables d'environnement :
MsgBox Environ (" COMPUTERNAME " )
|
Autre solution :
Copiez cette déclaration au début d'un module standard : Public Declare Function GetComputerName Lib " kernel32 " Alias " GetComputerNameA " _
(ByVal lpBuffer As String , nSize As Long) As Long
|
Copiez ensuite cette fonction dans votre module : Private Function NomOrdinateur () As String
Dim sComputerName As String
Dim iSize As Long
GetComputerName sComputerName, iSize
sComputerName = Space (iSize)
GetComputerName sComputerName, iSize
NomOrdinateur = sComputerName
End Function
|
|
lien : FAQ VB
|
| auteur : Alexandre Lokchine | Une méthode consiste à passer par les appels internes de NetBIOS. La fonction NetServerEnum() n'étant disponible
que sur Windows NT ou supérieur, ce code ne fonctionne pas sur Windows 9x.
Copiez le code suivant dans un module :
Private Const MAX_PREFERRED_LENGTH As Long = - 1
Private Const NERR_SUCCESS As Long = 0 &
Private Const ERROR_MORE_DATA As Long = 234 &
Private Const SV_TYPE_ALL As Long = & HFFFFFFFF
Private Const SV_PLATFORM_ID_OS2 As Long = 400
Private Const SV_PLATFORM_ID_NT As Long = 500
Private Const MAJOR_VERSION_MASK As Long = & HF
Private Type SERVER_INFO_100
sv100_platform_id As Long
sv100_name As Long
End Type
Private Declare Function NetServerEnum Lib " netapi32 " _
(ByVal servername As Long, ByVal level As Long, buf As Any, _
ByVal prefmaxlen As Long, entriesread As Long, totalentries As Long, _
ByVal servertype As Long, ByVal domain As Long, resume_handle As Long) As Long
Private Declare Function NetApiBufferFree Lib " netapi32 " (ByVal Buffer As Long) As Long
Private Declare Sub CopyMemory Lib " kernel32 " Alias " RtlMoveMemory " _
(pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib " kernel32 " _
(ByVal lpString As Long) As Long
Public Function GetServers (sDomain As String ) As String
Dim bufptr As Long
Dim dwEntriesread As Long
Dim dwTotalentries As Long
Dim dwResumehandle As Long
Dim se100 As SERVER_INFO_100
Dim success As Long
Dim nStructSize As Long
Dim cnt As Long
Dim resultat As String
nStructSize = LenB (se100)
success = NetServerEnum (0 & , 100 , bufptr, MAX_PREFERRED_LENGTH, dwEntriesread, _
dwTotalentries, SV_TYPE_ALL, 0 & , dwResumehandle)
If success = NERR_SUCCESS And _
success < > ERROR_MORE_DATA Then
For cnt = 0 To dwEntriesread - 1
CopyMemory se100, ByVal bufptr + (nStructSize * cnt), nStructSize
resultat = resultat & GetPointerToByteStringW (se100. sv100_name ) & " | "
Next
End If
Call NetApiBufferFree (bufptr)
GetServers = resultat
End Function
Public Function GetPointerToByteStringW (ByVal dwData As Long) As String
Dim tmp () As Byte
Dim tmplen As Long
If dwData < > 0 Then
tmplen = lstrlenW (dwData) * 2
If tmplen < > 0 Then
ReDim tmp (0 To (tmplen - 1 )) As Byte
CopyMemory tmp (0 ), ByVal dwData, tmplen
GetPointerToByteStringW = tmp
End If
End If
End Function
|
Ensuite, la fonction GetServers est utilisée de la manière suivante : Dim maliste as String
maliste= GetServers (vbNullString )
|
Cette fonction nous retourne la liste des noms des machines, séparés par le caractère "|".
Il est ensuite recommandé d'appeler la fonction Split() pour copier les noms dans un tableau.
|
lien : FAQ VB
|
| auteur : Team Access | Une adresse MAC est un identifiant stocké dans une interface réseau. Copiez le code ci-dessous dans un module standard.
La fonction GetMACAddress() vous renvoie l'adresse MAC. Private Const NCBASTAT As Long = & H33
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = & H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = & H4
Private Const NCBRESET As Long = & H32
Private Type NET_CONTROL_BLOCK
ncb_command As Byte
ncb_retcode As Byte
ncb_lsn As Byte
ncb_num As Byte
ncb_buffer As Long
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte
ncb_sto As Byte
ncb_post As Long
ncb_lana_num As Byte
ncb_cmd_cplt As Byte
ncb_reserve (9 ) As Byte
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address (5 ) As Byte
rev_major As Byte
reserved0 As Byte
adapter_type As Byte
rev_minor As Byte
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff (30 ) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib " netapi32 " (pncb As NET_CONTROL_BLOCK) As Byte
Private Declare Sub CopyMemory Lib " kernel32 " _
Alias " RtlMoveMemory " (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib " kernel32 " () As Long
Private Declare Function HeapAlloc Lib " kernel32 " _
(ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib " kernel32 " _
(ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Public Function GetMACAddress () As String
Dim tmp As String
Dim pASTAT As Long
Dim NCB As NET_CONTROL_BLOCK
Dim AST As ASTAT
NCB. ncb_command = NCBRESET
Call Netbios (NCB)
NCB. ncb_callname = " * "
NCB. ncb_command = NCBASTAT
NCB. ncb_lana_num = 0
NCB. ncb_length = Len (AST)
pASTAT = HeapAlloc (GetProcessHeap (), HEAP_GENERATE_EXCEPTIONS Or _
HEAP_ZERO_MEMORY, NCB. ncb_length )
If pASTAT = 0 Then
Debug. Print " pas assez de mémoire! "
Exit Function
End If
NCB. ncb_buffer = pASTAT
Call Netbios (NCB)
CopyMemory AST, NCB. ncb_buffer , Len (AST)
tmp = Right $(" 00 " & Hex (AST. adapt . adapter_address (0 )), 2 ) & " " & _
Right $(" 00 " & Hex (AST. adapt . adapter_address (1 )), 2 ) & " " & _
Right $(" 00 " & Hex (AST. adapt . adapter_address (2 )), 2 ) & " " & _
Right $(" 00 " & Hex (AST. adapt . adapter_address (3 )), 2 ) & " " & _
Right $(" 00 " & Hex (AST. adapt . adapter_address (4 )), 2 ) & " " & _
Right $(" 00 " & Hex (AST. adapt . adapter_address (5 )), 2 )
HeapFree GetProcessHeap (), 0 , pASTAT
GetMACAddress = tmp
End Function
|
|
lien : Comment Récupérer l'adresse MAC d'un PC distant
lien : http://access.developpez.com/sources/?page=reseau#mac1
lien : http://access.developpez.com/sources/?page=reseau#mac2
|
| auteurs : Alexandre Lokchine, Romain Puyfoulhoux | Placez ces déclarations dans un module standard : Public Declare Function WNetConnectionDialog Lib " mpr.dll " (ByVal hwnd As Long, _
ByVal dwType As Long) As Long
Public Declare Function WNetDisconnectDialog Lib " mpr.dll " (ByVal hwnd As Long, _
ByVal dwType As Long) As Long
Public Const RESOURCETYPE_DISK = & H1, RESOURCETYPE_PRINT = & H2
|
Ensuite, utilisez l'appel adéquat dans chacune des situations : Dim x As Long
x = WNetConnectionDialog (Me. hwnd , RESOURCETYPE_DISK)
x = WNetDisconnectDialog (Me. hwnd , RESOURCETYPE_DISK)
x = WNetConnectionDialog (Me. hwnd , RESOURCETYPE_PRINT)
x = WNetDisconnectDialog (Me. hwnd , RESOURCETYPE_PRINT)
|
|
lien : FAQ VB
|
| auteurs : hpj, Alexandre Lokchine | Copiez ce code dans un module : Private Declare Function EnumPorts Lib " winspool.drv " Alias " EnumPortsA " _
(ByVal pName As String , ByVal nLevel As Long, _
lpbPorts As Any, ByVal cbBuf As Long, _
pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenA Lib " kernel32 " (lpString As Any) As Long
Private Declare Function lstrcpyA Lib " kernel32 " (lpString1 As Any, lpString2 As Any) As Long
Private Const SIZEOFPORT_INFO_2 = 20
Private Type PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Private Enum PortTypes
PORT_TYPE_WRITE = & H1
PORT_TYPE_READ = & H2
PORT_TYPE_REDIRECTED = & H4
PORT_TYPE_NET_ATTACHED = & H8
End Enum
Private Function GetStrFromPtrA (lpszA As Long) As String
GetStrFromPtrA = String $(lstrlenA (ByVal lpszA), 0 )
Call lstrcpyA (ByVal GetStrFromPtrA, ByVal lpszA)
End Function
Public Function GetPorts () As String
Dim pcbNeeded As Long, pcReturned As Long, Boucle As Integer
Dim PortI2 () As PORT_INFO_2
Dim StrPortType As String , ret As String
EnumPorts vbNullString , 2 , 0 , 0 , pcbNeeded, pcReturned
If pcbNeeded Then
ReDim PortI2 ((pcbNeeded / SIZEOFPORT_INFO_2))
If EnumPorts (vbNullString , 2 , PortI2 (0 ), pcbNeeded, pcbNeeded, pcReturned) Then
For Boucle = 0 To (pcReturned - 1 )
With PortI2 (Boucle)
StrPortType = " "
If (. fPortType And PORT_TYPE_WRITE) Then StrPortType = " write "
If (. fPortType And PORT_TYPE_READ) Then StrPortType = StrPortType & " read "
If (. fPortType And PORT_TYPE_REDIRECTED) Then StrPortType = StrPortType & " redirected "
If (. fPortType And PORT_TYPE_NET_ATTACHED) Then StrPortType = StrPortType & " network "
ret = ret & GetStrFromPtrA (. pPortName ) & " ( " & StrPortType & " ) " & " | "
End With
Next
End If
End If
If Len (ret) > 0 Then ret = Left (ret, Len (ret) - 1 )
GetPorts = ret
End Function
|
La fonction GetPorts renvoie la liste des ports ouverts, separés par le caractère "|". Il est ensuite recommandé
d'appeler la fonction Split() afin de copier les éléments dans un tableau.
|
lien : FAQ VB
|
| auteur : Romain Puyfoulhoux | Copiez ce code source dans un module. Vous pourrez alors changer la résolution par un simple appel à la procédure ResolutionEcran(). Pour passer par exemple à une résolution de 800 x 600 : Private Declare Function EnumDisplaySettings Lib " user32 " Alias " EnumDisplaySettingsA " _
(ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib " user32 " Alias " ChangeDisplaySettingsA " _
(lpDevMode As Any, ByVal dwflags As Long) As Long
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const DM_WIDTH = & H80000
Private Const DM_HEIGHT = & H100000
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Public Sub ResolutionEcran (sgWidth As Long, sgHeight As Long)
Dim blTMP As Boolean, lgTMP As Long, dmEcran As DEVMODE, res As Long
lgTMP = 0
Do
blTMP = EnumDisplaySettings (0 , lgTMP, dmEcran)
lgTMP = lgTMP + 1
Loop While blTMP < > 0
dmEcran. dmFields = DM_WIDTH Or DM_HEIGHT
dmEcran. dmPelsWidth = sgWidth
dmEcran. dmPelsHeight = sgHeight
lgTMP = ChangeDisplaySettings (dmEcran, 0 )
End Sub
|
|
lien : FAQ VB
lien : Comment connaître la résolution de l'écran ?
|
| auteur : Romain Puyfoulhoux | Sous Windows, toutes les fenêtres des applications reçoivent le message WM_DISPLAYCHANGE quand la résolution a changé.
Le principe consiste donc à intercepter ce message grâce au sousclassement.
Copiez ce code source dans le module de la form. Private Sub Form_Load ()
oldWndProc = SetWindowLong (hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Private Sub Form_Unload (Cancel As Integer)
SetWindowLong hwnd, GWL_WNDPROC, oldWndProc
End Sub
|
Et celui-ci dans un module standard.
Public Declare Function SetWindowLong Lib " user32 " Alias " SetWindowLongA " _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (- 4 )
Public oldWndProc As Long
Private Declare Function CallWindowProc Lib " user32 " Alias " CallWindowProcA " _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_DISPLAYCHANGE = & H7E
Public Function WindowProc (ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If msg = WM_DISPLAYCHANGE Then
End If
WindowProc = CallWindowProc (oldWndProc, hwnd, msg, wParam, lParam)
End Function
|
Attention, la procédure Form_Unload doit obligatoirement être exécutée. Si vous déboguez et cliquez sur Stop,
l'éditeur VB plantera. Si vous fermez votre programme avec l'instruction End, la procédure Form_Unload ne sera pas exécutée et
votre programme plantera.
|
lien : FAQ VB
|
| auteur : Romain Puyfoulhoux | Les paramètres régionaux s'obtiennent grâce à la fonction GetLocaleInfo() de l'API Windows. Les paramètres de cette fonction sont :
locale : identifiant représentant le type d'information locale demandé (système ou utilisateur)
LCType : valeur indiquant quel paramètre doit être retrouvé. Ce doit être une des constantes LCTYPE
lpLCData : buffer recevant la valeur du paramètre demandé cchData : longueur du buffer
Voici les déclarations des deux fonctions dont vous aurez besoin, ainsi que quelques-unes des constantes LCTYPE disponibles : Private Declare Function GetLocaleInfo Lib " kernel32 " Alias " GetLocaleInfoA " (ByVal locale As Long, _
ByVal LCType As Long, ByVal lpLCData As String , ByVal cchData As Long) As Long
Private Declare Function GetUserDefaultLCID Lib " kernel32 " () As Long
Private Const LOCALE_IDATE = & H21
Private Const LOCALE_ILDATE = & H22
Private Const LOCALE_SCOUNTRY = & H6
Private Const LOCALE_SNATIVELANGNAME = & H4
Private Const LOCALE_STHOUSAND = & HF
Private Const LOCALE_SDECIMAL = & HE
|
La fonction ci-dessous renvoie la valeur du paramètre régional dont la constante LCTYPE est passée en paramètre : Private Function ParametreRegional (parametre As Long) As String
Dim lngResultat As Long
Dim buffer As String
Dim pos As Integer
Dim locale As Long
locale = GetUserDefaultLCID ()
lngResultat = GetLocaleInfo (locale, parametre, buffer, 0 )
buffer = String (lngResultat, 0 )
GetLocaleInfo locale, parametre, buffer, lngResultat
pos = InStr (buffer, Chr (0 ))
If pos > 0 Then ParametreRegional = Left (buffer, pos - 1 )
End Function
|
|
lien : FAQ VB
|
| auteur : Romain Puyfoulhoux | Placez cette ligne dans la partie Déclarations d'un module : Private Declare Sub Sleep Lib " kernel32 " (ByVal dwMilliseconds As Long)
|
Vous pourrez ainsi faire une pause de 2 secondes avec l'appel suivant : |
lien : FAQ VB
|
| auteurs : Romain Puyfoulhoux, Morgan BILLY | La fonction VersionWindows() de ce code source retourne la version de Windows et place dans le paramètre sp
le service pack qui serait éventuellement installé. Private Declare Function GetVersionExA Lib " kernel32 " (lpVersionInformation As OSVERSIONINFO) As Integer
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Function VersionWindows (ByRef sp As String ) As String
Dim os As OSVERSIONINFO
os. dwOSVersionInfoSize = Len (os)
GetVersionExA os
sp = " "
With os
Select Case . dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS
Select Case . dwMinorVersion
Case 0
VersionWindows = " 95 "
Case 10
VersionWindows = " 98 "
Case 90
VersionWindows = " Me "
End Select
Case VER_PLATFORM_WIN32_NT
Select Case . dwMajorVersion
Case 3
VersionWindows = " NT 3.51 "
Case 4
VersionWindows = " NT 4.0 "
Case 5
If . dwMinorVersion = 0 Then
VersionWindows = " 2000 "
Else
VersionWindows = " XP "
End If
Case 6
VersionWindows = " VISTA "
End Select
End Select
If InStr (. szCSDVersion , Chr (0 )) > 0 Then
sp = Left (. szCSDVersion , InStr (. szCSDVersion , Chr (0 )) - 1 )
End If
End With
End Function
|
|
lien : FAQ VB
|
| auteur : Tofalu | Utiliser la fonction
Où expression est le nom de la variable d'environement.
Exemple : |
| auteur : Gaël Donat | Private Const RESOURCETYPE_ANY = & H0
Private Const RESOURCE_CONNECTED = & H1
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As Long
lpRemoteName As Long
lpComment As Long
lpProvider As Long
End Type
Private Declare Function WNetOpenEnum Lib " mpr.dll " Alias " WNetOpenEnumA " (ByVal dwScope As Long, ByVal dwType As Long, _
ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib " mpr.dll " Alias " WNetEnumResourceA " (ByVal hEnum As Long, lpcCount As Long, _
lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib " mpr.dll " (ByVal hEnum As Long) As Long
Private Declare Function lstrlen Lib " kernel32 " Alias " lstrlenA " (ByVal lpString As Any) As Long
Private Declare Function lstrcpy Lib " kernel32 " Alias " lstrcpyA " (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Function LetterToUNC (DriveLetter As String ) As String
Dim hEnum As Long
Dim NetInfo (1023 ) As NETRESOURCE
Dim entries As Long
Dim nStatus As Long
Dim LocalName As String
Dim UNCName As String
Dim i As Long
Dim r As Long
nStatus = WNetOpenEnum (RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0 & , ByVal 0 & , hEnum)
LetterToUNC = DriveLetter
If ((nStatus = 0 ) And (hEnum < > 0 )) Then
entries = 1024
nStatus = WNetEnumResource (hEnum, entries, NetInfo (0 ), CLng (Len (NetInfo (0 ))) * 1024 )
If nStatus = 0 Then
For i = 0 To entries - 1
LocalName = " "
If NetInfo (i). lpLocalName < > 0 Then
LocalName = Space (lstrlen (NetInfo (i). lpLocalName ) + 1 )
r = lstrcpy (LocalName, NetInfo (i). lpLocalName )
End If
If Len (LocalName) < > 0 Then
LocalName = Left (LocalName, (Len (LocalName) - 1 ))
End If
If UCase $(LocalName) = UCase $(DriveLetter) Then
UNCName = " "
If NetInfo (i). lpRemoteName < > 0 Then
UNCName = Space (lstrlen (NetInfo (i). lpRemoteName ) + 1 )
r = lstrcpy (UNCName, NetInfo (i). lpRemoteName )
End If
If Len (UNCName) < > 0 Then
UNCName = Left (UNCName, (Len (UNCName) - 1 ))
End If
LetterToUNC = UNCName
Exit For
End If
Next i
End If
End If
nStatus = WNetCloseEnum (hEnum)
End Function
|
Appelez la fonction directement comme ceci : et elle renvoie :
\\hp-ux004\oracle
|
| auteur : Gaël Donat | Il faut utiliser la fonction Ping(HostName As String) du code suivant : Const SOCKET_ERROR = 0
Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription (0 To 255 ) As Byte
szSystemStatus (0 To 128 ) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Long
OptionsData As String * 128
End Type
Private Type IP_ECHO_REPLY
Address (0 To 3 ) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type
Private Declare Function GetHostByName Lib " wsock32.dll " Alias " gethostbyname " (ByVal HostName As String ) As Long
Private Declare Function WSAStartup Lib " wsock32.dll " (ByVal wVersionRequired& , lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib " wsock32.dll " () As Long
Private Declare Sub CopyMemory Lib " kernel32 " Alias " RtlMoveMemory " (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib " icmp.dll " () As Long
Private Declare Function IcmpCloseHandle Lib " icmp.dll " (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib " ICMP " (ByVal IcmpHandle As Long, ByVal DestAddress As Long, _
ByVal RequestData As String , _
ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, _
ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean
Private Function Ping (HostName As String ) As Integer
Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY
Call WSAStartup (& H101, lpWSAdata)
If GetHostByName (HostName + String (64 - Len (HostName), 0 )) < > SOCKET_ERROR Then
CopyMemory hHostent. h_name , ByVal GetHostByName (HostName + String (64 - Len (HostName), 0 )), Len (hHostent)
CopyMemory AddrList, ByVal hHostent. h_addr_list , 4
CopyMemory Address, ByVal AddrList, 4
End If
hFile = IcmpCreateFile ()
If hFile = 0 Then
MsgBox " Unable to Create File Handle "
Exit Function
End If
OptInfo. TTL = 255
If IcmpSendEcho (hFile, Address, String (32 , " A " ), 32 , OptInfo, EchoReply, Len (EchoReply) + 8 , 2000 ) Then
rIP = CStr (EchoReply. Address (0 )) + " . " + CStr (EchoReply. Address (1 )) + " . " + CStr (EchoReply. Address (2 )) + " . " + _
CStr (EchoReply. Address (3 ))
Else
Ping = - 1
End If
If EchoReply. Status = 0 Then
Ping = EchoReply. RoundTripTime
End If
Call IcmpCloseHandle (hFile)
Call WSACleanup
End Function
|
Cette fonction renvoie -1 en timeout, sinon elle renvoie le temps en millisecondes pour établir le ping.
|
| auteurs : Alexandre Lokchine, Romain Puyfoulhoux | Placez ces déclarations dans un module standard : Public Declare Function WNetConnectionDialog Lib " mpr.dll " (ByVal hwnd As Long, _
ByVal dwType As Long) As Long
Public Declare Function WNetDisconnectDialog Lib " mpr.dll " (ByVal hwnd As Long, _
ByVal dwType As Long) As Long
Public Const RESOURCETYPE_DISK = & H1, RESOURCETYPE_PRINT = & H2
|
Ensuite, utilisez l'appel adéquat dans chacune des situations : Dim x As Long
x = WNetConnectionDialog (Me. hwnd , RESOURCETYPE_DISK)
x = WNetDisconnectDialog (Me. hwnd , RESOURCETYPE_DISK)
x = WNetConnectionDialog (Me. hwnd , RESOURCETYPE_PRINT)
x = WNetDisconnectDialog (Me. hwnd , RESOURCETYPE_PRINT)
|
|
lien : Connecter et déconnecter un lecteur réseau
|
| auteur : fdraven | Mettez ce code dans un module :
Private Declare Function apiGetSys Lib " user32 " _
Alias " GetSystemMetrics " (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CYCAPTION = 4
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYVTHUMB = 9
Private Const SM_CXHTHUMB = 10
Private Const SM_CXICON = 11
Private Const SM_CYICON = 12
Private Const SM_CXCURSOR = 13
Private Const SM_CYCURSOR = 14
Private Const SM_CYMENU = 15
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Private Const SM_CYKANJIWINDOW = 18
Private Const SM_MOUSEPRESENT = 19
Private Const SM_CYVSCROLL = 20
Private Const SM_CXHSCROLL = 21
Private Const SM_DEBUG = 22
Private Const SM_SWAPBUTTON = 23
Private Const SM_RESERVED1 = 24
Private Const SM_RESERVED2 = 25
Private Const SM_RESERVED3 = 26
Private Const SM_RESERVED4 = 27
Private Const SM_CXMIN = 28
Private Const SM_CYMIN = 29
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const SM_CXMINTRACK = 34
Private Const SM_CYMINTRACK = 35
Private Const SM_CXDOUBLECLK = 36
Private Const SM_CYDOUBLECLK = 37
Private Const SM_CXICONSPACING = 38
Private Const SM_CYICONSPACING = 39
Private Const SM_MENUDROPALIGNMENT = 40
Private Const SM_PENWINDOWS = 41
Private Const SM_DBCSENABLED = 42
Private Const SM_CMOUSEBUTTONS = 43
Private Const SM_CMETRICS = 44
Function Resol (strWhat As String ) As String
Dim strRet As String
Select Case LCase (strWhat)
Case " resolution " : strRet = apiGetSys (SM_CXSCREEN) & " x " _
& apiGetSys (SM_CYSCREEN)
Case " windowsize " : strRet = apiGetSys (SM_CXFULLSCREEN) & " x " _
& apiGetSys (SM_CYFULLSCREEN)
End Select
Resol = strRet
End Function
|
Voici un exemple de code qui vous affichera la résolution de l'écran :
Dim test As String
test = " resolution "
MsgBox " Résolution de l'écran : " & Resol (test)
|
|
lien : Comment changer la résolution de l'écran ?
|
| auteur : hhkiki |
Le plus simple: il faut utiliser MSCOMM32.OCX
Mais lorsque l'on installe MSComm et que l'on veut l'utiliser dans un formulaire, la réponse est simple "vous ne possédez pas la licence", car l'ocx est fournit avec visual basic pro.
Deuxième étape:
Dans le formulaire ouvert en mode création, il faut insérer le ControlActiveX: Microsoft communications control, V6.0.
Troisième étape:
Le paramétrage du port ce fait dans la boite des propriétés du control MSComm :
-numéro de port, vitesse, parité, nombre de bits,...
et ceci en fonction du matériel branché sur le port.
Pour les autres paramètres: RThreshold, SThreshold, RTSEnable, DTREnable et InputLen, visitez le site de Microsoft
Quatrième étape:
Voici un exemple de code qui exploite le port COM
Private Sub Form_Load ()
MSComm1. PortOpen = True
End Sub
Private Sub Form_Unload (Cancel As Integer)
MSComm1. PortOpen = False
End Sub
Private Sub MSComm1_OnComm ()
Dim InBuff As String
Dim Lg As String
Select Case MSComm1. CommEvent
Case comEventBreak
Case comEventCDTO
Case comEventCTSTO
Case comEventDSRTO
Case comEventFrame
Case comEventOverrun
Case comEventRxOver
Case comEventRxParity
Case comEventTxFull
Case comEventDCB
Case comEvCD
Case comEvCTS
Case comEvDSR
Case comEvRing
Case comEvReceive
InBuff = MSComm1. Input
[b]Lg = Right (InBuff, 13 )
Lg = Left (Lg, 10 ) ASCII envoyé au dédut et à la fin de
Me!Texte1 = Lg l
Case comEvSend
Case comEvEOF
End Select
End Sub
|
si après cela la communication n'est pas établie, pausez-vous la question:
est-ce que mon câble convient ?
Utilisez HyperTerminal de Windows pour faire des essais de lecture direct.
|
lien : Le Microsoft Comm Control 6.0
lien : Piloter une sortie série RS232
lien : Comment Use MSCOMM32.OCX
|
| auteur : Tofalu |
La fonction GetDeviceCaps de l'API Windows permet de connaître le nombre de pixels par pouces en résolution horizontale et verticale.
En haut de module déclarer les fonctions suivantes :
Public Declare Function GetDC Lib " user32 " (ByVal hwnd As Long) As Long
Public Declare Function GetDeviceCaps Lib " gdi32 " (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Const LOGPIXELSX= 88
Public Const LOGPIXELSY= 90
|
Puis dans votre code, utiliser ainsi :
NbPointParPouceX = GetDeviceCaps (GetDC (0 ), 88 )
NbPointParPouceY = GetDeviceCaps (GetDC (0 ), 90 )
|
Le résultat est donc donné en pixels par pouce. Sachant qu'un pouce=1440 Twips (unité de mesure par défaut en vba), il suffit alors de diviser le résultat par 1440.
|
| auteur : Arkham46 |
Voici un exemple de module dont les fonctions permettent respectivement de tester si la calculatrice est ouverte et de la fermer.
Private Declare Function FindWindowEx Lib " user32 " Alias _
" FindWindowExA " (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String , ByVal lpsz2 As String ) As Long
Private Declare Function SendMessage Lib " user32 " Alias _
" SendMessageA " (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const WM_CLOSE = & H10
Public Function IsCalcOpen () As Boolean
IsCalcOpen = (FindWindowEx (0 & , 0 & , " SciCalc " , vbNullString ) < > 0 )
End Function
Public Sub CloseCalc ()
Dim lHwnd As Long
lHwnd = FindWindowEx (0 & , 0 & , " SciCalc " , vbNullString )
If lHwnd < > 0 Then SendMessage lHwnd, WM_CLOSE, 0 , 0 &
End Sub
|
|
| auteur : Tofalu |
Il faut utiliser l'API Windows et plus particulièrement la fonction LockStation
Dans un module :
Private Declare Function LockWorkStation Lib " user32.dll " () As Long
Public Sub Verrouiller ()
LockWorkStation
End Sub
|
Il suffit alors d'appeler la méthode Verrouiller là où vous en avez besoin.
|
| auteur : Tofalu |
Pour cela, il faut utiliser l'API ExitWindowsEx.
Dans un module placer les déclarations suivantes :
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Declare Function ExitWindowsEx Lib " user32 " (ByVal uFlags As Long, ByVal dwReserved As Long)
|
La constante LOGOFF ferme la session, SHUTDOWN arrête la machine, REBOOT redémarre. La constante FORCE peut être utiliser en addition d'une des 3 autres afin de forcer l'arrêt des applications sans demande de confirmation de sortie.
Exemple pour arréter l'ordinateur :
ExitWindowsEx (EWX_SHUTDOWN, 0 )
|
La même chose en forçant l'arrêt des applications :
ExitWindowsEx (EWX_SHUTDOWN OR EWX_FORCE, 0 )
|
|
| auteur : kloun | Ce code permet de renvoyer le répertoire d'installation d'Access : SysCmd (acSysCmdAccessDir)
|
|
Consultez les autres F.A.Q's
Les sources présentés sur cette pages sont libre de droits,
et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs.
Copyright ©2004
Developpez LLC. Tout droits réservés Developpez LLC.
Aucune reproduction, même partielle, ne peut être faite de ce site et de
l'ensemble de son contenu : textes, documents et images sans l'autorisation
expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans
de prison et jusqu'à 300 000 E de dommages et intérets.
Cette page est déposée à la SACD.
|