IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

FAQ MS-Access

FAQ MS-AccessConsultez toutes les FAQ

Nombre d'auteurs : 140, nombre de questions : 926, dernière mise à jour : 15 juin 2021 

 
OuvrirSommaireSystème
 
Sélectionnez
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
Créé le 1er janvier 2005  par nightfall

Lien : FAQ VB

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.

 
Sélectionnez
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
Créé le 1er janvier 2005  par nightfall, grafikm_fr

Lien : FAQ VB

Le FileSystemObject vous permet de le faire facilement :

 
Sélectionnez
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 :

 
Sélectionnez
MsgBox TypeLecteur("c")
Créé le 1er janvier 2005  par grafikm_fr, nightfall

Lien : FAQ VB

Voici le code :

 
Sélectionnez
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
Créé le 6 mars 2004  par Lucifer

Pour obtenir tous les paramètres relatifs à la mémoire, placez ce code dans un module standard :

 
Sélectionnez
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 :

 
Sélectionnez
Dim MS As MEMORYSTATUS
Dim chaine As String

MS.dwLength = Len(MS)
GlobalMemoryStatus MS
   
chaine = "Pourcentage RAM utilisé : " & Format$(MS.dwMemoryLoad, "###,###,###,###") & "  %" & vbCrLf
' On divise toutes les valeurs par 1024 pour les convertir en kilooctets
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
Créé le 1er janvier 2005  par grafikm_fr, nightfall

Lien : FAQ VB

Première solution en utilisant les variables d'environnement :

 
Sélectionnez
MsgBox Environ("COMPUTERNAME")

Autre solution :

Copiez cette déclaration au début d'un module standard :

 
Sélectionnez
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
                                        (ByVal lpBuffer As String, nSize As Long) As Long

Copiez ensuite cette fonction dans votre module :

 
Sélectionnez
Private Function NomOrdinateur() As String

Dim sComputerName As String
Dim iSize As Long

' Un premier appel pour avoir le nombre de caractères nécessaires pour sComputerName
GetComputerName sComputerName, iSize

' On met sComputerName à la bonne taille
sComputerName = Space(iSize)

' Appel final
GetComputerName sComputerName, iSize
NomOrdinateur = sComputerName
  
' P.-S. : on aurait aussi pu déclarer sComputerName avec une taille assez grande :
'     (dim sComputerName as string*32).
'     Un seul appel de GetComputerName aurait alors suffi

End Function
Créé le 1er janvier 2005  par Tofalu, abelman

Lien : FAQ VB

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 :

 
Sélectionnez
'Définition des constantes
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

' Masque pour obtenir la version OS Majeure à partir de la variable version globale
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

    ' Liste de tous les serveurs dans un domaine
    
    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)
    ' La liste des noms est obtenue avec la fonction NetServerEnum
    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 'si tout se passe bien
     
        For cnt = 0 To dwEntriesread - 1
            CopyMemory se100, ByVal bufptr + (nStructSize * cnt), nStructSize
            ' On scanne le buffer en memoire et pour chaque entrée, conversion en String
            resultat = resultat & GetPointerToByteStringW(se100.sv100_name) & "|"
        Next
     
   End If
   
  ' Nettoyage du buffer que le système a réservé pour la liste des noms
   Call NetApiBufferFree(bufptr)
   
  ' On retourne le string contenant les noms séparés par des "|"
   GetServers = resultat

End Function

Public Function GetPointerToByteStringW(ByVal dwData As Long) As String
 
    ' Fonction auxiliaire qui reçoit un pointeur vers une chaîne dans un buffer interne
    ' Windows et la convertit en String exploitable en VB
 
    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 :

 
Sélectionnez
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 ces noms dans un tableau.

Créé le 1er janvier 2005  par grafikm_fr

