Faire une capture écran, redimensionner et l'enregistrerRésolu

Question

Bonjour tout le monde, 

Je travaille en VB Excel 2003 (niveau débutant) et comme le titre l'indique je souhaite réaliser une capture écran d'un formulaire, redimmensionner cette capture et l'enregistrer dans un dossier. 

Merci d'avance pour vos conseils!

cs_Le Pivert · Accepted Answer

Bonjour,
Esaie ceci:

Option Explicit
Private Declare Sub keybd_event Lib "user32" ( _
    ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long)
Private Sub CommandButton1_Click()
Dim monImage As String
Dim Sh As Shape
'Définit le nom et le lieu de stockage de l'image
 monImage = ActiveWorkbook.Path & "\monimage" & ".jpg"
 keybd_event vbKeySnapshot, 1, 0&, 0&
    DoEvents
    Range("A1").Select
    ActiveSheet.Paste
    'on rogne l'image: à toi de régler suivant ta convenance à l'aide de l'enregistreur de macro
    With Selection
      .ShapeRange.ScaleWidth 0.68, msoFalse, msoScaleFromTopLeft
      .ShapeRange.ScaleHeight 0.68, msoFalse, msoScaleFromTopLeft
     End With
     'Récupère la dernière forme de la feuille
    Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    'Colle l'image dans un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
        .Paste
        'Sauvegarde l'image du graphique au format jpg
        .Export monImage, "JPG"
    End With
    'Supprime le graphique et la forme.
    With ActiveSheet
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .Shapes(ActiveSheet.Shapes.Count).Delete
    End With
    Application.ScreenUpdating = True
         MsgBox "L'image est sauvegardée dans le dossier du classeur."
End Sub



@+ Le Pivert

ucfoutu · Answer

Bonjour,
Ouvre ton aide VBA sur le mot PrinForm (Méthode PrintForm). 


________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

cs_Jack · Answer

Salut

Tu reposes la question, mais as-tu fait des recherches, des essais ?
Sous VBA, ça va être difficile car VBA ne sait pas gérer les PictureBox (pratique pour acceuillir la capture) et la manipulation des handles est difficile car pas d'accès direct.

Il va te falloir te familiariser avec les APIs qui permettent de jongler avec les recherches de handles (GetWindow) et le traitement de l'image comme BitBlt.

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)

benjfalta · Answer

Oui merci, je vais viens de trouver d'autres informations sur le site et sur l'aide VBA. Je peux grâce à ce code, désormais, réaliser une capture écran de mon userform, de la positionner dans Paint et de l'enregistrer dans "mes images".

Il ne me reste plus qu'à trouver le moyens de redimensionner celle-ci et de la placer dans un dossier différent de celui-là.


Private Sub CommandButton1_Click()

Dim logiciel

keybd_event VK_SNAPSHOT, 1, 0, 0

logiciel = Shell("C:\WINNT\system32\mspaint.exe", vbNormalFocus)
Application.Wait Now + TimeValue("00:00:02")
    
SendKeys "^v"
SendKeys "^s"
SendKeys "Image2"
Application.Wait Now + TimeValue("00:00:01")
SendKeys ("{ENTER}")
SendKeys "%{F4}"

End Sub

Merci pour vos réponses

ucfoutu · Answer

N'avais pas tout lu.
Pour faire tout ce que tu veux faire, le chemin va être long sous VBA et tu ne pourras y parvenir avec VBA qu'en utilisant des fonctions de l'Api de Windows, ce qui fait qu'on s'éloignerait considérablement du "niveau débutant" que tu exposes.
Je crois que le plus simple et le plus à ta portée serait alors d'utiliser la touche ImprEcran de ton clavier (mise en presse-papier) puis retravailler ton image à l'aide de Paint.
Car je suppose qu'il ne s'agit pas là d'une tâche récurrente, mais de quoi obtenir une image accompagnant l'exposé d'une appli.
Si, par contre, il s'agissait d'autre chose (utiliser par exemple la pixelisation de ton userform pour en faire une facture), tu t'éloignerais considérablement de l'esprit de développement orthodoxe.


________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

ucfoutu · Answer

