Comment capturer une partie de l'écran (via coordonnées pixel) ?

**Chekov** · 23/05/2008, 13h05

Bonjour,

est-il possible de faire une capture d'écran partielle, depuis VB6, à partir de coordonnées pixels ? J'aimerai en fait créer une image à partir d'une partie d'une fenêtre...

Bonne journée

**ucfoutu** · 23/05/2008, 16h10

Bonjour,

Je te propose d'essayer ceci

puis de l'analyser, puis de comprenddre, puis de l'adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = vbPicTypeBitmap
        .hBmp = hBmp
        .hPal = hPal
    End With
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        R = RealizePalette(hDCMemory)
    End If

'===================================================    ' c'est ici que les choses se passent
    Dim sourcex As Integer, sourcey As Integer, sourcewidth As Integer, sourceheight As Integer
    sourcex = 50: sourcey = 100
    sourcewidth = 200: sourceheight = 100
    R = BitBlt(hDCMemory, 0, 0, sourcewidth, sourceheight, hDCSrc, LeftSrc + sourcex, TopSrc + sourcey, vbSrcCopy)
'==================================================

    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    R = DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
    Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub

Je t'y ai isolé ce qui t'intéresse.

Il reste que tu devras faire l'effort de comprendre.
Si tu n'y parviens pas, c'est que tu n'es pas prêt à autre chose que du copier/coller et là ... ne compte plus sur moi !!!

**DarkVader** · 23/05/2008, 21h36

En légèrement plus court,
voir PrintWindow pour récupérer le contenu d'une fenêtre depuis son handle
puis éventuellement la méthode PaintPicture d'un picturebox pour saisir la zone.

**ProgElecT** · 23/05/2008, 21h59

Ou encore comme sa

Sur un Form, un PictureBox(PictCapture), un CommandButton

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
'recuperation de l'image du bureau en cours
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
 
'equivalant a PainPicture, mais depuis le HDC de la destination et du source
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
 
'pour obtenir l'image d'un objet graphique
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
' Drapeau du comportement de recuperation/melange des pixels couleur
Private Const SRCCOPY As Long = &HCC0020
 
Dim RecupLeft As Long, RecupTop As Long, RecupWidth As Long, RecupHeight As Long
 
Private Sub Form_Load()
'toutes ces commande peuvent être fait en design
PictCapture.AutoRedraw = True
PictCapture.BorderStyle = 0 'none
PictCapture.ScaleMode = vbPixels
Me.Caption = "Ton Form qui enclanche la capture"
Me.Height = 1095: Me.Width = 2055
Command1.Move 0, 0, 1935, 705
PictCapture.Move 0, Command1.Top + Command1.Height
Command1.Caption = "lancer la capture selective"
End Sub
 
Private Sub Command1_Click()
'pour que ton prog ne masque pas la fenêtre que tu veux capturer
'de plus, elle ne doit pas être cachée par un autre programme
Me.Visible = False
DoEvents
'ces variables son les coordonées et dimensions de la fenêtre que tu veux recuperer
'tous doient être en pixels
'RecupLeft = 60: RecupTop = 100: RecupHeight = 300: RecupWidth = 560
RecupLeft = 150: RecupTop = 200: RecupHeight = 200: RecupWidth = 800
 
'dimensionne le picture de capture
'ScaleX et ScaleY car le Form et en Twips, donc convertion
PictCapture.Height = ScaleY(RecupHeight, vbPixels, vbTwips)
PictCapture.Width = ScaleX(RecupWidth, vbPixels, vbTwips)
'dessine la fraction du bureau ou se trouve la fenêtre à recuperer
StretchBlt PictCapture.hdc, 0, 0, RecupWidth, RecupHeight, _
    GetDC(GetDesktopWindow()), RecupLeft, RecupTop, RecupWidth, RecupHeight, SRCCOPY
'obligatoire
PictCapture.Refresh
DoEvents
'pour prouver la capture
Me.Visible = True
Me.WindowState = vbMaximized
End Sub

MAIS le code de ucfoutu est plus complet, car il s'adapte a beaucoup plus de situation.

**ucfoutu** · 23/05/2008, 22h08

Bonsoir Progelect et Darkvader,

