Public Sub connect() 
 '--------------------------------------- 
 'Connection au serveur SQL NomServeur
 '--------------------------------------- 
 'instanciation de la connection 
 Set Cnx = New ADODB.Connection 
 'parametre de connection 
 Cnx.ConnectionString = "Driver={SQL Server};server=NomServeur;UID=sa;PWD=;database=NomMDB" 
 Cnx.Open 
 'test de connection 
 If Cnx.State = adStateOpen Then 
     MsgBox "connection OK" 
 End If 
End Sub

 '---------------------------
 '--- Déclaration des API ---
 '---------------------------
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As _
 Long, ByVal dwlProcessID As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

 '-----------------------------
 '--- Déclaration des CONSTANTES ---
 '-----------------------------
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STATUS_PENDING = &H103&

 '----------------
 '--- Fonction ---
 '----------------
Private Sub LancerProg(PathFilename As String)
Dim lhProcess As Long
Dim lProcessID As Long
Dim lpExitCode As Long

    'Ouverture du programme + récupération de sont handle
    'La récupération du handle est nécessaire pour pouvoir ouvrir un processus sur celui-ci
    lProcessID = Shell(PathFilename, 1)
   
    'Ouverture d'un processus sur le programme ouvert + récupération du handle du processus
    'La récupération du handle est nécessaire pour obtenir des informations sur celui-ci
    lhProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, lProcessID)
   
    'Boucle tant que la variable lpExitCode <> STATUS_PENDING (&H103&)
    Do
        'Récupération du code de sorti du processus
            'Si programme ouvert -> la variable lpExitCode = STATUS_PENDING
            'Sinon -> la variable lpExitCode = 0. Donc fin de la boucle
        Call GetExitCodeProcess(lhProcess, lpExitCode)
       
        DoEvents 'Continue à effectué les opération effectué par access
       
    Loop While lpExitCode = STATUS_PENDING

    Call CloseHandle(lhProcess) 'Ferme le handle du processus

End Sub

Dim ret As Long
ret = Shell("notepad.exe", vbNormalFocus)

Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, _
   lpdwprocessid As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, _
   ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, _
   ByVal nIndex As Long) As Long
Private Const WM_CLOSE = &H10
Private Const GWL_STYLE = (-16)
Private Const WS_SYSMENU = &H80000

Private Function CloseWindow(ByVal hwnd As Long, ByVal hInstance As Long) As Long

Dim idproc As Long

idproc = 0

'reçoit dans idproc l'id du processus lié à cette fenêtre
GetWindowThreadProcessId hwnd, idproc
If (idproc = hInstance) And ((GetWindowLong(hwnd, GWL_STYLE) And WS_SYSMENU) = WS_SYSMENU) Then
     PostMessage hwnd, WM_CLOSE, 0, 0
End If

'obligatoire pour qu'EnumWindows continue l'énumération
CloseWindow = True

End Function

Public Sub KillApp(hInstance As Long)

EnumWindows AddressOf CloseWindow, hInstance

End Sub

Declare Function EnumWindows Lib "user32" (ByVal wndenmprc As Long, ByVal lParam As Long) As Long 
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, _
                                                                    ByVal lpString As String, _
                                                                    ByVal cch As Long) As Long 
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
                                                                ByVal wParam As Long, _
                                                                lParam As Any) As Long
Public Const WM_CLOSE = &H10

Private AppCible As String

Public Function EnumCallback(ByVal app_hWnd As Long, ByVal param As Long) As Long

Dim buf As String * 256
Dim Titre As String
Dim Longueur As Long

'Récupère le titre de la fenêtre
Longueur = GetWindowText(app_hWnd, buf, Len(buf))
Titre = Left$(buf, Longueur)

'Vérifie si le titre de la fenêtre correspond au nom recherché
If InStr(Titre, AppCible) <> 0 Then
    'Ferme la fenêtre
    SendMessage app_hWnd, WM_CLOSE, 0, 0
End If

'Poursuit l'énumération
EnumCallback = 1

End Function 

Public Sub KillApp(App_Cherchee As String)

AppCible = App_Cherchee
'Demande à Windows d'énumérer les fenêtres ouvertes
EnumWindows AddressOf EnumCallback, 0

