Private Static Sub BtPaint_Click()
Const PgmPaint = "C:\WINDOWS\System32\MSPaint"
Dim PaintId As Variant, Z As String, Top As Long, Problème As String
Caption = "Couleurs - Transmettre à Paint"
Z = ""
Do:
If IsEmpty(PaintId) Then
PaintId = InputBox(Z & "Entrez le titre exact d'une fenêtre Paint existante," _
& vbLf & "sinon Couleurs va tenter de lancer :" & vbLf & """" & PgmPaint & """.", _
Caption, "Sans titre - Paint"): Z = ""
If PaintId = "" Then
On Error Resume Next: PaintId = Shell(PgmPaint, 1): Problème = Err.Description: On Error GoTo 0
If Problème <> "" Then
MsgBox "Shell """ & PgmPaint & """: " & Problème & vbLf _
& "Veuillez lancer Paint par vous-même.", vbCritical, Caption
PaintId = Empty: GoTo Épilogue: End If
Z = "MSPaint N°" & PaintId & " lancé…": End If: End If
Top = GetTickCount
While GetTickCount < Top + 1000: DoEvents
On Error Resume Next: AppActivate PaintId, Wait:=False: Problème = Err.Description: On Error GoTo 0
If Problème = "" Then Exit Do
Wend
If TypeName(PaintId) = "String" Then Z = "Fenêtre """ & PaintId & """" Else Z = "MSPaint N°" & PaintId
Z = Z & " introuvable." & vbLf: PaintId = Empty
Loop
SendKeys "%CM%D%R" & TR.Text & "%V" & TV.Text & "%B" & TB.Text & "~", Wait:=True
Épilogue: Caption = "Couleurs"
End Sub