Lien : FAQ VB

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.

 
Sélectionnez
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
    ' Définition du 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
    ' Définition du type pour définir le statut de l'adaptateur réseau
    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)
    ' Allocation de la mémoire dans le tas du processus
    pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or _
                       HEAP_ZERO_MEMORY, NCB.ncb_length)
             
    If pASTAT = 0 Then
        Debug.Print "Pas assez de mémoire!" 'Bon, y a peu de chance que ça arrive :o)
        Exit Function
    End If
     
    NCB.ncb_buffer = pASTAT
    ' Appel de la fonction NetBIOS qui va nous donner les stats de la carte
    '   (dont l'adresse MAC)
    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)
    ' Désallocation de la mémoire...
    HeapFree GetProcessHeap(), 0, pASTAT
     
    GetMACAddress = tmp

End Function
Créé le 1er janvier 2005  par Team Access

Lien : Comment récupérer l'adresse MAC d'un PC distant ?
Lien : https://access.developpez.com/sources/?page=reseau#mac1
Lien : https://access.developpez.com/sources/?page=reseau#mac2

Placez ces déclarations dans un module standard :

 
Sélectionnez
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 :

 
Sélectionnez
Dim x As Long

' Connecter un lecteur réseau
x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)

' Déconnecter un lecteur réseau
x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)

' Connecter une imprimante
x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_PRINT)

' Déconnecter une imprimante
x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_PRINT)
Créé le 1er janvier 2005  par grafikm_fr, nightfall

Lien : FAQ VB

Copiez ce code dans un module :

 
Sélectionnez
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, séparés par le caractère "|". Il est ensuite recommandé d'appeler la fonction Split() afin de copier les éléments dans un tableau.

Créé le 1er janvier 2005  par HPJ, grafikm_fr

Lien : FAQ VB

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 :

 
Sélectionnez
ResolutionEcran 800, 600
 
Sélectionnez
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
Créé le 1er janvier 2005  par nightfall

Lien : FAQ VB
Lien : Comment connaître la résolution de l'écran ?

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 sous-classement.

Copiez ce code source dans le module du formulaire.

 
Sélectionnez
Private Sub Form_Load()

    ' Remplace la procédure de fenêtre par défaut par notre propre procédure
    oldWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
   
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' Remet la procédure de fenêtre par défaut
    SetWindowLong hwnd, GWL_WNDPROC, oldWndProc
   
End Sub

Et celui-ci dans un module standard.

 
Sélectionnez
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
        ' La résolution a changé
    End If
   
    ' Appelle la procédure de fenêtre par défaut pour que Windows puisse traiter l'événement
    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.

Créé le 1er janvier 2005  par nightfall

Lien : FAQ VB

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 :

 
Sélectionnez
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          ' Format de date courte : 0 = M-J-A, 1 = J-M-A, 2 = A-M-J
Private Const LOCALE_ILDATE = &H22         ' Format de date longue
Private Const LOCALE_SCOUNTRY = &H6        ' Pays en toutes lettres
Private Const LOCALE_SNATIVELANGNAME = &H4 ' Langue, en toutes lettres
Private Const LOCALE_STHOUSAND = &HF       ' Séparateur des milliers
Private Const LOCALE_SDECIMAL = &HE        ' Séparateur décimal

La fonction ci-dessous renvoie la valeur du paramètre régional dont la constante LCTYPE est passée en paramètre :

 
Sélectionnez
Private Function ParametreRegional(parametre As Long) As String

Dim lngResultat As Long
Dim buffer As String
Dim pos As Integer
Dim locale As Long

' Récupère l'identifiant de l'information locale de type utilisateur
locale = GetUserDefaultLCID()

' Renvoie le nombre de caractères nécessaires pour recevoir la valeur du paramètre demandé
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
Créé le 1er janvier 2005  par nightfall

Lien : FAQ VB

Placez cette ligne dans la partie Déclarations d'un module :

 
Sélectionnez
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Vous pourrez ainsi faire une pause de deux secondes avec l'appel suivant :

 
Sélectionnez
Sleep 2000
Créé le 1er janvier 2005  par nightfall

