Exemples de fonctions API, suite (2)

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

Une fonction qui renvoie l'adresse de la cellule survolée par le curseur de la souris (GetWindow, FindWindow, GetClassName, GetWindowRect et GetCursorPos de user32)

Recopier dans un module standard, le texte de la fonction ci-dessous (tout le texte vert).
Dans une page Excel, masquer les entêtes de lignes et colonnes.
Inscrire dans une cellule : =pos_souris().
Déplacer le curseur de la souris sans cliquer.
Taper la touche F9 pour actualiser.
La fonction pos_souris() renvoie l'adresse de la cellule survolée par la souris.

Plutôt que de recopier la fonction, vous pouvez la télécharger (fichier Excel zippé, 13 ko) en cliquant ici.

Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINT_) As Long
Type POINT_
      X As Long
      Y As Long
End Type
Type RECT
      Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
Dim point As POINT_
Dim coord As RECT
Dim nomclasse As String * 200

Function pos_souris()
Application.Volatile
'recherche de la fenetre de la page active
     pointeur = FindWindow("XLMAIN", vbNullString)
     pointeur = GetWindow(pointeur, 5)
     Do
     GetClassName pointeur, nomclasse, 250
     If LCase(Left(nomclasse, 6)) = "xldesk" Then Exit Do
     pointeur = GetWindow(pointeur, 2)
     Loop
'recherche de la position et taille de la fenetre
     Call GetWindowRect(pointeur, coord)
     échx = Application.UsableWidth / (coord.Right - coord.Left)
     échy = Application.UsableHeight / (coord.Bottom - coord.Top)
'recherche de la position du curseur en points
      GetCursorPos point
     xpt = (point.X - coord.Left) * échx
     ypt = (point.Y - coord.Top) * échy
'position en lignes colonnes
     lin = 0
     col = 0
     encorey:
     lin = lin + 1
     If ypt > Cells(lin + 1, 1).Top - Cells(ActiveWindow.ScrollRow, 1).Top Then GoTo encorey
     encorex:
     col = col + 1
     If xpt > Cells(1, col + 1).Left - Cells(1, ActiveWindow.ScrollColumn).Left Then GoTo encorex
'résultat
     pos_souris = Cells(lin, col).Address
End Function

Application.Volatile permet à la fonction de se mettre à jour au moment des recalculs (ou en tapant la touche F9).
Les lignes suivantes ("recherche de la fenêtre de la page active") permettent d'accéder au pointeur de la zone utile de la page de calcul en cours (recherche du pointeur de la fenêtre de l'application Excel, puis accès à la sous-fenêtre par pointeur = GetWindow(pointeur, 2)).
Les lignes "recherche de la position et taille de la fenetre" récupèrent les coordonnées en pixel de la fenêtre et déterminent les coefficients de conversion pixel / points.
GetCursorPos point permet de récupérer les coordonnées du curseur de la souris (en pixel).
Il suffit alors de comparer ces coordonnées (après conversion en points) avec celles des lignes et colonnes de la page Excel (Cells(...).Top et .Left) pour pouvoir déterminer l'adresse de la cellule survolée par le curseur de la souris.

Ouvrir et fermer les fenêtres de manière originale (GetActiveWindow et AnimateWindow de user32)

