Sauvegarder directement vos captures lors de l'appui sur 'impr ecran'

Télécharger le projet
Commenter

Description

Le programme est ultra-simple à prendre en main si vous vous y connaissez déjà en VB. Pour ceux qui débute, il n'y a pas de grande difficulté à comprendre le code.
Vous pourrez facilement le développer et l'améliorer.
C'est une entrée en matière quant à l'utilisation des API. Egalement le code montre comment ajouter une icône dans la barre système (à côté de l'heure) et interargir avec...

MAJ du 08/12/2003
Suite aux pertinentes remarques que j'ai eut, j'ai modifié la source de manière à ce qu'elle n'occupe pas inutilement le processeur.
J'ai aussi fait quelques modif. et j'ai monté du coup le niveau de la source à 'Initié', mais il n'y a pas de difficulté majeure.
Pour l'instant, les source ne sont pas encore vraiment commentée, je les mettrai la prochaine fois, quand j'aurai finit ce que je veux faire mais que j'arrive pas à faire :)
J'ai rajouté une fonctionnalité : si vous appuyez sur Control + Impr Ecran, vous pourrez 'admirer' la capture d'écran que vous venez de faire.

so long !

Source / Exemple : 


'extraite du code, le reste dans le zip :)

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Type MSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const VK_SNAPSHOT = &H3112
Private Const VK_SNAPSHOT2 = &H3113
Private Const PM_REMOVE = &H1
Private Const WM_HOTKEY = &H312

Public Event Capture(ByVal path As String, ByVal Control As Integer)

Private SavPATH_ As String
Private SrcFRM_ As Form
Private Arreter_ As Boolean
Private Touche_ As KeyCodeConstants

Public Actif As Boolean

Public Sub LancerService()
Dim Mess As MSG
    Arreter_ = False
    Actif = True
    Do
        WaitMessage
        If Actif Then If PeekMessage(Mess, 0, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then Sauver_Image
        DoEvents
    Loop Until Arreter_
End Sub

Public Sub ArreterService()
    Actif = False
    Arreter_ = True
    'Attention, si vous arrêtez le service, et que vous le redémarrer, il y aura un problème avec
    'l'icône dans la barre des tâches qui ne répondra plus.
    'Pour qu'il n'y ait pas de problème, il faudrait faire un Thread ou lancer la boucle de
    'récupération des messages comme un service géré par Windows.
    'Pour mettre en pause, il faut utiliser la propriété 'Actif'
End Sub

Private Sub Sauver_Image()
Dim numero As String, fichier As String
Dim SrcDC As Long
Dim CtrlKey As Integer

    CtrlKey = GetKeyState(vbKeyControl)
    
    numero = Format(Now, "dddd dd mmmm YY - HHmmSS")
    
    SrcDC = GetDC(GetDesktopWindow())
    StretchBlt SrcFRM_.hdc, 0, 0, Screen.Width, Screen.Height, SrcDC, 0, 0, Screen.Width, Screen.Height, vbSrcCopy
    fichier = SavPATH_ & numero & ".bmp"
    SavePicture SrcFRM_.Image, fichier
    
    If CtrlKey < 0 Then ShellExecute 0&, "open", fichier, "", SavPATH_, vbNormalFocus
    
    RaiseEvent Capture(fichier, CtrlKey)
    
End Sub

Private Sub Class_Initialize()
    SavPATH_ = IIf(Len(App.path) = 3, App.path, App.path & "\")
    Touche = vbKeySnapshot
End Sub

Private Sub Class_Terminate()
    Actif = False
    Arreter_ = True
    UnregisterHotKey 0, VK_SNAPSHOT
    UnregisterHotKey 0, VK_SNAPSHOT2
End Sub

Public Property Get SrcFRM() As Form:   Set SrcFRM = SrcFRM_:   End Property
Public Property Let SrcFRM(ByVal vNewValue As Form)
    Set SrcFRM_ = vNewValue
    SrcFRM_.AutoRedraw = True
End Property

Public Property Get Dossier() As String:    Dossier = SavPATH_:     End Property
Public Property Let Dossier(ByVal vNewValue As String)
    If Not Mid(vNewValue, Len(vNewValue), 1) = "\" Then vNewValue = vNewValue & "\"
    SavPATH_ = IIf(Dir$(vNewValue), vNewValue, IIf(Len(App.path) = 3, App.path, App.path & "\"))
End Property

Public Property Get EnCours() As Boolean: EnCours = Not Arreter_: End Property

Public Property Get Touche() As KeyCodeConstants:   Touche = Touche_:   End Property
Public Property Let Touche(ByVal vNewValue As KeyCodeConstants)
    Touche_ = vNewValue
    RegisterHotKey 0, VK_SNAPSHOT, &H0, Touche_
    RegisterHotKey 0, VK_SNAPSHOT2, MOD_CONTROL, Touche_
End Property

Conclusion :


bonne prog !
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_nessi)