patricktoulon
XLDnaute Barbatruc
bonjour a tous
confinement oblige je fait mumuse
voudriez vous bien tester ceci
toujours dans le theme de l'utilisation des api (au black) sans déclaration
j'ai repris mon partOffScreenSnapshoteur
je voudrais savoir si ca fonctionne en 64 bits
ouvrir un nouveau fichier
ajouter un userform et lui mettre le backcolor de la couleur qui vous plaira
nommer ce userform SnapForm
et c'est tout (pas de contrôles ou quoi qu'est ce ,rien)
dans le module de ce userform mettre ce code
le mode d'emploi est simple il est expliqué en commentaires
merci d'avance pour les retours
confinement oblige je fait mumuse
voudriez vous bien tester ceci
toujours dans le theme de l'utilisation des api (au black) sans déclaration
j'ai repris mon partOffScreenSnapshoteur
je voudrais savoir si ca fonctionne en 64 bits
ouvrir un nouveau fichier
ajouter un userform et lui mettre le backcolor de la couleur qui vous plaira
nommer ce userform SnapForm
et c'est tout (pas de contrôles ou quoi qu'est ce ,rien)
dans le module de ce userform mettre ce code
le mode d'emploi est simple il est expliqué en commentaires
VB:
'**************************************************************************************************
' COLLECTION UTILISATION DES API AVEC ExecuteExcel4Macro EPISODE 23
' ---------------------------------------------
' |SnapForm pour capturer une portion de l’écran|
' ---------------------------------------------
'Auteur: patricktoulon sur exceldownload
'version 1.0
'---------------------------------------------
'mode d'emploi:
'pour l'appeler de n'importe quel module:
'exemple: SnapForm.GetCapture' a pour effet d'afficher le carré transparent(rouge)
'pour le redimensionner
' avec la souris vers les angles ou les cotés en restant appuyé avec le bouton 1 de la souris comme une fenetre classique
'le mouse pointer(cursor) vous indique quand le bord est accrochable
' pour le déplacer
'avec la souris en restant appuyé vers le centre du carré avec le bouton 1 de la souris
' pour capturer
'click droit dessus (ouvre la boite de dialogue "enregistrer sous")
'taper le nom dans le dialogue ou laisser celui par défaut et voila c'est capturé et enregistré
'**************************************************************************************************
Option Explicit
Public Function GetCapture()
Me.Show
End Function
'restructuration et transparence de l'userform
Private Sub UserForm_Activate()
Dim hwnd&
hwnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")")
ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hwnd & ", " & -16 & ", " & &H94080080 & ")") 'api SetWindowLongA
ExecuteExcel4Macro ("CALL(""user32"",""DrawMenuBar"",""JJJJJJ"", " & hwnd & ")")
'Rajoute l'attribut transparent à la fenêtre..
ExecuteExcel4Macro ("CALL(""user32"",""SetWindowLongA"",""JJJJJ""," & hwnd & ", " & -20 & ", " & &H80000 & ")") 'api SetWindowLongA
'125 = Taux de transparence de 0 à 255
ExecuteExcel4Macro ("CALL(""user32"",""SetLayeredWindowAttributes"",""JJJJJ"",""" & hwnd & """,""" & 0 & """,""" & 40 & """,""" & &H2 & """)")
End Sub
'prise de capture avec le click droit de la souris
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim hwnd&, fichier As Variant, shp As Shape
If Button = 2 Then
hwnd = ExecuteExcel4Macro("CALL(""user32"",""GetActiveWindow"",""JCC"")") 'api GetActiveWindow
ExecuteExcel4Macro ("CALL(""user32"",""SetLayeredWindowAttributes"",""JJJJJ"",""" & hwnd & """,""" & 0 & """,""" & 0 & """,""" & &H2 & """)")
ExecuteExcel4Macro ("CALL(""user32"",""keybd_event"",""JJJJJ""," & 44 & ", " & 1 & ", " & 0 & ", " & 0 & ")") 'api SetWindowLongA
ExecuteExcel4Macro ("CALL(""user32"",""keybd_event"",""JJJJJ""," & 44 & ", " & 1 & ", " & &H2 & ", " & 0 & ")") 'api SetWindowLongA
ChDir (Environ("userprofile") & "\DeskTop")
fichier = Application.GetSaveAsFilename(CurDir & "\" & "Captured_By_SnapForm", filefilter:="image Files (*.jpg;*.gif), *.jpg;*.gif", Title:="ENREGISTREMENT DE LA CAPTURE")
If fichier = False Then Unload Me: Exit Sub
Me.Hide: ActiveSheet.Paste
With ActiveSheet
Set shp = .Shapes(.Shapes.Count)
With .ChartObjects.Add(shp.Left + 200, shp.Top, shp.Width, shp.Height)
.Chart.Paste: .Chart.Export Filename:=fichier & ".jpg", FilterName:="jpg"
.Delete
shp.Delete
End With
End With
Unload Me
End If
End Sub
'deplacement et deformation sans api
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Static xx#
Static yy#
Dim mp As Variant, H$, Coté$
If Y < 10 Then H = "H" Else H = "M"
If Y > Me.InsideHeight - 10 Then H = "B"
If X < 10 Then Coté = "G" Else Coté = "M"
If X > Me.InsideWidth - 10 Then Coté = "D"
mp = H & Coté
mp = Switch(mp = "HG", 8, mp = "BD", 8, mp = "HD", 6, mp = "BG", 6, mp = "HM", 7, mp = "BM", 7, mp = "MM", 0, mp = "MG", 9, mp = "MD", 9)
If Me.MousePointer <> mp Then Me.MousePointer = mp
If Button = 1 Then
xx = IIf(xx = 0, X, xx): yy = IIf(yy = 0, Y, yy)
Select Case H & Coté
Case "MM": Me.Move Me.Left + (X - xx), Me.Top + (Y - yy): Exit Sub
Case "HG": Me.Width = Me.Width - (X - xx): Me.Left = Me.Left + (X - xx): Me.Height = Me.Height - (Y - yy): Me.Top = Me.Top + (Y - yy)
Case "MG": Me.Width = Me.Width - (X - xx): Me.Left = Me.Left + (X - xx)
Case "BG": Me.Width = Me.Width - (X - xx): Me.Left = Me.Left + (X - xx): Me.Height = Y + 5
Case "HD": Me.Width = X + 5: Me.Height = Me.Height - Y + 5: Me.Top = Me.Top + (Y - 5)
Case "MD": Me.Width = X + 5
Case "BD": Me.Width = X + 5: Me.Height = Y + 5
Case "HM": Me.Height = (Me.Height - Y): Me.Top = Me.Top + Y
Case "BM": Me.Height = Y + 5
End Select
Else
xx = 0: yy = 0
End If
End Submerci d'avance pour les retours
