Exemples de fonctions API, suite

<<<< voir les exemples précécents <<<<

Pour tous les exemples d'utilisation des API en VBA, il suffit de recopier le texte de la macro (lignes en vert, y compris les déclarations) dans un module standard, puis de lancer la macro (Sub).

La souris pond des oeufs (GetWindowDC et GetCursorPos de user32, Ellipse de gdi32, Sleep de kernel32)

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long
Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Type POINT
x As Long
y As Long
End Type

Sub rond()
Dim Position As POINT
For num = 1 To 100
GetCursorPos Position
Ellipse GetWindowDC(0), Position.x - 5, Position.y - 7, Position.x + 5, Position.y + 5
Sleep 30
Next
End Sub

Déplacez la souris sur l'écran après avoir lancé la macro. Le pointeur pond un oeuf toutes les 30 millisecondes, même sur les barres d'outils ou de menus...
GetWindowDC(0) renvoie le pointeur de la fenetre occupant tout l'écran.
GetCursorPos renvoie la position du curseur sous forme d'objet de type POINT (deux coordonnées en pixel).
La fonction Ellipse trace une ellipse sur la fenêtre dont le pointeur est retourné par GetWindowDC(0), avec comme coordonnées celles qui sont contenues dans l'objet de type POINT.

L'écran disparait sous un tapis de bulles (GetWindowDC de user32, Ellipse de gdi32, Sleep de kernel32

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub bulles()
For num = 1 To 1000
xx = 1000 * Rnd()
yy = xx * Rnd()
diam = 100 * Rnd
Ellipse GetWindowDC(0), xx, yy, xx + diam, yy + diam
Sleep 20
Next
End Sub

GetWindowDC(0) renvoie le pointeur de la fenetre occupant tout l'écran.
La fonction Ellipse trace une ellipse sur la fenêtre dont le pointeur est retourné par GetWindowDC(0), avec comme coordonnées des nombres aléatoires.

Il neige dans un coin de l'écran (GetWindowDC de user32, Ellipse de gdi32, Sleep de kernel32

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub neige()
For num = 1 To 5000
xx = 500 * Rnd()
yy = (500 - xx) * Rnd()
diam = 10 * Rnd
Ellipse GetWindowDC(0), xx, yy, xx + diam, yy + diam
Sleep 1
Next
End Sub

GetWindowDC(0) renvoie le pointeur de la fenetre occupant tout l'écran.
La fonction Ellipse trace une ellipse sur la fenêtre dont le pointeur est retourné par GetWindowDC(0), avec comme coordonnées des nombres aléatoires.

La barre de menu clignote (GetActiveWindow et FlashWindow de user32)

Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub clignote()
For num = 1 To 50
Call FlashWindow(GetActiveWindow(), 1)
Sleep 100
Next
End Sub

La barre de menu clignote 10 fois par seconde.
La fonction FlashWindow est appliquée toutes 100 millisecondes au pointeur de la fenêtre active (renvoyé par GetActiveWindow()).

Tracer une courbe y=f(x) n'importe où sur l'écran (GetWindowDC de user32 et SetPixel de gdi32)

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetPixel Lib "gdi32" ( _
       ByVal hdc As Long, _
       ByVal x As Long, _
       ByVal y As Long, _
       ByVal crColor As Long) As Long

Sub courbe()
For xx = 1 To 800 Step 0.05
yy = 250 + 250 * Sin(xx / 50)
Call SetPixel(GetWindowDC(0), xx, yy, vbBlue)
Next
End Sub

Rien de plus simple pour tracer une courbe y=f(x) avec les API : on peut placer les points n'importe où sur l'écran avec SetPixel.
L'exemple trace une superbe sinusoïde bleue sur l'écran, sans se soucier des diverses barres et fenêtres.

Tracer une courbe paramétrique n'importe où sur l'écran (GetWindowDC de user32 et SetPixel de gdi32)

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SetPixel Lib "gdi32" ( _
       ByVal hdc As Long, _
       ByVal x As Long, _
       ByVal y As Long, _
       ByVal crColor As Long) As Long

Sub courbe_paramétrique()
For teta = 1 To 10000
xx = 250 + 250 * Cos(teta / 3)
yy = 255 + 250 * Sin(teta / 3.5)
Call SetPixel(GetWindowDC(0), xx, yy, vbRed)
Next
End Sub

Rien de plus simple pour tracer une courbe paramétrique avec les API : on peut placer les points n'importe où sur l'écran avec SetPixel.