On peut bien évidemment également envoyer la totalité dans le clipboard (simulation de la touche IMPR ECRAN<, puis jouer avec une Ipicture et PaintPicture (ou d'ailleurs Bitblt ou stretchBlt)..

Pourquoi alors avoir fourni le code plus complexe que j'ai fourni ? ===>> je crois avoir mes raisons (inavouables ? ... oui...sans auucun doute ... mais c'est et ce sera toujours ainsi dans certains cas ...

)

Bonne nuit.

**DarkVader** · 24/05/2008, 14h11

Bonjour,
on ne m'otera pas de l'idée qu'un code de 5 lignes est préférable à un autre de 50
ne serait-ce qu'en terme de lisibilité.

Soit avec 2 PictureBox (autoredraw on) - cachés ou non

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
 
Private Type RECT
   Left     As Long
   Top      As Long
   Right    As Long
   Bottom   As Long
End Type
 
Private Sub getPictCopy(hW As Long, bloc As RECT, fileName As String)
    PrintWindow hW, Me.Picture1.hDC, 0
 
    With bloc
        Me.Picture2.Width = .Right - .Left
        Me.Picture2.Height = .Bottom - .Top
        Me.Picture2.PaintPicture Me.Picture1.Image, -.Left, -.Top
 
        SavePicture Me.Picture2.Image, fileName
    End With
End Sub

hW correspond au handle de la fenêtre source

**ucfoutu** · 24/05/2008, 16h07

Bonjour, DarkVader,

- lisibilité pour visibilité, il y a alors plus simple à faire

(relire mon dernier message)
- mais t'es-tu intéressé à la portabilité ? As-tu vérifié (sinon fais-le) que cette fonction est bien présente dans la librairie User32 de Windows 2000 ?

**DarkVader** · 24/05/2008, 16h33

Windows NT/2000/XP/Vista: Included in Windows XP and Windows Server 2003.
Windows 95/98/Me: Unsupported.

Ceci dit, j'aime bien ce qui est court - tu aurais répondu
http://support.microsoft.com/kb/161299/fr, je ne pouvais rien y redire lol

**ucfoutu** · 24/05/2008, 18h09

Ouais..

Tu sais quoi ?

La machine sur laquelle je te réponds en ce moment travaille avec Windows 2000 ...
Et sa Librairie User32 de Windows 2000 ne comporte pas la fonction PrintWindow ...

Je me suis alors demandé si c'était moi ou celui qui a rédigé la rubrique Microsoft concernée, qui avait la berlue ... ou encore si je possédais une version bizarre de Windows 2000 ...
Je suis alors allé voir ici :
http://www.answers.com/topic/printwi...cat=technology
où j'ai été rassuré ! ma version n'est pas infirme et ne contient pas cette fonction ...

(pas plus que Windows 95, Windows 98 et Windows Me)
Reste (je l'ai dit plus haut) que l'on peut faire plus simple en simulant la touche 44... et que celà marche avec toutes les versions.
Je n'y viendrait toutefois que plus tard (après que notre ami demandeur se sera à nouveau manifesté ... pas avant) .

Bon ...
Allons-y malgré tout ...
C'est vraiment simple :

Deux Forms (la deuxième va servir uniquement à l'affichage/démo de la capture faite) dont on se moque totalement de la propriété AutoRedraw et du ScaleMode .. et un bouton de commande pour lancer la capture.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
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 Command1_Click()
   Dim monchoix As Byte, couic As StdPicture, couac As StdPicture
   
   'monchoix = 0 '(pour tout l'écran)
   'ou
   monchoix = 1 '(pour la seule fenêtre active)
   
   Set couac = Clipboard.GetData ' je garde en mémoire l'image qu'a éventuellement Cesar
   Clipboard.Clear
   keybd_event 44, monchoix, 0, 0
   DoEvents
   Form2.Move 0, 0, Screen.Width, Screen.Height
   Form1.Visible = False
   Set couic = Clipboard.GetData
   Form2.Picture = couic
   Form2.Show
   Clipboard.Clear
   Clipboard.SetData couac, 2 ''je rends à Cesar l'image qu'avait éventuellement Cesar
End Sub

et couic étant une stdpicture, je peux en faire ce que je veux à l'aide de PaintPicture, de BitBlt ou de StrectchBlt (pour n'afficher que ce que je veux)

**pbozo** · 29/08/2020, 18h52

Envoyé par ucfoutu

Bonjour,

Je te propose d'essayer ceci

puis de l'analyser, puis de comprenddre, puis de l'adapter :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = vbPicTypeBitmap
        .hBmp = hBmp
        .hPal = hPal
    End With
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
    Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        R = RealizePalette(hDCMemory)
    End If

'===================================================    ' c'est ici que les choses se passent
    Dim sourcex As Integer, sourcey As Integer, sourcewidth As Integer, sourceheight As Integer
    sourcex = 50: sourcey = 100
    sourcewidth = 200: sourceheight = 100
    R = BitBlt(hDCMemory, 0, 0, sourcewidth, sourceheight, hDCSrc, LeftSrc + sourcex, TopSrc + sourcey, vbSrcCopy)
'==================================================

    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    R = DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
    Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub

Je t'y ai isolé ce qui t'intéresse.

Il reste que tu devras faire l'effort de comprendre.
Si tu n'y parviens pas, c'est que tu n'es pas prêt à autre chose que du copier/coller et là ... ne compte plus sur moi !!!

**Mat.M** · 01/09/2020, 11h01

Dans cette fonction , passer les bons paramètres:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

Modifier TopSrc et LeftSrc en conséquence

Comment capturer une partie de l'écran (via coordonnées pixel) ?

VB 6 et antérieur

Discussions similaires

Partager

Partager