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
| Option Explicit
'application des modification
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'trouver le handle
Private Declare Function fwa Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'on redessine la barre sinon elle se retrouve en bas de l'userform
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
'capturer le handle et pouvoir le deplacer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
'api pour capture basic
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Dim handle
Dim handleApp
Dim otherhandle
Dim LW
Dim plan
Private Sub UserForm_Activate()
Me.BackColor = vbRed
handle = fwa(vbNullString, Me.Caption)
handleApp = Application.hwnd
SetParent handle, GetDesktopWindow()
SetWindowPos handleApp, 1, 0&, 0&, 0&, 0&, (&H10 Or &H40 Or &H1 Or &H2) 'force l'userform au premier plan
SetWindowLongA handle, -16, &H140F0101: DrawMenuBar handle ' sans caption cadre epais coin arrondi et elastique
SetWindowLongA handle, -20, &H80109 'Rajoute l'attribut transparent à la fenêtre.
SetLayeredWindowAttributes handle, 0, 60, &H2 'application de la transparence de 0 a 255 ici 60
LW = Round(Me.Height - Me.InsideHeight) 'recupération de l epaisseur du cadre
SetWindowPos handle, -1, 0&, 0&, 0&, 0&, (&H1 Or &H2) 'force l'userform au premier plan
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Unload Me
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim hPicAvail, fname, chemin$
If Button = 1 Then
ReleaseCapture
SendMessage handle, &HA1, 2, 0&
Else
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With
SetWindowLongA handle, -16, &H94080080: SetWindowLongA handle, -20, &H0: DrawMenuBar handle ' sans caption
SetWindowLongA handle, -20, &H80109
SetLayeredWindowAttributes handle, 0, 0, &H2
Me.Move Me.Left + (LW / 2), Me.Top + (LW / 2), Me.Width - (LW), Me.Height - (LW)
SetWindowPos handle, -1, 0&, 0&, 0&, 0&, (&H1 Or &H2) 'force l'userform au premier plan
'SetParent handle, GetDesktopWindow()
keybd_event &H2C, 1, 0, 0: keybd_event &H2C, 1, &H2, 0 'on appuie et on relache la touche snapshot
'on va boucler tant que le contenu du clipboard n'est pas BITMAP soit (2) le temps necessaire a ce que
'la touche print excecute sa tache et envoie les informations au clipboard
Do: DoEvents: hPicAvail = IsClipboardFormatAvailable(2): Loop While hPicAvail = 0 'Or (Timer - T) > 1000
If Me.Tag <> "" Then
fname = Application.GetSaveAsFilename(InitialFileName:=Environ("userprofile") & "\Desktop", filefilter:="image Files (*.jpg), *.jpg", Title:="ENREGISTREMENT DE LA CAPTURE")
If fname <> False Then chemin = fname Else Exit Sub
Else
chemin = Environ("userprofile") & "\Desktop\capture.jpg"
End If
'crée un graphique
With ActiveSheet.ChartObjects.Add(0, 0, Me.Width, Me.Height)
.Chart.Paste: .Chart.Export chemin, "jpg" 'colle l'image dans graphique puis exportation le graphique en image jog
.Delete
End With
'ActiveSheet.Paste
Unload Me
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If GetActiveWindow() <> handleApp Then otherhandle = GetActiveWindow()
End Sub |
Partager