Choisir un répertoire (SHBrowseForFolder et SHGetPathFromIDList de shell32)
En VBA, il est facile de faire choisir à l'utilisateur un fichier en affichant la boite de dialogue "Fichier / Ouvrir" avec GetOpenFileName (cliquez ici).
La procédure est assez mal adaptée aux cas où il faut faire choisir un répertoire à l'utilisateur.
La fonction API SHBrowseForFolder offre une bonne solution :

Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
     lParam As Long
    iImage As Long
End Type

Sub choisit_répertoire()
Dim zaza As String, brinf As BrowseInfo
dialg = SHBrowseForFolder(brinf) 'affiche la boite de dialogue
zaza = Space(200) 'crée un tampon zaza
SHGetPathFromIDList dialg, zaza 'charge le chemin dans le tampon
MsgBox Left(zaza, InStr(1, zaza, Chr(0)) - 1)
End Sub

Modifier le titre de la fenetre active (GetActiveWindow et SetWindowText de user32)

Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" ( _
ByVal hwnd As Long, _
ByVal lpString As String) As Long
Declare Function GetActiveWindow Lib "user32" () As Long

Sub change_titre()
SetWindowText GetActiveWindow(), "le nouveau titre"
End Sub

La macro change le texte du titre de le fenêtre Excel (fenetre active dont le pointeur est récupéré par GetActiveWindow()).

Réduire la fenetre active (GetActiveWindow et ShowWindow de user32)

Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Sub reduit_fenetre()
Call ShowWindow(GetActiveWindow(), 6)
End Sub

GetActiveWindow récupère le pointeur de la fenêtre active. ShowWindow, avec le paramètre nCmdShow fixé à 6, réduit la fenêtre à l'état d'icone.

Si le paramètre nCmdShow est fixé à 0, la fenêtre est completement cachée.
Les autres valeurs de nCmdShow sont 2 pour activer et réduire, 3 pour agrandir la fenetre, 5 pour afficher et activer la fenetre, 8 pour afficher la fenetre et 9 pour restaurer une fenetre réduite et l'activer.

La macro qui suit fait disparaitre la fenetre de Excel pendant 2 secondes avant de la faire réapparaitre :
pointeur = GetActiveWindow()
Call ShowWindow(pointeur, 0)
Application.Wait Now + 2 / 24 / 3600
Call ShowWindow(pointeur, 5)

En ouvrant VBE puis en lançant depuis une feuille Excel la macro
Call ShowWindow(GetActiveWindow(), 0),
on se retrouve avec un VBE sans objet Excel visible !

Pour masquer la fenêtre VBE, on peut utiliser
ShowWindow Application.VBE.MainWindow.hwnd, 0
(Application.VBE.MainWindow.hwnd renvoie le pointeur de la fenêtre VBE).
On peut au contraire l'afficher avec
ShowWindow Application.VBE.MainWindow.hwnd, 8

Donner le focus à une fenêtre (FindWindowA et SetFocus de user32)

Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Declare Function cherche_fenetre Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Sub fcs()
nom_fenetre = "Microsoft Excel - " & ThisWorkbook.Name
poign = cherche_fenetre(vbNullString, nom_fenetre)
SetFocus poign
End Sub

Utile notamment quand on veut utiliser SendKeys et éviter d'envoyer les commandes sur n'importe quelle fenêtre.

pour passer une fenêtre en premier plan (sans forcément lui donner le focus), on utilise SetForegroundWindow :
Declare Function cherche_fenetre Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
sub truc()
nom_fenetre = "Sans titre - Bloc-notes"
notepad = cherche_fenetre(vbNullString, nom_fenetre)
SetForegroundWindow (notepad)
end sub

Simuler la frappe d'une touche du clavier (FindWindowA, GetWindow, PostMessageA et SetForegroundWindow de user32)