End Sub

Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" _
                                      (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, _
                                       ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
                                       ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
                                       ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
                                       lpStartupInfo As STARTUPINFO, _
                                       lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long

'Type pour gérer les lancements de processus
Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

'Info sur un processus
Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadID As Long
End Type

Public Const NORMAL_PRIORITY_CLASS = &H20&
Public Const STILL_ACTIVE = &H103&

Public Sub AttendreFinProcess(proc As PROCESS_INFORMATION, Optional timeout As Long = 60)

Dim Ret As Long
Dim tms As Single
Dim exitcode As Long
   
'Attendre la fin de la commande
tms = Timer
Ret = GetExitCodeProcess(proc.hProcess, exitcode)
Do While Ret <> 0 And exitcode = STILL_ACTIVE
    Ret = GetExitCodeProcess(proc.hProcess, exitcode)
    DoEvents
    Sleep 100
    If Timer - tms > timeout Then
        Err.Raise STILL_ACTIVE, "AttendreFinProcess", "Timeout sur l'attente de la fin d'un process"
    End If
Loop
If Ret = 0 Then
    Err.Raise Err.LastDllError, "AttendreFinProcess", "Erreur systeme N° " & Err.LastDllError
End If

End Sub

Public Sub LancerProcess(sExe As String, proc As PROCESS_INFORMATION)

Dim start As STARTUPINFO
Dim Ret As Long
   
'StartupInfo pour le processus qui lancera la commande
start.cb = Len(start)
'Lancement de la commande
Ret& = CreateProcess(0&, sExe, 0&, 0&, 0&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
If Ret = 0 Then
    Err.Raise Err.LastDllError, "LancerProcess", "Erreur systeme N° " & Err.LastDllError
End If
   
End Sub

Private Sub Command1_Click()
   
Dim proc As PROCESS_INFORMATION
   
On Error GoTo errortag
proc.hProcess = -1
proc.hThread = -1
Debug.Print "Debut du processus"
Call LancerProcess("notepad", proc)
Call AttendreFinProcess(proc)
Debug.Print "fin du processus"
Call CloseHandle(proc.hProcess)
Call CloseHandle(proc.hThread)
  
Exit Sub
   
errortag:
If proc.hProcess <> -1 Then CloseHandle proc.hProcess
If proc.hThread <> -1 Then CloseHandle proc.hThread
MsgBox Err.Number & " - " & Err.Description
   
End Sub

'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

Option Compare Database
Option Explicit

Private Sub cmdEnvoyer_Click()
'txtForm
    CDOSendMail txtFrom, txtTo, txtSubject, txtBody, txtAttach
    'txtForm : Mail de l'envoyeur
    'txtTo : Mail de destination
    'txtSubject = Objet
    'txtBody = contenu
    'txtAttach = chemin complet du fichier
End Sub

Public Sub CDOSendMail(SendFrom As String, _
                       SendTo As String, _
                       Subject As String, _
                       PlainTextBody As String, _
                       FullPathFileName As String)
Dim cdoMail As CDO.Message
Dim iBp As CDO.IBodyPart ' for IBodyPart on message
Dim iBp1 As CDO.IBodyPart
Dim Flds As ADODB.Fields
Dim Stm  As ADODB.Stream

    Set cdoMail = New CDO.Message
    With cdoMail
        .From = SendFrom
        .To = SendTo
        .Subject = Subject
        ''Set iBp = .BodyPart
        Set iBp = cdoMail   '??
   
        ' TEXT BODYPART
        ' Add the body part for the text/plain part of message
        Set iBp1 = iBp.AddBodyPart
   
        ' set the fields here
        Set Flds = iBp1.Fields
        Flds("urn:schemas:mailheader:content-type") = "text/plain; charset=""iso-8859-1"""
        Flds.Update
   
        ' get the stream and add the message
        Set Stm = iBp1.GetDecodedContentStream
        Stm.WriteText PlainTextBody
        Stm.Flush
  
        ' HTML BODYPART
        ' Do the HTML part here
        Set iBp1 = iBp.AddBodyPart
        ' set the content-type field here
        Set Flds = iBp1.Fields
        Flds("urn:schemas:mailheader:content-type") = "text/html"
        Flds.Update
        ' get the stream and add message HTML text to it
        Set Stm = iBp1.GetDecodedContentStream
        Stm.WriteText "<HTML><H1>this is some content for the body part object</H1></HTML>"
        Stm.Flush
   
        ' Now set the Message object's Content-Type header
        ' to multipart/alternative
        Set Flds = iBp.Fields
        Flds("urn:schemas:mailheader:content-type") = "multipart/alternative"
        Flds.Update
        .AddAttachment FullPathFileName
        .Send
    End With
End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

ShellExecute Me.hwnd, "open", "http://www.developpez.com", "", CurrentProject.Path, 1

Dim Ret as Variant

Ret = ShellExecute(.....)
msgbox Ret

0 Le système manque de mémoire ou de ressources, l'exécutable est corrompu ou réallocations non valides.
2 Fichier non trouvé.
3 Chemin non trouvé.
5 Une tentative a été faite pour se lier dynamiquement à une tâche, ou il y a eu une erreur de partage ou de protection réseau.
6 La librairie requiert des segments de données séparés pour chaque tâche.
8 Il n'y a pas assez de mémoire disponible pour lancer l'application.
10 Version de Windows incorrecte.
11 Le fichier exécutable n'est pas correct, il se peut que ce ne soit pas une application Windows, ou qu'il y ait une erreur dans le fichier .EXE;
12 L'application a été conçue pour un autre système d'exploitation.
13 L'application a été conçue pour MS-DOS 4.0.
14 Le type de fichier exécutable est inconnu.
15 Tentative de chargement d'une application en mode réel.
16 Tentative de charger une seconde instance d'un fichier exécutable contenant plusieurs segments de données qui ne sont pas marqués en lecture seule.
19 Tentative de charger un fichier exécutable compressé, le fichier doit être décompressé avant d'être chargé.
20 Fichier de librairie liée dynamiquement (DLL) incorrect, une des DLLs requise pour exécuter cette application est corrompue.
21 L'application requiert les extensions Microsoft Windows 32-bit.
31 Il n'y a pas d'association avec le type de fichier spécifié, ou il n'y a pas d'association pour l'action choisie pour le type de fichier choisi