MAPISession1.SignOn
MAPIMessages1.MsgIndex = -1
MAPIMessages1.SessionID = MAPISession1.SessionID
MAPIMessages1.RecipDisplayName = "toto@domaine.fr"  'Destinataire
MAPIMessages1.MsgSubject = "Un petit bonjour"       'Objet
MAPIMessages1.MsgNoteText = "Salut."                'Texte
MAPIMessages1.Send
MAPISession1.SignOff

Dim config As CDO.Configuration 
Dim email As CDO.Message 
 
Set config = New CDO.Configuration 
With config.Fields 
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = CDO.cdoSendUsingPort 
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.monserveur.com" 
    .Update 
End With 
 
 
Set email = New CDO.Message 
With email 
    Set .Configuration = config 
    .From = "toto@a.com" 
    .To = "tata@a.com" 
    .Subject = "Sujet" 
    .Textbody = "Blabla" 
    .Send 
End With

Function Base64Decode(ByVal base64String as String) as String
 
    Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Dim dataLength, sOut, groupBegin
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
 
    'Suppression des espaces/entrées/tab, s'il y en a
    base64String = Replace(base64String, vbCrLf, "")
    base64String = Replace(base64String, vbTab, "")
    base64String = Replace(base64String, " ", "")
 
    'la longueur de la chaîne passée doit être un multiple de 4
    dataLength = Len(base64String)
    If dataLength Mod 4 <> 0 Then
        Err.Raise 1, "Base64Decode", "Bad Base64 string."
        Exit Function
    End If
 
    ' Decodage de chaque groupe:
    For groupBegin = 1 To dataLength Step 4
 
        ' Chaque groupe se transforme en 3 octets.
        numDataBytes = 3
        nGroup = 0
 
        For CharCounter = 0 To 3
            ' On convertit chaque caractère en 6 bits de données, et l'ajouter à un
            'entier pour assurer le stockage temporaire. Si le caractère est
            'un '=', il y a un byte de données de moins (il ne peut avoir que 2 '=' au
            'maximum dans toute la chaine).
 
            thisChar = Mid(base64String, groupBegin + CharCounter, 1)
 
            If thisChar = "=" Then
                numDataBytes = numDataBytes - 1
                thisData = 0
            Else
                thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
            End If
            If thisData = -1 Then
                Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
                Exit Function
            End If
            nGroup = 64 * nGroup + thisData
        Next
 
        'Hex divise l'entier long en 6 groupes de 4 bits
        nGroup = Hex(nGroup)
 
        'Ajout des zéros de tête
        nGroup = String(6 - Len(nGroup), "0") & nGroup
 
        'Conversion de l'entier en héxa en 3 caractères
        pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
          Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
          Chr(CByte("&H" & Mid(nGroup, 5, 2)))
 
        'concatenation avec la chaîne de sortie
        sOut = sOut & Left(pOut, numDataBytes)
    Next    
 
    Base64Decode = sOut
 
End Function

'Envoi d'un mail avec Lotus Notes
'Subject : sujet du mail
'Attachment : nom d'une pièce jointe
'Recipient : adresse e-mail du destinataire principal
'ccRecipient : destinataire en copie
'bccRecipient : destinataire en copie invisible
'BodyText : corps du mail
'SaveIt : mettre à True pour que le mail soit sauvegardé
'Password : mot de passe
 
Public Sub SendNotesMail(ByVal Subject As String, ByVal Attachment As String, _
                         ByVal Recipient As String, ByVal ccRecipient As String, _
                         ByVal bccRecipient As String, ByVal BodyText As String, _
                         ByVal SaveIt As Boolean, ByVal Password As String)
 
    Dim Maildb As Object      'La base des mails
    Dim UserName As String    'Le nom d'utilisateur
    Dim MailDbName As String  'Le nom de la base des mails
    Dim MailDoc As Object     'Le mail
    Dim AttachME As Object    'L'objet pièce jointe en RTF
    Dim Session As Object     'La session Notes
    Dim EmbedObj As Object    'L'objet incorporé
 
    'Crée une session notes
    Set Session = CreateObject("Notes.NotesSession")
 
    '*** Cette ligne est réservée aux versions 5.x et supérieur : ***
    Session.Initialize (Password)
 
    'Récupère le nom d'utilisateur et crée le nom de la base des mails
    UserName = Session.UserName
    MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
 
    'Ouvre la base des mails
    Set Maildb = Session.GETDATABASE("", MailDbName)
    If Not Maildb.ISOPEN Then Maildb.OPENMAIL
 
    'Paramètre le mail à envoyer
    Set MailDoc = Maildb.CREATEDOCUMENT
    MailDoc.Form = "Memo"
    MailDoc.sendto = Recipient
    MailDoc.CopyTo = ccRecipient
    MailDoc.BlindCopyTo = bccRecipient
    MailDoc.Subject = Subject
    MailDoc.Body = BodyText
    MailDoc.SAVEMESSAGEONSEND = SaveIt
 
    'Prend en compte les pièces jointes
    If Attachment <> "" Then
        Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
        Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment")
        MailDoc.CREATERICHTEXTITEM ("Attachment")
    End If
 
    'Envoie le mail
    MailDoc.PostedDate = Now()
    MailDoc.SEND 0, Recipient
 
    Set Maildb = Nothing
    Set MailDoc = Nothing
    Set AttachME = Nothing
    Set Session = Nothing
    Set EmbedObj = Nothing