Declare Function GetWindow Lib "user32" _ (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function cherche_fenetre Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100

Sub ecrire_dans_notepad()
'envoyer un message sur notepad
nom_fenetre = "Sans titre - Bloc-notes"
notepad = cherche_fenetre(vbNullString, nom_fenetre)
notepad = GetWindow(notepad, 5) 'se placer dans la fenetre du texte
txt = "BONJOUR TOUT LE MONDE"
For num = 1 To Len(txt)
PostMessage notepad, WM_KEYDOWN, Asc(Mid(txt, num, 1)), 0
Next
PostMessage notepad, WM_KEYDOWN, VK_RETURN, 0 'enter
SetForegroundWindow (notepad)
End Sub

La macro va rechercher le handle de la fenetre NotePad "sans-titre" et y inscrire un texte puis passer à la ligne. Ensuite seulement, elle affiche la fenêtre (pour voir la liste des touches, cliquez ici).
Cette technique remplace avantageusement SendKeys : elle évite d'envoyer par erreur des commandes sur une fenetre non visée, et elle permet d'envoyer des commandes sur une fenêtre qui n'est pas active.
(on aurait aussi pu utiliser SendMessage qui permet d'attendre que les commandes soient transmises avant de poursuivre le programme).

Il y a bien d'autres techniques, plus ou moins efficaces pour simuler la frappe d'une touche du clavier (cliquez ici).

Tracer un triangle sur l'écran (GetWindowDC de user32, MoveToEx et LineTo de gdi32

Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function MoveToEx Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    lpPoint As PT) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Type PT
    x As Long
    y As Long
End Type

Sub triangle()
Dim origine As PT
origine.x = 0
origine.y = 0
fen = GetWindowDC(0)
Call MoveToEx(fen, 200, 400, origine)
Call LineTo(fen, 400, 400)
Call LineTo(fen, 300, 250)
Call LineTo(fen, 200, 400)
End Sub

GetWindowDC(0) renvoie le pointeur de la fenêtre graphique en cours.
MoveToEx est utilisé pour positionner le point d'insertion graphique sur le premier sommet du triangle.
LineTo est utilisé pour tracer les côtés du triangle.

La fenetre active fait un petit tour et puis revient (GetActiveWindow, MoveWindow et GetWindowRect de user32)

Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function MoveWindow Lib "user32" ( _
     ByVal hwnd As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal nWidth As Long, _
     ByVal nHeight As Long, _
     ByVal bRepaint As Long) As Long
Declare Function GetWindowRect Lib "user32" ( _
     ByVal hwnd As Long, _
     lpRect As RECT) As Long
Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type

Sub un_ti_tour()
Dim rectangle As RECT
fen = GetActiveWindow()
Call GetWindowRect(fen, rectangle)
For num = 1 To 500
Call MoveWindow(fen, 200 + 200 * Sin(num * 6.28 / 500), 200 + 200 * Cos(num * 6.28 / 500), 500, 500, True)
Next
Call MoveWindow(fen, rectangle.Left, rectangle.Top, rectangle.Right - rectangle.Left, rectangle.Bottom - rectangle.Top, True)
End Sub

La fonction GetWindowRect permet d'enregistrer les coordonnées de la fenetre dans une variable de type RECT.
La fonction MoveWindow permet de redimensionner la fenetre et de la déplacer.
Après lui avoir fait décrire un cercle, on la remet dans sa position initiale en utilisant MoveWindow et les coordonnées stockées dans la variable de type RECT.

Ecrire n'importe où sur l'écran (GetDC de user32 et TextOut de gdi32)

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" ( _
     ByVal hdc As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal lpString As String, _
     ByVal nCount As Long) As Long
Sub ecriture()
txt = "j'écris n'importe où"
Call TextOut(GetDC(0), 100, 30, txt, Len(txt))
End Sub

