Recup une image à partir picturebox

Desole, mais sa fonctionne pas, jai une errue sur PrintWindow, inconnu dans
la Dll user32.

"Zoury" <yanick_lefebvre at hotmail dot com> a écrit dans le message de
news: O9Zw8KtYFHA.3624@tk2msftngp13.phx.gbl...

> Oui, mais sa me dit pas comment faire pour recuperer l'image du

Picturebox

> tt ça.

hehe ! patience ! :O)

Je t'ai fais un petit exemple qui sauvegarde un Bitmap de 24bits sur le
disque.

Au démarrage du programme, un screenshot du systray est copié dans le
picture. Il ne te reste qu'à appuyer sur sur "Sauvegarder" pour créer
l'image.
'***
' Form 1
' 1 PictureBox
' 1 CommandButton
' 1 Timer
Option Explicit

' Constante désignant "BM" pour l'entête du fichier
Private Const BMP_MAGIC_COOKIE = &H4D42

' Information relative à l'entête du bitmap
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
blWidth As Long
blHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

' Information relative à l'entête du fichier
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function PrintWindow _
Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hdcBlt As Long, _
ByVal nFlags As Long) 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 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 GetDIBits _
Lib "gdi32" _
( _
ByVal hDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As BITMAPINFOHEADER, _
ByVal wUsage As Long _
) As Long

Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject _
Lib "gdi32" ( _
ByVal hObject As Long) As Long

Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hDC As Long) As Long

Private Sub Form_Load()

Call Me.Move(Me.Left, Me.Top, 6525, 1725)
Call Picture1.Move(120, 120, 6135, 495)
Call Command1.Move(4800, 720, 1465, 375)

Timer1.Interval = 10

Command1.Enabled = False
Command1.Caption = "&Sauvegarder"

Me.ScaleMode = vbPixels
Me.Caption = "Démo de sauvegarde d'image"

Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = False

End Sub

Private Sub Timer1_Timer()

Timer1.Enabled = False
Command1.Enabled = True
Call PrintWindow(FindWindow("Shell_TrayWnd", vbNullString),
Picture1.hDC, 0)

End Sub

Private Sub Command1_Click()