End Sub

Dim recip(25) as Variant
 
recip(0) = "emailaddress1"
recip(1) = "emailaddress2"
maildoc.sendto = recip

Private Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Private Const ERROR_SUCCESS As Long = 0
 
Private Type IP_ADDRESS_STRING
    IpAddr(0 To 15) As Byte
End Type
 
Private Type IP_MASK_STRING
    IpMask(0 To 15) As Byte
End Type
 
Private Type IP_ADDR_STRING
    dwNext As Long
    IpAddress As IP_ADDRESS_STRING
    IpMask As IP_MASK_STRING
    dwContext As Long
End Type
 
Private Type IP_ADAPTER_INFO
    dwNext As Long
    ComboIndex As Long  'reserved
    sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
    sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
    dwAddressLength As Long
    sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
    dwIndex As Long
    uType As Long
    uDhcpEnabled As Long
    CurrentIpAddress As Long
    IpAddressList As IP_ADDR_STRING
    GatewayList As IP_ADDR_STRING
    DhcpServer As IP_ADDR_STRING
    bHaveWins As Long
    PrimaryWinsServer As IP_ADDR_STRING
    SecondaryWinsServer As IP_ADDR_STRING
    LeaseObtained As Long
    LeaseExpires As Long
End Type
 
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
                                         (pTcpTable As Any, pdwSize As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                               (dst As Any, src As Any, ByVal bcount As Long)
 
Private Function TrimNull(item As String)
 
Dim pos As Integer
 
pos = InStr(item, Chr$(0))
If pos Then
    TrimNull = Left$(item, pos - 1)
Else
    TrimNull = item
End If
 
End Function
 
Public Function LocalIPAddress() As String
 
Dim cbRequired  As Long
Dim buff()      As Byte
Dim Adapter     As IP_ADAPTER_INFO
Dim AdapterStr  As IP_ADDR_STRING
Dim ptr1        As Long
Dim sIPAddr     As String
Dim found       As Boolean
 
GetAdaptersInfo ByVal 0&, cbRequired
 
If cbRequired > 0 Then
    ReDim buff(0 To cbRequired - 1) As Byte
    If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
        ptr1 = VarPtr(buff(0))
        Do While (ptr1 <> 0)
            CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
            With Adapter
                sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
                If Len(sIPAddr) > 0 Then
                    found = True
                    Exit Do
                End If
                ptr1 = .dwNext
            End With
        Loop
    End If
End If
 
LocalIPAddress = sIPAddr
 
End Function

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

Private Function NomOrdinateur() As String
 
Dim sComputerName As String
Dim iSize As Long
 
'Un premier appel pour avoir le nombre de caractères nécéssaire pour sComputerName
GetComputerName sComputerName, iSize
 
'On met sComputerName à la bonne taille
sComputerName = Space(iSize)
 
'Appel final
GetComputerName sComputerName, iSize
NomOrdinateur = sComputerName
 
'PS : On aurait aussi pu déclarer sComputerName avec une taille assez grande :
'     (dim sComputerName as string*32).
'     Un seul appel de GetComputerName aurait alors suffit
 
End Function

Dim NomOrdinateur As String
 
NomOrdinateur = Environ("COMPUTERNAME")

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
                                                   (ByRef lpdwFlags As Long, _
                                                    ByVal dwReserved As Long) As Long
 
Public Function ConnexionInternetActive() As Boolean
 
ConnexionInternetActive = InternetGetConnectedState(0&, 0&)
 
End Function

Private Sub CopieParFtp(ByVal source As String, ByVal destination, ByVal login As String, _
                        ByVal motdepasse As String, ByVal url As String)
 
With Inet1
    .AccessType = icDirect
    .Protocol = icFTP
    .URL = "ftp://" & login & ":" & motdepasse & "@" & url
    .Execute , "SEND " & source & " " & "/" & destination
    While .StillExecuting
        DoEvents
    Wend
    .Cancel
End With
 
End Sub

CopieParFtp "c:\lettre.txt", "lettre.txt", "bill", "HgDrk62B", "microsoft.com"

'------------------- 
'Déclaration des API 
'------------------- 
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
                                            (ByVal hInet As Long) As Integer 
 
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
                      (ByVal hInternetSession As Long, ByVal sServerName As String, _
                           ByVal nServerPort As Integer, ByVal sUserName As String, _
         ByVal sPassword As String, ByVal lService As Long, _
 ByVal lFlags As Long, ByVal lContext As Long) As Long 
 
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
                               (ByVal sAgent As String, ByVal lAccessType As Long, _
 ByVal sProxyName As String, ByVal sProxyBypass As String, _
 ByVal lFlags As Long) As Long 
 
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
                         (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean 
 
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" _
                           (ByVal hConnect As Long, ByVal lpszLocalFile As String, _
 ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
 ByVal dwContext As Long) As Boolean 
 
 
 
Private Sub envoi_fichier_Click() 
Dim HwndConnect As Long 
Dim HwndOpen As Long 
 
HwndOpen = InternetOpen("SiteWeb", 0, vbNullString, vbNullString, 0) 'Ouvre internet 
 
HwndConnect = InternetConnect(HwndOpen, "ftp.mon_site_web.qc.ca", 21, "mon_username", _
                                              "mon_password", 1, 0, 0) 'Connection au site ftp 
 
'On arrive par défaut dans le répertoire ftp.mon_site_web.qc.ca/root/ 
'Cependant, je veux envoyer le fichier dans le dossier page_web/documents 
'Donc il faut que je me déplace dans le ftp pour me positionner dans le bon répertoire 
FtpSetCurrentDirectory HwndConnect, "page_web/documents" 
 
'Le fichier est envoyé ici 
'Mon fichier sur le disque dur est le suivant: C:\windows\bureau\test.txt 
'Cependant, je veux que le fichier sur le ftp se nomme shwin.txt donc, le fichier test.txt est renommé en shwin.txt quand il est envoyé
'On aurait pu laisser le nom test.txt au lieu de shwin.txt mais ainsi, on a un exemple de renommage. 
FtpPutFile HwndConnect, "C:\windows\bureau\test.txt", "shwin.txt", &H0, 0 
 
InternetCloseHandle HwndConnect 'Ferme la connection 
InternetCloseHandle HwndOpen 'Ferme internet

'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 reservé pour la liste des noms
   Call NetApiBufferFree(bufptr)
 
  'on retourne le string contenants les noms separés par des "|"
   GetServers = resultat
 
End Function
 
Public Function GetPointerToByteStringW(ByVal dwData As Long) As String
 
    'fonction auxilliaire 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

Dim maliste as String
maliste=GetServers(vbNullString)

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
    'definition 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
    'definition du type pour definir 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 memoire 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 ca 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

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

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)

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

Public Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias _
                 "InitiateSystemShutdownA" (ByVal lpMachineName As String, _
 ByVal lpMessage As String, ByVal dwTimeout As Long, _
 ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long 
 
Public Sub RedemarrerADistance() 
    Call InitiateSystemShutdown("\\COMPUTER1", "Votre ordinateur va être arrêté à distance _
                                           depuis VB dans 5 secondes", 5000, True, False) 
End Sub

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

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

MsgBox fnctGetUNCPath("U:\Argyronet\OneAnyFile.txt")

Option Explicit
 
' Déclarations pour GetRemoteMACAddress
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
  (ByVal s As String) As Long
Private Declare Function SendARP Lib "iphlpapi.dll" _
  (ByVal DestIP As Long, _
   ByVal SrcIP As Long, _
   pMacAddr As Long, _
   PhyAddrLen As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" _
   Alias "RtlMoveMemory" _
  (dst As Any, _
   src As Any, _
   ByVal bcount As Long)
' Déclarations pour LetterToUNC
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
 
' Déclarations pour LetterToUNC
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
 
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
 
Private Type WSADATA
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To WSADescription_Len) As Byte
    szSystemStatus(0 To WSASYS_Status_Len) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type
 
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
 
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, _
ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _
hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal _
hpvSource&, ByVal cbCopy&)
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Public Function GetRemoteMACAddress(ByVal pIPDistante As String) As String
Dim lAddr As Long
Dim lMacAddr As Long
Dim lMacAddrByte() As Byte
Dim lPhyAddrLen As Long
Dim lCpt As Integer
' Transforme l'adresse IP texte en adresse IP numérique
lAddr = inet_addr(pIPDistante)
If lAddr <> -1 Then
    ' Taille d'une adresse MAC = 6
    lPhyAddrLen = 6
    ' Recherche l'adresse MAC distante
    If SendARP(lAddr, 0&, lMacAddr, lPhyAddrLen) = 0 Then
        If (lMacAddr <> 0) And (lPhyAddrLen <> 0) Then
            ' Tableau de byte qui contiendra l'adresse MAC
            ReDim lMacAddrByte(0 To lPhyAddrLen - 1)
            ' Copy l'adresse MAC dans le tableau (lMacAddr est une adresse mémoire)
            CopyMemory lMacAddrByte(0), lMacAddr, ByVal lPhyAddrLen
            ' Converti l'adresse MAC en texte
            GetRemoteMACAddress = ""
            For lCpt = LBound(lMacAddrByte) To UBound(lMacAddrByte)
                GetRemoteMACAddress = GetRemoteMACAddress & Right("00" & Hex(lMacAddrByte(lCpt)), 2) & IIf(lCpt = UBound(lMacAddrByte), "", "-")
            Next
        End If
    End If
End If
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/192689/fr
Public 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 = "Drive Letter Not Found"
 
'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
            LetterToUNC = UNCName
 
            ' Exit the loop
            Exit For
         End If
      Next i
   End If
End If
 
' End enumeration
nStatus = WNetCloseEnum(hEnum)
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/160215/fr
Private Function hibyte(ByVal wParam As Integer)
    hibyte = wParam \ &H100 And &HFF&
End Function
 
Private Function lobyte(ByVal wParam As Integer)
    lobyte = wParam And &HFF&
End Function
 
Private Sub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
    iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
    If iReturn <> 0 Then
        MsgBox "Winsock.dll is not responding."
        End
    End If
    If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _
        WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
        sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
        sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
        sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
        sMsg = sMsg & " is not supported by winsock.dll "
        MsgBox sMsg
        End
    End If
    'iMaxSockets is not used in winsock 2. So the following check is only
    'necessary for winsock 1. If winsock 2 is requested,
    'the following check can be skipped.
    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox sMsg
        End
    End If
End Sub
 
Private Sub SocketsCleanup()
Dim lReturn As Long
    lReturn = WSACleanup()
    If lReturn <> 0 Then
        MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
        End
    End If
End Sub
 
Public Function GetIpFromHost(ByVal pHostName As String) As Variant
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
Dim lCpt As Integer
Dim lResult() As String
On Error GoTo Gestion_Erreurs
    SocketsInitialize
    ' Retire le double \
    If Left(pHostName, 2) = "\\" Then
        pHostName = Right(pHostName, Len(pHostName) - 2)
    End If
    ' Retire un éventuel chemin
    If InStr(pHostName, "\") > 0 Then
        pHostName = Left(pHostName, InStr(pHostName, "\") - 1)
    End If
    hostname = Trim$(pHostName & vbNullChar)
    hostent_addr = gethostbyname(hostname)
    If hostent_addr = 0 Then
        MsgBox "Winsock.dll is not responding."
        Exit Function
    End If
    RtlMoveMemory host, hostent_addr, LenB(host)
    RtlMoveMemory hostip_addr, host.hAddrList, 4
    'get all of the IP address if machine is  multi-homed
    lCpt = 0
    Do
        ReDim temp_ip_address(1 To host.hLength)
        RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
 
        For i = 1 To host.hLength
            ip_address = ip_address & temp_ip_address(i) & "."
        Next
        ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
 
        ReDim lResult(lCpt)
        lResult(lCpt) = ip_address
        lCpt = lCpt + 1
        ip_address = ""
        host.hAddrList = host.hAddrList + LenB(host.hAddrList)
        RtlMoveMemory hostip_addr, host.hAddrList, 4
     Loop While (hostip_addr <> 0)
Gestion_Erreurs:
    SocketsCleanup
    GetIpFromHost = lResult
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------