GetDC(0) renvoie le pointeur de la sortie graphique de la fenêtre (incluant les barres d'outils et de menus).
TextOut(GetDC(0), 100, 30, txt, Len(txt)) va écrire le texte txt en partant du point de coordonnées 100, 300 (coordonnées en pixel).

Ecrire en couleur n'importe où sur l'écran (GetDC de user32, TextOut, SetTextColor et SetBkMode de gdi32)

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function TextOut Lib "gdi32" Alias "TextOutA" ( _
     ByVal hdc As Long, _
     ByVal x As Long, _
     ByVal y As Long, _
     ByVal lpString As String, _
     ByVal nCount As Long) As Long
Declare Function SetTextColor Lib "gdi32" ( _
     ByVal hdc As Long, _
     ByVal crColor As Long) As Long
Declare Function SetBkMode Lib "gdi32" ( _
     ByVal hdc As Long, _
     ByVal nBkMode As Long) As Long

Sub ecriture_en_bleu_sur_fond_transparent()
fen = GetDC(0)
Call SetBkMode(fen, 1)
Call SetTextColor(fen, vbBlue)
txt = "j'écris en couleur"
Call TextOut(fen, 100, 30, txt, Len(txt))
End Sub

GetDC(0) renvoie le pointeur de la sortie graphique de la fenêtre (incluant les barres d'outils et de menus).
TextOut(GetDC(0), 100, 30, txt, Len(txt)) va écrire le texte txt en partant du point de coordonnées 100, 300 (coordonnées en pixel).
SetBkMode(fen,1) permet de préciser que l'on souhaite écrire avec un fond transparent. On aurait pu utiliser SetBkColor(fen, vbYellow) pour écrire sur fond jaune.
SetTextColor permet de préciser la couleur d'écriture.

Changer de curseur de souris (SetSystemCursor et LoadCursor de user32)

Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long

Sub change_curseur()
Call SetSystemCursor(LoadCursor(0, 32514), 32512)
Call SetSystemCursor(LoadCursor(0, 32515), 32513)
End Sub

LoadCursor(0,32514) va charger le curseur n°32514 (curseur prédéfini en forme de sablier).
SetSystemCursor(LoadCursor(0, 32514), 32512) va remplacer le curseur système qui est habituellement en forme de flèche (32512) par le nouveau curseur LoadCursor(0,32514) en forme de sablier.
De même, SetSystemCursor(LoadCursor(0, 32515), 32513) va remplacer le curseur système qui est habituellement en forme de I (curseur de texte 32513) par un curseur en forme de croix (32515).

Ne pas oublier de restaurer la situation initiale par :
Sub restaure()
Call SetSystemCursor(LoadCursor(0, 32512), 32512)
Call SetSystemCursor(LoadCursor(0, 32513), 32513)
End Sub

De nombreuses formes de curseurs sont disponibles :
32512 flèche
32513 curseur en I
32514 sablier
32515 croix
32516 flèche vers le haut
32640, 32642, 32643, 32644, 32645, 32646 doubles flèches de redimensionnement
32648 stationnement interdit
32650 flèche + sablier

Changer de curseur de souris à partir d'un fichier de curseur (SetSystemCursor et LoadCursorFromFile de user32)

Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long

Sub change_curseur()
Call SetSystemCursor(LoadCursorFromFile("c:\windows\cursors\appstart.ani"), 32513)
End Sub

LoadCursorFromFile("c:\windows\cursors\appstart.ani") va charger le curseur qui est enregistré dans le fichier appstart.ani.
SetSystemCursor(LoadCursorFromFile("c:\windows\cursors\appstart.ani"), 32513) va remplacer le curseur système qui est habituellement en forme de flèche (32512) par le nouveau curseur LoadCursorFromFile("c:\windows\cursors\appstart.ani").
On aurait évidemment pu faire la même chose sur le curseur système qui est habituellement en forme de I (curseur de texte 32513).

Ne pas oublier de restaurer la situation initiale par :
Sub restaure()
Call SetSystemCursor(LoadCursor(0, 32512), 32512)
End Sub

Envoyer un fichier sur votre site Web par ftp (InternetConnect, InternetOpen, FtpSetCurrentDirectory et FtpPutFile de wininet
(voir aussi le logiciel de transfert FTP sous Excel)

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
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
Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
     "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
     ByVal lpszDirectory As String) As Boolean
Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" ( _
     ByVal hFtpSession As Long, _
     ByVal lpszLocalFile As String, _
     ByVal lpszRemoteFile As String, _
     ByVal dwFlags As Long, _
     ByVal dwContext As Long) As Boolean

Sub envoie_fichier()
internet_ok = InternetOpen("", 1, "", "", 0)
If internet_ok Then
ftp_ok = InternetConnect(internet_ok, "ftpperso.free.fr", 21, "zaza", "mdp_miaou", 1, 0, 0)
If FtpSetCurrentDirectory(ftp_ok, "/") Then
succès = FtpPutFile(ftp_ok, "c:\rien.xls", "rien2.xls", 1, 0)
End If
End If
If succès Then MsgBox ("le fichier a été transféré")
End Sub

InternetOpen ouvre une session Internet
InternetConnect(internet_ok, "ftpperso.free.fr", 21, "zaza", "mdp_miaou", 1, 0, 0) établit la connexion avec le serveur ftpperso.free.fr en utilisant le port 21 avec le login zaza et le mot de passe mdp_miaou.
FtpSetCurrentDirectory(ftp_ok, "/") sélectionne la racine du site sur le serveur,
FtpPutFile(ftp_ok, "c:\rien.xls", "rien2.xls", 1, 0) envoie le fichier rien.xls depuis c:\ vers le répertoire sélectionné sur le serveur, en lui donnant le nom rien2.xls.

Sur cette base, on peut automatiser facilement sous Excel / VBA la mise à jour de sites internet. Cliquez ICI pour télécharger un logiciel de transfert FTP sous Excel (transfert d'une sélection de fichiers, ou bien de tous les fichiers d'un même répertoire répondant à certains critères, examen des fichiers d'un répertoire distant avec leur date de dernière modification...).

>>> voir les exemples suivants >>>>

- Les API
- Les correspondances entre macros VBA, macros Excel 4, fonctions de feuilles de calcul et API.