Soyez le premier à donner votre avis sur cette source.
Vue 18 050 fois - Téléchargée 922 fois
Private Sub Command1_Click() 'On vérifie que le taux est valable... If txtRate = "" Or txtRate = "0" Or Not IsNumeric(txtRate) Then Exit Sub Else MsgBox "Le taux entré est incorrect": Picture2.Cls 'On convertit txtRate en Double pour conserver la virgule Resize Picture1, Picture2, CDbl(txtRate) End Sub 'Cette fonction copie le contenu d'une premiere PictureBox 'pixel par pixel et la copie, rétrécie ou agrandie, dans 'une seconde PictureBox... 'Pour agrandir, le taux est inférieur à 1 'Pour rétrécir, le taux est supérieur à 1 'Pour garder la taille, le taux est égal à 1... Sub Resize(Image1 As PictureBox, Image2 As PictureBox, rate As Double) Image2.Cls For Y = 0 To Image1.ScaleHeight Step rate * 10 For X = 0 To Image1.ScaleWidth Step rate * 10 c = Image1.Point(X, Y) Image2.PSet (X / rate, Y / rate), c DoEvents Next DoEvents Next End Sub
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Integer, ByVal X As _
Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As _
Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As _
Integer, ByVal dwRop As Long) As Integer
Const SRCCOPY = &HCC0020
Public Taux As Double
Public Function capture_ecran() As String
On Error GoTo Trap
Dim Ret As Long
Dim ScreenHDC As Long
' GET SCREEN
ScreenHDC = GetDC(0&)
Shoot.Picture1.Picture = LoadPicture(Empty)
Shoot.Result.Picture = LoadPicture(Empty)
Shoot.Picture1.Height = Screen.Height
Shoot.Picture1.Width = Screen.Width
Ret = BitBlt(Shoot.Picture1.hDC, 0, 0, _
Screen.Width Screen.TwipsPerPixelX, _
Screen.Height Screen.TwipsPerPixelY, _
ScreenHDC, 0, 0, SRCCOPY)
' RESIZE SCREEN
Shoot.Result.Height = Taux * Screen.Height
Shoot.Result.Width = Taux * Screen.Width
Shoot.Result.PaintPicture Shoot.Picture1.Image, 0, 0, Shoot.Result.Width, Shoot.Result.Height, 0, 0, Shoot.Picture1.Width, Shoot.Picture1.Height
' Save Picture
SavePicture Shoot.Result.Image, App.Path & "
esult.bmp"
' Get Buffer Picture
Dim PF As Long
PF = FreeFile()
Open App.Path & "
esult.bmp" For Binary Access Read As #PF
capture_ecran = Space(LOF(PF))
Get #PF, 1, capture_ecran ' Transfert du Fichier dans la Variable
Close #PF ' capture_ecran
' Delete Temps
'Kill App.Path & "
esult.bmp"
Debug.Print "Capture get IT OK !"
Exit Function
Trap:
MsgBox "Erreur : " & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Erreur " & Err.Number
MsgBox "Taux : " & Taux & vbCrLf & "ScreenHDC : " & ScreenHDC & vbCrLf & "Screen Copy :" & SRCCOPY & vbCrLf & "Screen Mode Pixel : " & Screen.TwipsPerPixelX & vbCrLf & "Screen : " & Screen.Width & "x" & Screen.Height, vbInformation + vbOKOnly, "DEBUG ..."
Err.Clear
Exit Function
End Function
Par contre , je suis désolé , mais ce code n'a pas l'air d'être valable sur tous les os , pour capturer l'écran , mais pour changer la taillé la methode est nikel , et casi instantanée avec 800*600 Bits ...
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.