Ouais ...
On s'est un peu "croisés" pendant que j'écrivais mon message précédent.
Voici ce que tu pourrais astucieusement faire avant de traiter par Paint : ===>>> utiliser la propriété Zoom de ton UserDForm.

Fais ce petit test, qui te fera comprendre de quoi il retourne :

Un bouton de commande sur ton UserForm et ce code :
Private Sub CommandButton1_Click()
  k = 0.7
  Me.Width = Me.Width * k
  Me.Height = Me.Height * k
  Me.Zoom = k * 100
End Sub

cet exemple passe à un zoom de 70% (k 0.7) . k 2 ===>> passerait à 200%
________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

benjfalta · Answer

Ton code est intéressant mais il ne me convient pas car je dois en réalité "rogner" l'image afin de laisser apparâitre qu'une partie bien précise de celle-ci. Je me suis donc mal exprimé dans mon titre et je m'en excuse

castou60 · Answer

Castou60
Ce qui est inscrit fonctionne avec Visual Basic 2010 Express :

Pour faire la capture d'écran fait comme ceci :

tu met 1 picturebox et un bouton, ensuite pour le bouton tu met ceci :
------------------------------------------------
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        PictureBox1.Image = Nothing     CaptureScreen.CaptureScreen.PlatformInvokeUSER32.GetDesktopWindow()
PictureBox1.Image=CaptureScreen.CaptureScreen.CaptureScreen.GetDesktopImage
PictureBox1.Update()
End Sub
------------------------------------------------
ensuite pour redimenssionner la capture tu procède ainsi :
------------------------------------------------
 Dim ecran As Screen = Screen.PrimaryScreen
 Dim largeur As Integer = ecran.Bounds.Width
 Dim hauteur As Integer = ecran.Bounds.Height

sub taille écran()
 Dim w = largeur - 4
 Dim h = hauteur - 138
 PictureBox1.Width = w 
 PictureBox1.Height = h 
 PictureBox1.Refresh()    
end sub
------------------------------------------------
Pour enregistrer la capture dans un fichier bmp,jpeg, etc.... fais comme cela :
------------------------------------------------
Dim pic = PictureBox1.Image
SaveFileDialog1.Filter="Fichier.jpg(*.jpg)|*.jpg|Fichier.png(*.png)|*.png|Fichier.gif(*.gif)|*.gif"
        SaveFileDialog1.FileName = ""
        SaveFileDialog1.ShowDialog()
        If SaveFileDialog1.FileName <> "" Then
            pic.Save(SaveFileDialog1.FileName.ToString)
End If
------------------------------------------------
Ps : CaptureScreen est une dll que j'ai trouver sur le net dont je me suis servi pour créer ma propre application de capture d'écran cela fonctionne à merveille

benjfalta · Answer

Ton code ne fonctionne pas en VBA car les PictureBox ne sont pas gérables

benjfalta · Answer

Bonjour Pivert,

Ton code est parfait, il me correspond tout à fait. Il y a juste un hik au moment ou je rogne l'image car même avec les codes récupérés dans l'enregistrement manuel, l'image ne se rogne pas en haut ni à gauche comme elle devrait le faire dans mon exemple suivant:

    With Selection
    Selection.ShapeRange.PictureFormat.CropLeft = 13.5
    Selection.ShapeRange.PictureFormat.CropTop = 34.5
    Selection.ShapeRange.PictureFormat.CropBottom = 24#
    Selection.ShapeRange.PictureFormat.CropRight = 299.25     End With

Je vais continuer à chercher ce léger souci
Merci encore!

cs_Le Pivert · Answer

J'ai trouvé la solution à ton problème. Enlever la barre de titre de ton UserForm pour la capture et la remettre ensuite.
Dans un module le code suivant:

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Const GWL_STYLE = (-16)
Const WS_CAPTION = &HC00000
Const SWP_FRAMECHANGED = &H20

Public Declare Function FindWindowA Lib "User32" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
        
Public Declare Function GetWindowRect Lib "User32" _
        (ByVal hWnd As Long, lpRect As RECT) As Long
        
Public Declare Function GetWindowLong Lib "User32" Alias _
        "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "User32" Alias _
        "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long

Public 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
 
