Захват видео с камеры 2 МPxl

[jiomaster]

Всем привет. Поиском не нашел по форуму ничего подходящего. Дело так: есть написанная программа на vb, позволяющая захватить с любого источника (в данном случае это микроскоп) видео картинку и сохранить ее в файл. Но есть одна проблема, которую мне и поручили решить (а я не программист) - данная программа позволяет получить изображение не более 640 на 480. Другой программой от Microsoft "AmCam" пробовал - до 2 MPxl вполне успешно работает. В программе на форме довольно много кнопок сделано, но необходимы лично мне только несколько. Первая создает окно на форме, подключает драйвер, спрашивает его параметры, и захватывает картинку. Кнопка 2 отключает драйвер. Третья берет сохраненную картинку и выкладывает в окно на форме. Остальные две настроены на получение свойств устройства и на параметры подключенных устройств. Надеюсь, изложил понятно и не нудно:). Возможно при указании переменных наделал ошибок...Очень надеюсь на помощь. Код следуюущий.

Код: Выделить всё

Option Explicit
'Объявления для видео
Const WM_USER = 1024
Const WM_CAP_DRIVER_CONNECT = WM_USER + 10
Const WM_CAP_SET_PREVIEW = WM_USER + 50
Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Const WM_CAP_DRIVER_GET_CAPS = WM_USER + 14
Const WM_CAP_DLG_VIDEOFORMAT = WM_USER + 41
Const WM_CAP_DLG_VIDEOSOURCE = WM_USER + 42
Const WM_CAP_DRIVER_DISCONNECT = WM_USER + 11
Const WM_CAP_GRAB_FRAME = WM_USER + 60
Const WM_CAP_FILE_SAVEDIB = WM_USER + 25

Private Type CAPDRIVERCAPS
    wDeviceIndex As Long
    fHasOverlay As Boolean
    fHasDlgVideoSource As Boolean
    fHasDlgVideoFormat As Boolean
    fHasDlgVideoDisplay As Boolean
    fCaptureInitialized As Boolean
    fDriverSuppliesPalettes As Boolean
    hVideoIn As Long
    hVideoOut As Long
    hVideoExtIn As Long
    hVideoExtOut As Long
End Type

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" (ByVal a As String, ByVal b As Long, ByVal c As Integer, ByVal d As Integer, ByVal e As Integer, ByVal f As Integer, ByVal g As Long, ByVal h As Integer) As Long
Private Declare Function capGetDriverDescription Lib "avicap32" Alias "capGetDriverDescriptionA" (ByVal wDriverIndex As Long, ByVal lpszName As String, ByVal cbName As Long, ByVal lpszVer As String, ByVal cbVer As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim hWDC As Long
Dim STARTcap As Boolean
Dim CapInfo As CAPDRIVERCAPS
'Объявления для конвертации
Private Declare Function GetPixel Lib "gdi32" (ByVal _
hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal _
hdc As Long, ByVal x As Long, ByVal y As Long, ByVal _
crColor As Long) As Long



'Работа с видео
Private Sub Command1_Click()
hWDC = capCreateCaptureWindow("VideoCapture", 0, 0, 0, 1280, 960, Picture1.HWND, 0)
  If (hWDC <> 0) Then
    SendMessage hWDC, WM_CAP_DRIVER_CONNECT, 0, 0
    SendMessage hWDC, WM_CAP_DRIVER_GET_CAPS, Len(CapInfo), VarPtr(CapInfo)
     STARTcap = True
    Do While STARTcap = True
    SendMessage hWDC, WM_CAP_GRAB_FRAME, 0, 0
    SendMessageString hWDC, WM_CAP_FILE_SAVEDIB, 0, "C:\VIDEO1.BMP"
    Picture1.Picture = LoadPicture("C:\VIDEO1.BMP")
    DoEvents
     Sleep 100
    Loop
  Else
    MsgBox ("no cam found")
  End If
End Sub
Private Sub Command2_Click()
If STARTcap = True Then
Call SendMessage(hWDC, WM_CAP_DRIVER_DISCONNECT, 0, 0)
STARTcap = False
End If
End Sub

Private Sub Command3_Click()
Dim i As Integer
Me.Picture2.ScaleMode = vbTwips
Me.Picture2.Picture = LoadPicture("C:\VIDEO1.BMP")
'Picture2.PaintPicture Picture1, 0, 0, 4800, 3600, 0, 0, , , vbSrcCopy
SavePicture Picture2.Image, "c:\video2.bmp"
Me.Picture2.ScaleMode = vbPixels
Label5.Caption = Me.Picture2.ScaleWidth
     Label6.Caption = Me.Picture2.ScaleHeight
For i = 1 To 12
Picture2.Line (0, i * 40)-(640, i * 40), vbYellow
Next i
End Sub

Private Sub Command4_Click()
If STARTcap = True Then
Call SendMessage(hWDC, WM_CAP_DRIVER_DISCONNECT, 0, 0)
STARTcap = False
End If
Unload Form1
Unload Form2
End Sub

Private Sub Command7_Click()
Call SendMessage(hWDC, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
End Sub

Private Sub Command8_Click()
Call SendMessage(hWDC, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
End Sub

[Хакер]

Очень надеюсь на помощь.

Благословляю тебя на успешное написание программы.

Помощь оказана в полном объёме — тема закрыта.
Если в таком объёме помощь тебя не устраивает — почитай вот это.