Captura

[Guest - mizzu -]

Alguém tem um programa de captura de imagens no VB.

gostaria que me enviassem o fonte para: mizzu@jupiter.com.br

Grato.

[Graymalkin]

Que tal você tentar fazer um? Uma dica para isso seria a utilização da funções GetDC(), GetDesktopWindow() e BitBlt() da API Win32 (são as que me vieram à mente agora, mas pode ser necessário alguma outra também). Dê uma olhada nelas no API-Guide (http://www.mentalis.org/).

Abraços,

Graymalkin

[ramon]

É uma boa!

[Guest Guest]

inice assim

form1:

Option Explicit

Option Base 0

Dim x, y, z As Integer

Dim fso, CreateFolderDemo, f, result, iret

Dim path, lpOperation, lpParameters, scrdirectory, scrfilename As String

Private Sub Command1_Click()

CommonDialog1.Filter = "Screen Saver Executable (*.scr)|*.scr"

CommonDialog1.DialogTitle = "Open Screen Saver .. "

CommonDialog1.ShowOpen

Text1 = CommonDialog1.FileName

End Sub

Private Sub Command2_Click()

If Text1 = "" Or Text3 = "" Then

Exit Sub

End If

path = Text3.Text & "\"

' check whether path is valid

Call pretest

' if y=1 path invalid

If y = 1 Then

Exit Sub

End If

scrdirectory = fso.GetParentFolderName(Text1.Text)

scrfilename = fso.GetFileName(Text1.Text)

' run the Screen Saver

result = ShellExecute(Hwnd, lpOperation, scrfilename, _

lpParameters, scrdirectory, 1)

Form2.Label4(1) = "Time started : " & Time

' wait for Screen Saver to start (delay)

Sleep 2000 ' system variable

' capture images

Call capture

Form2.Label4(2) = "Time ended : " & Time

' ends the capture

Call report

End Sub

Private Sub Command3_Click()

If Text1.Text <> "" Then

' Screen Saver Display Settings

Shell Text1.Text, vbNormalFocus

End If

End Sub

Private Sub Cancel_Click()

Me.Height = 4410

Me.Width = 7845

Frame2.Visible = False

End Sub

Private Sub ok_Click()

Me.Height = 4410

Me.Width = 7845

Frame2.Visible = False

Text3 = Desfolder.Text

End Sub

Private Sub Command4_Click()

Me.Height = 4485

Me.Width = 5280

Frame2.Visible = True

End Sub

Private Function capture()

Dim i As Long

Dim tm As Integer

tm = Second(Time)

x = 2

z = 0

For i = 1 To 300000

If Second(Time) = tm + x Then

Set Picture1(0).Picture = Nothing

Set Picture1(0).Picture = CaptureScreen()

SavePicture Picture1(0).Picture, path & i & ".jpg"

z = z + 1

End If

x = (x + 4) Mod 60

Next i

End Function

Private Function pretest()

Dim msg

Set fso = CreateObject("Scripting.FileSystemObject")

' check source .scr file

If (fso.FileExists(Text1.Text)) Then

GoTo 2

Else

y = 1

msg = MsgBox("The file " & Text1.Text & _

" doesn't exist.", , "Screen Saver Capture")

GoTo 100

End If

' check if folder exist`s

2 If (fso.FolderExists(Text3.Text)) Then

GoTo 100

Else

msg = MsgBox("The folder " & Text3.Text & " doesn't exist." & vbCrLf & "Do you want to create one?", vbYesNo, "Screen Saver Capture")

' create new folder

If msg = 6 Then

Set f = fso.CreateFolder(path)

CreateFolderDemo = f.path

Else

y = 1

End If

End If

100 End Function

Private Function report()

Form2.Label4(0) = "Total images captured : " & z

Form2.Label4(3) = "Destination Folder : " & Text3.Text

Form2.Show vbModal, Me

' opens the folder

iret = ShellExecute(Hwnd, lpOperation, "", _

lpParameters, Text3.Text, 1)

End Function

Private Sub Dir1_Change()

Desfolder = Dir1.path

End Sub

Private Sub Drive1_Change()

Dim d, drvpath

Set fso = CreateObject("Scripting.FileSystemObject")

drvpath = Left(Drive1.Drive, 2) & "\"

Set d = fso.GetDrive(drvpath)

If d.IsReady Then

Dir1.path = Drive1.Drive

Else

Exit Sub

End If

End Sub

---------------

form2:

Private Sub Command1_Click()

Unload Me

End Sub

Private Sub Form_Load()

Dim Ret As Long

Ret = SetWindowPos(Hwnd, -1, 0, 0, 0, 0, 3)

End Sub

Private Sub Label3_Click()

Call Navigate(Me, "anand2all@yahoo.com")

End Sub

Sub Navigate(frm As Form, ByVal WebPageURL As String)

Dim hBrowse As Long

hBrowse = ShellExecute(frm.Hwnd, "open", "MailTo:" + WebPageURL, "", "", SW_SHOW)

End Sub

----------

module:

Option Explicit

Dim x As Integer

Dim fso, result

Public Type PALETTEENTRY

peRed As Byte

peGreen As Byte

peBlue As Byte

peFlags As Byte

End Type

Public Type LOGPALETTE

palVersion As Integer

palNumEntries As Integer

palPalEntry(255) As PALETTEENTRY

End Type

Public Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Public Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Public Type PicBmp

Size As Long

Type As Long

hBmp As Long

hPal As Long

Reserved As Long

End Type

Public Const RASTERCAPS As Long = 38

Public Const RC_PALETTE As Long = &H100

Public Const SIZEPALETTE As Long = 104

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long

Public Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Public Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long

Public Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long

Public Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long

Public Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long

Public Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long

Public Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long

Public Declare Function GetForegroundWindow Lib "user32" () As Long

Public Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Public Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long

Public Declare Function GetWindowDC Lib "user32" (ByVal Hwnd As Long) As Long

Public Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long

Public Declare Function GetWindowRect Lib "user32" (ByVal Hwnd As Long, lpRect As RECT) As Long

Public Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As Long, ByVal hDC As Long) As Long

Public Declare Function GetDesktopWindow Lib "user32" () As Long

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd 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

Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

' capture coding by unknown

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

Dim r As Long

Dim Pic As PicBmp

Dim IPic As IPicture

Dim 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

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

Dim hDCMemory As Long

Dim hBmp As Long

Dim hBmpPrev As Long

Dim r As Long

Dim hDCSrc As Long

Dim hPal As Long

Dim hPalPrev As Long

Dim RasterCapsScrn As Long

Dim HasPaletteScrn As Long

Dim PaletteSizeScrn As Long

Dim LogPal As LOGPALETTE

If Client Then

hDCSrc = GetDC(hWndSrc)

Else

hDCSrc = GetWindowDC(hWndSrc)

End If

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

r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

hPal = SelectPalette(hDCMemory, hPalPrev, 0)

End If

r = DeleteDC(hDCMemory)

r = ReleaseDC(hWndSrc, hDCSrc)

Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)

End Function

Public Function CaptureScreen() As Picture

Dim hWndScreen As Long

hWndScreen = GetDesktopWindow()

Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)

End Function

Valeu