Const FILE_NAME As String = "c:picture1.bmp"
Call SavePictureBoxToBMP(Picture1.hDC, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, FILE_NAME)
Call Shell("mspaint """ & FILE_NAME & """", vbNormalFocus)

End Sub

Public Sub SavePictureBoxToBMP( _
ByRef hDCSrc As Long, _
ByRef lPosX As Long, _
ByRef lPosY As Long, _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef sFileName As String)

Dim hDC As Long
Dim hDIB As Long
Dim hOldDIB As Long
Dim biHeader As BITMAPINFOHEADER
Dim lScanLine As Long
Dim byDIB() As Byte

' initialise notre DC
hDC = CreateCompatibleDC(hDCSrc)
hDIB = CreateCompatibleBitmap(hDCSrc, lWidth, lHeight)
hOldDIB = SelectObject(hDC, hDIB)

' copie le contenu du DCSrc dans notre DC
Call BitBlt(hDC, 0, 0, lWidth, lHeight, hDCSrc, lPosX, lPosY,

vbSrcCopy)

' obtient l'entete du bitmap
biHeader = CreateBIHeader(lWidth, lHeight, byDIB)

' obtient les octets du DIB
Call GetDIBits(hDC, hDIB, 0, lHeight, byDIB(0, 0), biHeader, 0)

' sauvegarde le fichier
Call SaveFileAs(sFileName, biHeader, CreateBFHeader(biHeader), byDIB)

' Libère les ressources
Call SelectObject(hDC, hOldDIB)
Call DeleteObject(hDIB)
Call DeleteDC(hDC)

End Sub

Private Function CreateBIHeader( _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef byDIB() As Byte) As BITMAPINFOHEADER

Dim lScanLine As Long

' prépare notre entete de bitmap
With CreateBIHeader
.biSize = Len(CreateBIHeader)
.biBitCount = 24
.biPlanes = 1
.blHeight = lHeight
.blWidth = lWidth
lScanLine = (((.blWidth * .biBitCount) + &H1F) And Not &H1F) &H8
.biSizeImage = lScanLine * .blHeight
ReDim byDIB(lScanLine - 1, CreateBIHeader.blHeight - 1) As Byte
End With

End Function

Private Function CreateBFHeader(ByRef biHeader As BITMAPINFOHEADER) As
BITMAPFILEHEADER

' initialise l'entete du fichier
With CreateBFHeader
.bfType = BMP_MAGIC_COOKIE
.bfOffBits = Len(CreateBFHeader) + Len(biHeader)
.bfSize = .bfOffBits + biHeader.biSizeImage
End With

End Function

Private Function SaveFileAs( _
ByRef sFileName As String, _
ByRef biHeader As BITMAPINFOHEADER, _
ByRef bfHeader As BITMAPFILEHEADER, _
ByRef byDIB() As Byte) As Boolean

Dim hFile As Long

' supprime le fichier s'il existe déjà
If (FileExists(sFileName)) Then
Call Kill(sFileName)
End If

' sauvegarde l'image dans le fichier
hFile = FreeFile
Open sFileName For Binary As #hFile
Put #hFile, , bfHeader
Put #hFile, , biHeader
Put #hFile, , byDIB
Close #hFile

End Function

Private Function FileExists(ByRef sFileName As String) As Boolean
On Error Resume Next
FileExists = ((GetAttr(sFileName) And vbDirectory) = 0)
End Function
'***

--
Cordialement
Yanick
MVP pour Visual Basic

naaaargg... tu travailles sur Win 9X c'est bien ça ? :OP

si c'est le cas, essai ceci... je ne peux malheureusement pas tester la
modification avant lundi.. :O/
'***
' Form 1
' 1 PictureBox
' 1 CommandButton
' 1 Timer
Option Explicit

' Constante désignant "BM" pour l'entête du fichier
Private Const BMP_MAGIC_COOKIE = &H4D42

' Information relative à l'entête du bitmap
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
blWidth As Long
blHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

' Information relative à l'entête du fichier
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 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 GetDIBits _
Lib "gdi32" _
( _
ByVal hDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As BITMAPINFOHEADER, _
ByVal wUsage As Long _
) As Long

Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject _
Lib "gdi32" ( _
ByVal hObject As Long) As Long

Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hDC As Long) As Long

Private Sub Form_Load()

Call Me.Move(Me.Left, Me.Top, 6525, 1725)
Call Picture1.Move(120, 120, 6135, 495)
Call Command1.Move(4800, 720, 1465, 375)

Timer1.Interval = 10

Command1.Enabled = False
Command1.Caption = "&Sauvegarder"

Me.ScaleMode = vbPixels
Me.Caption = "Démo de sauvegarde d'image"

Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = False

End Sub

Private Sub Timer1_Timer()

Timer1.Enabled = False
Command1.Enabled = True
Call BitBlt(Picture1.hDC, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, _
FindWindow("Shell_TrayWnd", vbNullString), 0, 0,
vbSrcCopy)

End Sub

Private Sub Command1_Click()

Const FILE_NAME As String = "c:picture1.bmp"
Call SavePictureBoxToBMP(Picture1.hDC, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, FILE_NAME)
Call Shell("mspaint """ & FILE_NAME & """", vbNormalFocus)

End Sub

Public Sub SavePictureBoxToBMP( _
ByRef hDCSrc As Long, _
ByRef lPosX As Long, _
ByRef lPosY As Long, _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef sFileName As String)

Dim hDC As Long
Dim hDIB As Long
Dim hOldDIB As Long
Dim biHeader As BITMAPINFOHEADER
Dim lScanLine As Long
Dim byDIB() As Byte

' initialise notre DC
hDC = CreateCompatibleDC(hDCSrc)
hDIB = CreateCompatibleBitmap(hDCSrc, lWidth, lHeight)
hOldDIB = SelectObject(hDC, hDIB)

' copie le contenu du DCSrc dans notre DC
Call BitBlt(hDC, 0, 0, lWidth, lHeight, hDCSrc, lPosX, lPosY, vbSrcCopy)

' obtient l'entete du bitmap
biHeader = CreateBIHeader(lWidth, lHeight, byDIB)

' obtient les octets du DIB
Call GetDIBits(hDC, hDIB, 0, lHeight, byDIB(0, 0), biHeader, 0)

' sauvegarde le fichier
Call SaveFileAs(sFileName, biHeader, CreateBFHeader(biHeader), byDIB)

' Libère les ressources
Call SelectObject(hDC, hOldDIB)
Call DeleteObject(hDIB)
Call DeleteDC(hDC)

End Sub

Private Function CreateBIHeader( _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef byDIB() As Byte) As BITMAPINFOHEADER

Dim lScanLine As Long

' prépare notre entete de bitmap
With CreateBIHeader
.biSize = Len(CreateBIHeader)
.biBitCount = 24
.biPlanes = 1
.blHeight = lHeight
.blWidth = lWidth
lScanLine = (((.blWidth * .biBitCount) + &H1F) And Not &H1F) &H8
.biSizeImage = lScanLine * .blHeight
ReDim byDIB(lScanLine - 1, CreateBIHeader.blHeight - 1) As Byte
End With

End Function

Private Function CreateBFHeader(ByRef biHeader As BITMAPINFOHEADER) As
BITMAPFILEHEADER

' initialise l'entete du fichier
With CreateBFHeader
.bfType = BMP_MAGIC_COOKIE
.bfOffBits = Len(CreateBFHeader) + Len(biHeader)
.bfSize = .bfOffBits + biHeader.biSizeImage
End With

End Function

Private Function SaveFileAs( _
ByRef sFileName As String, _
ByRef biHeader As BITMAPINFOHEADER, _
ByRef bfHeader As BITMAPFILEHEADER, _
ByRef byDIB() As Byte) As Boolean

Dim hFile As Long

' supprime le fichier s'il existe déjà
If (FileExists(sFileName)) Then
Call Kill(sFileName)
End If

' sauvegarde l'image dans le fichier
hFile = FreeFile
Open sFileName For Binary As #hFile
Put #hFile, , bfHeader
Put #hFile, , biHeader
Put #hFile, , byDIB
Close #hFile

End Function

Private Function FileExists(ByRef sFileName As String) As Boolean
On Error Resume Next
FileExists = ((GetAttr(sFileName) And vbDirectory) = 0)
End Function
'***

--
Cordialement
Yanick
MVP pour Visual Basic

SAlut, mais je crois que cet exemple vien de allapi.net que j'ai essayer
mais sa fonctionne pas.
désoler pour ca mais je crois que les probleme est plus complexe que ca.

"Zoury" <yanick_lefebvre@hotmail.com> a écrit dans le message de news:
#JLpaOyYFHA.3356@TK2MSFTNGP15.phx.gbl...

naaaargg... tu travailles sur Win 9X c'est bien ça ? :OP

si c'est le cas, essai ceci... je ne peux malheureusement pas tester la
modification avant lundi.. :O/
'***
' Form 1
' 1 PictureBox
' 1 CommandButton
' 1 Timer
Option Explicit

' Constante désignant "BM" pour l'entête du fichier
Private Const BMP_MAGIC_COOKIE = &H4D42

' Information relative à l'entête du bitmap
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
blWidth As Long
blHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

' Information relative à l'entête du fichier
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 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 GetDIBits _
Lib "gdi32" _
( _
ByVal hDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As BITMAPINFOHEADER, _
ByVal wUsage As Long _
) As Long

Private Declare Function SelectObject _
Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteObject _
Lib "gdi32" ( _
ByVal hObject As Long) As Long

Private Declare Function DeleteDC _
Lib "gdi32" ( _
ByVal hDC As Long) As Long

Private Sub Form_Load()

Call Me.Move(Me.Left, Me.Top, 6525, 1725)
Call Picture1.Move(120, 120, 6135, 495)
Call Command1.Move(4800, 720, 1465, 375)

Timer1.Interval = 10

Command1.Enabled = False
Command1.Caption = "&Sauvegarder"

Me.ScaleMode = vbPixels
Me.Caption = "Démo de sauvegarde d'image"

Picture1.ScaleMode = vbPixels
Picture1.AutoRedraw = False

End Sub

Private Sub Timer1_Timer()

Timer1.Enabled = False
Command1.Enabled = True
Call BitBlt(Picture1.hDC, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, _
FindWindow("Shell_TrayWnd", vbNullString), 0, 0,
vbSrcCopy)

End Sub

Private Sub Command1_Click()

Const FILE_NAME As String = "c:picture1.bmp"
Call SavePictureBoxToBMP(Picture1.hDC, 0, 0, Picture1.ScaleWidth,
Picture1.ScaleHeight, FILE_NAME)
Call Shell("mspaint """ & FILE_NAME & """", vbNormalFocus)

End Sub

Public Sub SavePictureBoxToBMP( _
ByRef hDCSrc As Long, _
ByRef lPosX As Long, _
ByRef lPosY As Long, _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef sFileName As String)

Dim hDC As Long
Dim hDIB As Long
Dim hOldDIB As Long
Dim biHeader As BITMAPINFOHEADER
Dim lScanLine As Long
Dim byDIB() As Byte

' initialise notre DC
hDC = CreateCompatibleDC(hDCSrc)
hDIB = CreateCompatibleBitmap(hDCSrc, lWidth, lHeight)
hOldDIB = SelectObject(hDC, hDIB)

' copie le contenu du DCSrc dans notre DC
Call BitBlt(hDC, 0, 0, lWidth, lHeight, hDCSrc, lPosX, lPosY,

vbSrcCopy)

' obtient l'entete du bitmap
biHeader = CreateBIHeader(lWidth, lHeight, byDIB)

' obtient les octets du DIB
Call GetDIBits(hDC, hDIB, 0, lHeight, byDIB(0, 0), biHeader, 0)

' sauvegarde le fichier
Call SaveFileAs(sFileName, biHeader, CreateBFHeader(biHeader), byDIB)

' Libère les ressources
Call SelectObject(hDC, hOldDIB)
Call DeleteObject(hDIB)
Call DeleteDC(hDC)

End Sub

Private Function CreateBIHeader( _
ByRef lWidth As Long, _
ByRef lHeight As Long, _
ByRef byDIB() As Byte) As BITMAPINFOHEADER

Dim lScanLine As Long

' prépare notre entete de bitmap
With CreateBIHeader
.biSize = Len(CreateBIHeader)
.biBitCount = 24
.biPlanes = 1
.blHeight = lHeight
.blWidth = lWidth
lScanLine = (((.blWidth * .biBitCount) + &H1F) And Not &H1F) &H8
.biSizeImage = lScanLine * .blHeight
ReDim byDIB(lScanLine - 1, CreateBIHeader.blHeight - 1) As Byte
End With

End Function

Private Function CreateBFHeader(ByRef biHeader As BITMAPINFOHEADER) As
BITMAPFILEHEADER

' initialise l'entete du fichier
With CreateBFHeader
.bfType = BMP_MAGIC_COOKIE
.bfOffBits = Len(CreateBFHeader) + Len(biHeader)
.bfSize = .bfOffBits + biHeader.biSizeImage
End With

End Function

Private Function SaveFileAs( _
ByRef sFileName As String, _
ByRef biHeader As BITMAPINFOHEADER, _
ByRef bfHeader As BITMAPFILEHEADER, _
ByRef byDIB() As Byte) As Boolean

Dim hFile As Long

' supprime le fichier s'il existe déjà
If (FileExists(sFileName)) Then
Call Kill(sFileName)
End If

' sauvegarde l'image dans le fichier
hFile = FreeFile
Open sFileName For Binary As #hFile
Put #hFile, , bfHeader
Put #hFile, , biHeader
Put #hFile, , byDIB
Close #hFile

End Function

Private Function FileExists(ByRef sFileName As String) As Boolean
On Error Resume Next
FileExists = ((GetAttr(sFileName) And vbDirectory) = 0)
End Function
'***

--
Cordialement
Yanick
MVP pour Visual Basic

Salut !

je crois que cet exemple vien de allapi.net que j'ai essayer
mais sa fonctionne pas.

Peux-tu nous montrer ton code et nous expliquer dans quel contexte tu
emplois quels parties de mon exemple ?

désoler pour ca mais je crois que les probleme est plus complexe que ca.

J'en doute... :O/
montre nous ce que tu as essayé... ;O)

--
Cordialement
Yanick
MVP pour Visual Basic

Pour commencer , j'ai fait ça :
sur le form , il ya :
'2 commandButton
'2pictureBox
'1 Commanddialog
'1 MMcontrol
' le principe est simple, je charge un Mpeg, j'arrete le défilement du film,
et après 'je souhaite récupérer l'image sur la quelle j'ai fait l'arret
'Merci de me faire part de ton expérience.


Private Sub Command1_Click()
'Set the file extension filter for the
'Common Dialog control
CommonDialog1.Filter = "MPEG Files |*.MPG"
'Show the Common Dilaog box
CommonDialog1.ShowOpen
'Set the file name for the multimedia
'control
MMControl1.filename = CommonDialog1.filename
'Open the multimedia control
MMControl1.Command = "open"
'MMControl1.Command = "stop"
End Sub


Private Sub Command2_Click()
Dim p As StdPicture
Set p = Picture1.Image
SavePicture p, "c:aser.bmp"
Set p = Nothing
Picture2.Cls
Picture2.Picture = LoadPicture("c:aser.bmp")
Picture2.Refresh
End Sub

Private Sub Form_Load()
'Set the DeviceType property for the
' multimedia control to MPEG video
MMControl1.DeviceType = "MPEGVideo"
'Set the window handle display of
' the control to the window handle
' of the picture box
MMControl1.hWndDisplay = Picture1.hWnd

End Sub


Private Sub Form_Unload(Cancel As Integer)
'Close the multimedia control to free
' resources
MMControl1.Command = "close"
End Sub


Private Sub MMControl1_Done(NotifyCode As Integer)
'Close the multimedia control to free
' resources
Select Case NotifyCode
Case 4
MMControl1.Command = "stop"
Case 0
MMControl1.Command = "close"

End Select

End Sub


"Zoury" <yanick_lefebvre@hotmail.com> a écrit dans le message de news:
u$qc$r$YFHA.2420@TK2MSFTNGP12.phx.gbl...

Salut !


> je crois que cet exemple vien de allapi.net que j'ai essayer
> mais sa fonctionne pas.

Peux-tu nous montrer ton code et nous expliquer dans quel contexte tu
emplois quels parties de mon exemple ?


> désoler pour ca mais je crois que les probleme est plus complexe que ca.

J'en doute... :O/
montre nous ce que tu as essayé... ;O)

--
Cordialement
Yanick
MVP pour Visual Basic