cliché de l'userform

[patricktoulon]

bonjour


dans la ligné de mon cliché de cellules,graphique instantané

je vous propose aujourdh'ui le cliché de l 'userform

simulation de l'appui sur la touche "imprim" (on trouve ca dans la faq)
recuperation du cliché dans le presse papier
construction du bitmap
sauvegarde du fichier image sous le nom de "capture de l'userform "avec la date du jour
une boite de dialogue vous laisse le choix de la destination

le code est commenté

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
 
 
Option Explicit
 
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Public Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare Function CloseClipboard& Lib "user32" ()
Public Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
 
 
Public Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(8) As Byte
End Type
 
Public Type PICTDESC
  cbSize As Long
  picType As Long
  hImage As Long
End Type
 
Public iPic As IPicture
Public mode As Long
Public handle As Long
Dim nom As Variant
Dim madate As String
 
Sub cliché_de_l_userform(uf As Object)
madate = Format(Date, "dd-mm-yyyy")
 'on identifie le pointeur de l'userform
handle = FindWindow(vbNullString, uf.Caption)
'on met en premier plan le userform au cas ou il y en ai plusieur pour eviter les erreurs  et on lui donne le focus
SetFocus handle
Set iPic = Nothing 'on vide la variable au cas ou il y aurais une precedante
  'Copie d'écran de la forme active en simulant la touche "imprim" le cliché va se retrouver dans le presse papier
    keybd_event vbKeySnapshot, 1, 0&, 0&
    DoEvents
 
  'on copie l'image du presse papier
Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H8)
'on ferme le presse papier
CloseClipboard
'si il y a rien on sort de la sub
       If hCopy = 0 Then Exit Sub
'on construit le bitmap
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
  With tPICTDEST
  .cbSize = Len(tPICTDEST)
  .picType = 1
  .hImage = hCopy
  End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
         If Ret Then Exit Sub
 
nom = Application.GetSaveAsFilename("capture de l'" & uf.Name & " du " & madate, "Fichier JPEG (*.JPG),*.JPG,Tous fichiers (*.*),*.*")
 
'Intercepte l'utilisation du bouton "Annuler" et la croix de fermeture de la fenetre de dialog  save as
If VarType(nom) = vbBoolean Then 'si c 'est false
Set iPic = Nothing 'on vide la variable de ipic
EmptyClipboard ' on vide le presse papier
 
Else
 
' on le sauve en jpg
SavePicture iPic, nom
'on vide la variable
Set iPic = Nothing
End If
End Sub

le code dans le userform pour appeler la macro
exemple avec un bouton:

Code :

1
2
3
4
 
Private Sub CommandButton1_Click()
cliché_de_l_userform Me
End Sub

si vous appellez la macro ailleur que dans le userform
exemple:

Code :

1
2
3
4
 
 Sub cliche_usf()
cliché_de_l_userform "le nom de l'userform" 'ne pas oublier les guillemet
End Sub

meme au momment de l'appel si le userform n'a pas le focus la macro se charge de lui donner



bonne utilisation

au plaisir