Lien : FAQ VB

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é.

 
Sélectionnez
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
Mis à jour le 1er mars 2007  par nightfall, Morgan BILLY

Lien : FAQ VB

Utilisez la fonction

 
Sélectionnez
Environ$(Expression)

expression est le nom de la variable d'environnement.

Exemple :

 
Sélectionnez
Msgbox Environ$("PATH")
Créé le 10 mai 2005  par Tofalu
 
Sélectionnez
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

    ' Begin the enumeration
    nStatus = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, 0&, ByVal 0&, hEnum)

    LetterToUNC = DriveLetter

    ' Check for success from open enum
    If ((nStatus = 0) And (hEnum <> 0)) Then
        ' Set number of entries
        entries = 1024

        ' Enumerate the resource
        nStatus = WNetEnumResource(hEnum, entries, NetInfo(0), CLng(Len(NetInfo(0))) * 1024)

        ' Check for success
        If nStatus = 0 Then
            For i = 0 To entries - 1
                ' Get the local name
                LocalName = ""
                If NetInfo(i).lpLocalName <> 0 Then
                    LocalName = Space(lstrlen(NetInfo(i).lpLocalName) + 1)
                    r = lstrcpy(LocalName, NetInfo(i).lpLocalName)
                End If

                ' Strip null character from end
                If Len(LocalName) <> 0 Then
                    LocalName = Left(LocalName, (Len(LocalName) - 1))
                End If

                If UCase$(LocalName) = UCase$(DriveLetter) Then
                    ' Get the remote name
                    UNCName = ""
                    If NetInfo(i).lpRemoteName <> 0 Then
                        UNCName = Space(lstrlen(NetInfo(i).lpRemoteName) + 1)
                        r = lstrcpy(UNCName, NetInfo(i).lpRemoteName)
                    End If

                    ' Strip null character from end
                    If Len(UNCName) <> 0 Then
                        UNCName = Left(UNCName, (Len(UNCName) - 1))
                    End If

                    ' Return the UNC path to drive
                    '  added the [] to seperate on printout only
                    LetterToUNC = UNCName

                    ' Exit the loop
                    Exit For
                End If
            Next i
        End If
    End If

    ' End enumeration
    nStatus = WNetCloseEnum(hEnum)
End Function

Appelez la fonction directement comme ceci :

 
Sélectionnez
LetterToUNC("E:")

Et elle renvoie :

\\hp-ux004\oracle

Créé le 10 mai 2005  par Gaël Donat

Il faut utiliser la fonction Ping(HostName As String) du code suivant :

 
Sélectionnez
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.

Créé le 10 mai 2005  par Gaël Donat

Placez ces déclarations dans un module standard :

 
Sélectionnez
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 :

 
Sélectionnez
Dim x As Long

' Connecter un lecteur réseau
x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)

' Déconnecter un lecteur réseau
x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)

' Connecter une imprimante
x = WNetConnectionDialog(Me.hwnd, RESOURCETYPE_PRINT)

' Déconnecter une imprimante
x = WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_PRINT)
Créé le 26 avril 2004  par grafikm_fr, nightfall

Lien : Connecter et déconnecter un lecteur réseau

Mettez ce code dans un module :

 
Sélectionnez
'***************** Code Start **********************
'
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 :

 
Sélectionnez
Dim test As String

test = "resolution"

MsgBox "Résolution de l'écran : " & Resol(test)
Créé le 20 novembre 2005  par fdraven

Lien : Comment changer la résolution de l'écran ?

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 fourni 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 se fait dans la boite des propriétés du contrôle 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

 
Sélectionnez
Private Sub Form_Load()
MSComm1.PortOpen = True     'ouverture du port
End Sub

Private Sub Form_Unload(Cancel As Integer)
MSComm1.PortOpen = False        'fermeture du port
End Sub

