Faire une capture écran, redimensionner et l'enregistrer [Résolu]

benjfalta - 13 nov. 2012 à 09:51 - Dernière réponse : cs_Le Pivert 5401 Messages postés jeudi 13 septembre 2007Date d'inscriptionContributeurStatut 3 octobre 2018 Dernière intervention
- 1 déc. 2012 à 11:54
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!
Afficher la suite 

Votre réponse

12 réponses

Meilleure réponse
cs_Le Pivert 5401 Messages postés jeudi 13 septembre 2007Date d'inscriptionContributeurStatut 3 octobre 2018 Dernière intervention - 19 nov. 2012 à 14:16
3
Merci
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

Merci cs_Le Pivert 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 102 internautes ce mois-ci

Commenter la réponse de cs_Le Pivert
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 13 nov. 2012 à 10:56
0
Merci
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
Commenter la réponse de ucfoutu
cs_Jack 14010 Messages postés samedi 29 décembre 2001Date d'inscriptionModérateurStatut 28 août 2015 Dernière intervention - 13 nov. 2012 à 10:57
0
Merci
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)
Commenter la réponse de cs_Jack
benjfalta - 13 nov. 2012 à 11:05
0
Merci
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
Commenter la réponse de benjfalta
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 13 nov. 2012 à 11:05
0
Merci
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
Commenter la réponse de ucfoutu
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 13 nov. 2012 à 11:17
0
Merci
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
Commenter la réponse de ucfoutu
benjfalta - 13 nov. 2012 à 11:27
0
Merci
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
Commenter la réponse de benjfalta
castou60 28 Messages postés mercredi 1 décembre 2010Date d'inscription 18 novembre 2012 Dernière intervention - 18 nov. 2012 à 03:22
0
Merci
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
Commenter la réponse de castou60
benjfalta - 19 nov. 2012 à 08:15
0
Merci
Ton code ne fonctionne pas en VBA car les PictureBox ne sont pas gérables
Commenter la réponse de benjfalta
benjfalta - 29 nov. 2012 à 10:52
0
Merci
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!
Commenter la réponse de benjfalta
cs_Le Pivert 5401 Messages postés jeudi 13 septembre 2007Date d'inscriptionContributeurStatut 3 octobre 2018 Dernière intervention - 30 nov. 2012 à 17:25
0
Merci
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
Commenter la réponse de cs_Le Pivert
cs_Le Pivert 5401 Messages postés jeudi 13 septembre 2007Date d'inscriptionContributeurStatut 3 octobre 2018 Dernière intervention - 1 déc. 2012 à 11:54
0
Merci
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
Commenter la réponse de cs_Le Pivert

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.