Declare Function AnimateWindow Lib "user32" ( _
     ByVal hwnd As Long, _
     ByVal dwTime As Long, _
     ByVal dwFlags As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long

Sub par_le_centre()
Sheets(1).Activate
fen = GetActiveWindow()
Call AnimateWindow(fen, 500, &H10 Or &H10000)
Call AnimateWindow(fen, 500, &H10 Or &H20000)
End Sub

Sub haut_bas_cotes()
Sheets(1).Activate
fen = GetActiveWindow()
Call AnimateWindow(fen, 500, &H4 Or &H10000)
Call AnimateWindow(fen, 500, &H2 Or &H20000)
Call AnimateWindow(fen, 500, &H8 Or &H10000)
Call AnimateWindow(fen, 500, &H1 Or &H20000)
End Sub

Selon les paramètres, la fonction AnimateWindow masque (&H10000) ou affiche (&H20000) la fenêtre avec des effets spéciaux (par le centre &H10, de droite à gauche, de haut en bas et inversement).

Masquer la barre des tâches (GetWindowRect, FindWindowA, FillRect, GetWindowDC et GetSysColorBrush de user32)

Declare Function cherche_fen Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type

Sub cache_barre_des_taches()
Dim coord As RECT
Call GetWindowRect(cherche_fen("Shell_TrayWnd", vbNullString), coord)
Call FillRect(GetWindowDC(0), coord, GetSysColorBrush(0))
End Sub

FindWindowA, renommée pour l'occasion cherche_fen, va chercher la fenêtre de classe "Shell_TrayWnd", c'est à dire la barre des tâches Windows.
Avec GetWindowRect on va pouvoir en déterminer les coordonnées.
Puis on remplit le rectangle ayant ces coordonnées par FillRect avec la couleur de fond de Window c'est à dire GetSysColorBrush(0).
Pas de panique, la barre des tàches disparait, mais elle n'est pas perdue.
Il suffit de passer la souris sur les icônes masquées pour les voir réapparaitre.
Et d'appuyer sur la touche Windows pour récupérer le bouton "Démarrer".

Modifier l'adresse dans la barre d'adresse du navigateur (EnumChildWindows, GetClassNameA, FindWindowA et PostMessageA de user32
La macro cherche dans les sous-fenêtres d'Internet Explorer une zone Edit (qui correspond à la barre d'adresses), et en modifie le texte :

Declare Function EnumChildWindows Lib "user32"
     (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
      (ByVal hwnd As Long, ByVal lpClassName As String, _
      ByVal nMaxCount 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

Function classe(pointeur) As String 'classe de la fenetre
classe = String(100, Chr$(0))
GetClassName pointeur, classe, 100
classe = Left$(classe, InStr(classe, Chr$(0)) - 1)
End Function

Function change_adresse(ByVal fen As Long, ByVal lParam As Long) As Long
If classe(fen) = "Edit" Then
For num = 1 To 50
PostMessage fen, &H100, &H8, 0 '(efface le texte)
Next
txt = "le site que je prefere"
For num = 1 To Len(txt)
PostMessage fen, &H100, Asc(Mid(UCase(txt), num, 1)), 0 '(inscrit le nouveau texte)
Next
End If
change_adresse = 1
End Function

Sub modifie_site()
titre_fen = "Formation Excel - Microsoft Internet Explorer"
pg = cherche_fenetre(vbNullString, titre_fen)
EnumChildWindows pg, AddressOf change_adresse, ByVal 0&
End Sub

On peut aussi ouvrir directement une page avec l'adresse modifiée en remplacant la macro "modifie_site" par "ouvre_site :

Sub ouvre_site()
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate ("http://jacxl.free.fr")
EnumChildWindows ie.hwnd, AddressOf change_adresse, ByVal 0&
End Sub

ATTENTION La macro utilise la fonction AdressOf qui n'est pas supportée par les versions d'Excel antérieures à la version Excel 2000.
Pour Excel 97, il faut complèter la macro : cliquez ici.

Le texte qui est dans le presse-papiers ? (OpenClipboard, GetClipboardData, CloseClipboard et GetWindow de user32 et CopyMemory de kernel32)

Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, pSrc As Long, ByVal ByteLen As Long)

Sub texte_du_pressepapiers()
Dim zaza As String * 5000
Dim données As Long
OpenClipboard GetWindow(0, 0)
données = GetClipboardData(1)
If données <> 0 Then
CopyMemory ByVal zaza, ByVal données, 5000
MsgBox Left(zaza, InStr(1, zaza, Chr(0)) - 1)
Else
MsgBox "il n'y a pas de texte dans le presse-papiers"
End If
CloseClipboard
End Sub

zaza est un tampon (buffer) de texte de 5000 caractères dans lequel on vient placer (grace aux fonctions GetClipboardData puis CopyMemory) les données texte (paramètre 1 passé à la fonction GetClipboardData) que peut contenir le presse-papiers (préalablement ouvert par la fonction OpenClipboard).
Attention, la macro ne va récupérer que les données que le presse-papiers identifie comme du texte (une cellule Excel n'est pas du texte; par contre si on rentre dans la cellule et qu'on copie le contenu, on a bien du texte).

L'impression est-elle terminée ? (GetProfileStringA de kernel32, OpenPrinterA, ClosePrinter et EnumJobsA de winspool.drv)

Utile notammeent quand on pilote à partir d'Excel l'impression d'une autre application et qu'on a besoin d'attendre la fin de l'impression avant de fermer cette application.

Private Declare Function GetProfileString Lib "kernel32.dll" _
      Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, _
      ByVal lpDefault As String, ByVal lpReturnedString As String, _
      ByVal nSize As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA"_
      (ByVal pPrinterName As String, phPrinter As Long, pDefault As Any) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" _
      (ByVal hPrinter As Long) As Long
Private Declare Function EnumJobs Lib "winspool.drv" _
      Alias "EnumJobsA" (ByVal hPrinter As Long, ByVal FirstJob As Long, _
      ByVal NoJobs As Long, ByVal Level As Long, pJob As Any, ByVal cdBuf As Long, _
      pcbNeeded As Long, pcReturned As Long) As Long

Function printfini()
Dim nimpr As String * 254
Dim imprimante As Long, zaza As Long, toto As Long
GetProfileString "windows", "device", ",,,", nimpr, 254
nom_imprimante = Left(nimpr, InStr(nimpr, ",") - 1)
OpenPrinter nom_imprimante, imprimante, ByVal 0&
zaza = 0
EnumJobs imprimante, 0, 99, 1, ByVal 0&, 0, zaza, toto
ClosePrinter imprimante
printfini = True
If zaza > 0 Then printfini = False
End Function

GetProfileString "windows", "device", ",,,", nimpr, 254 envoie dans le buffer nimpr le nom de l'imprimante.
OpenPrinter nom_imprimante, imprimante, ByVal 0& récupère, dans la variable "imprimante", le handle correspondant à l'imprimante. On aurait aussi bien pu écrire directement le nom de l'imprimante s'il n'est pas susceptible de changer :
OpenPrinter "HP DeskJet 710C", imprimante, ByVal 0&
EnumJobs imprimante, 0, 99, 1, ByVal 0&, 0, zaza, toto va placer dans zaza la taille du fichier restant à imprimer.
Si zaza n'est pas nul, il reste quelque chose dans la file d'attente de l'imprimante.

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