Private Sub MSComm1_OnComm()
   Dim InBuff As String
   Dim Lg As String
   Select Case MSComm1.CommEvent
' Erreurs
      Case comEventBreak   ' Un événement d'arrêt a été reçu.
      Case comEventCDTO    ' Expiration du délai CD (RLSD).
      Case comEventCTSTO   ' Expiration du délai CTS.
      Case comEventDSRTO   ' Expiration du délai DSR.
      Case comEventFrame   ' Erreur de trame.
      Case comEventOverrun ' Perte de données.
      Case comEventRxOver  ' Dépassement de capacité du tampon de réception.
      Case comEventRxParity   ' Erreur de parité.
      Case comEventTxFull  ' Tampon de transmission saturé.
      Case comEventDCB     ' Erreur inattendue lors de la récupération de DCB]
' Événements
      Case comEvCD   ' Modification dans la ligne CD.
      Case comEvCTS  ' Modification dans la ligne CTS.
      Case comEvDSR  ' Modification dans la ligne DSR.
      Case comEvRing ' Modification dans l'indicateur d'appel.
      Case comEvReceive ' Réception d'un nombre RThreshold de caractères.
         InBuff = MSComm1.Input        'lecture du tampon de stockage
         [b]Lg = Right(InBuff, 13)   'mon code pour enlever les caractères
         Lg = Left(Lg, 10)               ASCII envoyés au début et à la fin de
         Me!Texte1 = Lg                 l'émission[/b]
      Case comEvSend ' Un nombre Sthreshold de caractères se trouve dans le tampon de transmission.
      Case comEvEOF  ' Un caractère indiquant la fin du fichier (EOF) a été trouvé dans le flux d'entrée
   End Select
End Sub

Si après cela la communication n'est pas établie, posez-vous la question : est-ce que mon câble convient ? Utilisez HyperTerminal de Windows pour faire des essais de lecture directe.

Créé le 20 novembre 2005  par hhkiki

Lien : Le Microsoft Comm Control 6.0
Lien : Piloter une sortie série RS232
Lien : Comment Use MSCOMM32.OCX

Pour arriver à vos fins intéressez-vous à la fonction SHFormatDrive(). Vous trouverez l'aide de cette fonction en anglais dans le lien ci-dessous.

Créé le 20 novembre 2005  par loufab

Lien : MSDN SHFormatDrive Function

La fonction GetDeviceCaps de l'API Windows permet de connaître le nombre de pixels par pouce en résolution horizontale et verticale.

En haut de module déclarer les fonctions suivantes :

 
Sélectionnez
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 :

 
Sélectionnez
' Récupère le nombre de pixels par pouce
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.

Créé le 20 novembre 2005  par Tofalu

Voici un exemple de module dont les fonctions permettent respectivement de tester si la calculatrice est ouverte et de la fermer le cas échéant.

 
Sélectionnez
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
Créé le 29 novembre 2006  par Arkham46

Il faut utiliser l'API Windows et plus particulièrement la fonction LockStation.
Dans un module :

 
Sélectionnez
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.

Créé le 14 mai 2006  par Tofalu

Pour cela, il faut utiliser l'API ExitWindowsEx.
Dans un module placer les déclarations suivantes :

 
Sélectionnez
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 utilisée en addition d'une des trois autres afin de forcer l'arrêt des applications sans demande de confirmation de sortie.
Exemple pour arrêter l'ordinateur :

 
Sélectionnez
ExitWindowsEx(EWX_SHUTDOWN, 0)

La même chose en forçant l'arrêt des applications :

 
Sélectionnez
ExitWindowsEx(EWX_SHUTDOWN OR EWX_FORCE, 0)
Créé le 14 mai 2006  par Tofalu

Ce code permet de renvoyer le répertoire d'installation d'Access.

 
Sélectionnez
SysCmd(acSysCmdAccessDir)
Créé le 31 mars 2008  par kloun

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.