Sub AfficheTitleBarre(stCaption As String, pbVisible As Boolean)
Dim vrWin As RECT
Dim style As Long
Dim lHwnd As Long
'- Recherche du handle de la fenêtre par son Caption
    lHwnd = FindWindowA(vbNullString, stCaption)
    If lHwnd = 0 Then
        MsgBox "Handle de " & stCaption & " Introuvable", vbCritical
        Exit Sub
    End If
    
    GetWindowRect lHwnd, vrWin
    style = GetWindowLong(lHwnd, GWL_STYLE)
    If pbVisible Then
        SetWindowLong lHwnd, GWL_STYLE, style Or WS_CAPTION
    Else
        SetWindowLong lHwnd, GWL_STYLE, style And Not WS_CAPTION
    End If
    SetWindowPos lHwnd, 0, vrWin.Left, vrWin.Top, vrWin.Right - vrWin.Left, _
            vrWin.Bottom - vrWin.Top, SWP_FRAMECHANGED
End Sub


Dans ton UserForm 2 CommandButtons:


Private Sub CommandButton3_Click()
'On passe en arguments :
'    - le titre de la fenêtre
'    - False pour masquer la barre de titre
    AfficheTitleBarre Me.Caption, False
End Sub
Private Sub CommandButton4_Click()
'On passe en arguments :
'    - le titre de la fenêtre
'    - True pour afficher la barre de titre
    AfficheTitleBarre Me.Caption, True
End Sub


Et voilà le tour est joué!

@+Le Pivert

cs_Le Pivert · Answer

benjfalta,
Dans ce que tu as mis dans ton précédent post:
[i]With Selection 
Selection.ShapeRange.PictureFormat.CropLeft = 13.5 
Selection.ShapeRange.PictureFormat.CropTop = 34.5 
Selection.ShapeRange.PictureFormat.CropBottom = 24# 
Selection.ShapeRange.PictureFormat.CropRight = 299.25 End With 
/i
Il faut que tu saches que si tu mets With Selection c'est pour supprimer le mot sélection dans les lignes suivantes!

Donc il faut écrire:

With Selection
        .ShapeRange.PictureFormat.CropLeft = 13.5
        .ShapeRange.PictureFormat.CropTop = 34.5
        .ShapeRange.PictureFormat.CropBottom = 24#
        .ShapeRange.PictureFormat.CropRight = 299.25
       End With

Voici donc le code automatisé sans passer par des commanbutton pour supprimer la barre de titre et la rétablir:

Private Sub CommandButton1_Click()
Dim monImage As String
Dim Sh As Shape
'Définit le nom et le lieu de stockage de l'image
    monImage = ActiveWorkbook.Path & "\monimage" & ".jpg"
   keybd_event vbKeySnapshot, 1, 0&, 0&
    DoEvents
     Range("A1").Select
    ActiveSheet.Paste
     'on rogne l'image: à toi de régler suivant ta convenance à l'aide de l'enregistreur de macro
    With Selection
        .ShapeRange.PictureFormat.CropLeft = 13.5
        .ShapeRange.PictureFormat.CropTop = 34.5
        .ShapeRange.PictureFormat.CropBottom = 24#
        .ShapeRange.PictureFormat.CropRight = 299.25
       End With
    'Récupère la dernière forme de la feuille
    Set Sh = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    'Colle l'image dans un graphique
    With ActiveSheet.ChartObjects.Add(0, 0, Sh.Width, Sh.Height).Chart
        .Paste
        'Sauvegarde l'image du graphique au format jpg
        .Export monImage, "JPG"
    End With
  'Supprime le graphique et la forme.
    With ActiveSheet
        .ChartObjects(ActiveSheet.ChartObjects.Count).Delete
        .Shapes(ActiveSheet.Shapes.Count).Delete
    End With
    Application.ScreenUpdating = True
         MsgBox "L'image est sauvegardée dans le dossier du classeur."
 AfficheTitleBarre Me.Caption, True ' rétablir la barre de titre
     End Sub
Private Sub UserForm_Initialize()
 AfficheTitleBarre Me.Caption, False 'masquer la barre de titre
End Sub

@+Le Pivert

Faire une capture écran, redimensionner et l'enregistrer

12 réponses

Votre réponse

Discussions similaires