Image Capture on Windows 8 Tablet - windows

I'm working with a Dell Latitude ST2 tablet. It's running Windows 8 Pro on an Intel Atom processor.
I'm trying to do a simultaneous image capture from both the front and rear facing cameras. I'm messing around with the code from here: http://www.codeproject.com/Articles/18511/Webcam-using-DirectShow-NET
I can only get the rear facing camera, and even then the image capture doesn't work. The stream is just fine. (Less concerned about this than I am the dual streams.)
The two image sensors in the tablet are OV8830 and OV2720.
Also, is there a better API or method rather than using DirectShow for what I'm trying to accomplish?
Thanks!
Edit: I forgot to mention I'm working in VB. I'd prefer to stick with an Windows Forms Application.

I have tried this method just a day back with small modifications in the code.For me the image stream as well as the capture is working great.i will place my code here.you can have your modification for application to work for you.
Imports System.Runtime.InteropServices
Imports System.IO
Public Class FrmCam
Const WM_CAP As Short = &H400S
Const WM_CAP_DRIVER_CONNECT As Integer = WM_CAP + 10
Const WM_CAP_DRIVER_DISCONNECT As Integer = WM_CAP + 11
Const WM_CAP_EDIT_COPY As Integer = WM_CAP + 30
Public Const WM_CAP_GET_STATUS As Integer = WM_CAP + 54
Public Const WM_CAP_DLG_VIDEOFORMAT As Integer = WM_CAP + 41
Const WM_CAP_SET_PREVIEW As Integer = WM_CAP + 50
Const WM_CAP_SET_PREVIEWRATE As Integer = WM_CAP + 52
Const WM_CAP_SET_SCALE As Integer = WM_CAP + 53
Const WS_CHILD As Integer = &H40000000
Const WS_VISIBLE As Integer = &H10000000
Const SWP_NOMOVE As Short = &H2S
Const SWP_NOSIZE As Short = 1
Const SWP_NOZORDER As Short = &H4S
Const HWND_BOTTOM As Short = 1
Private DeviceID As Integer = 0 ' Current device ID
Private hHwnd As Integer ' Handle to preview window
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
ByRef lParam As CAPSTATUS) As Boolean
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Boolean, _
ByRef lParam As Integer) As Boolean
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, _
ByRef lParam As Integer) As Boolean
Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Integer, _
ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, _
ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
Declare Function DestroyWindow Lib "user32" (ByVal hndw As Integer) As Boolean
Structure POINTAPI
Dim x As Integer
Dim y As Integer
End Structure
Public Structure CAPSTATUS
Dim uiImageWidth As Integer '// Width of the image
Dim uiImageHeight As Integer '// Height of the image
Dim fLiveWindow As Integer '// Now Previewing video?
Dim fOverlayWindow As Integer '// Now Overlaying video?
Dim fScale As Integer '// Scale image to client?
Dim ptScroll As POINTAPI '// Scroll position
Dim fUsingDefaultPalette As Integer '// Using default driver palette?
Dim fAudioHardware As Integer '// Audio hardware present?
Dim fCapFileExists As Integer '// Does capture file exist?
Dim dwCurrentVideoFrame As Integer '// # of video frames cap'td
Dim dwCurrentVideoFramesDropped As Integer '// # of video frames dropped
Dim dwCurrentWaveSamples As Integer '// # of wave samples cap'td
Dim dwCurrentTimeElapsedMS As Integer '// Elapsed capture duration
Dim hPalCurrent As Integer '// Current palette in use
Dim fCapturingNow As Integer '// Capture in progress?
Dim dwReturn As Integer '// Error value after any operation
Dim wNumVideoAllocated As Integer '// Actual number of video buffers
Dim wNumAudioAllocated As Integer '// Actual number of audio buffers
End Structure
Declare Function capCreateCaptureWindowA Lib "avicap32.dll" _
(ByVal lpszWindowName As String, ByVal dwStyle As Integer, _
ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Short, ByVal hWndParent As Integer, _
ByVal nID As Integer) As Integer
Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Short, _
ByVal lpszName As String, ByVal cbName As Integer, ByVal lpszVer As String, _
ByVal cbVer As Integer) As Boolean
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
LoadDeviceList()
If Not Directory.Exists(Application.StartupPath & "\Images") Then
Directory.CreateDirectory(Application.StartupPath & "\Images")
End If
If lstDevices.Items.Count > 0 Then
btnStart.Enabled = True
lstDevices.SelectedIndex = 0
btnStart.Enabled = True
Else
lstDevices.Items.Add("No Capture Device")
btnStart.Enabled = False
End If
Me.AutoScrollMinSize = New Size(100, 100)
btnStop.Enabled = False
btnSave.Enabled = False
'picCapture.SizeMode = PictureBoxSizeMode.StretchImage
End Sub
Private Sub LoadDeviceList()
Dim strName As String = Space(100)
Dim strVer As String = Space(100)
Dim bReturn As Boolean
Dim x As Short = 0
'
' Load name of all avialable devices into the lstDevices
'
Do
'
' Get Driver name and version
'
bReturn = capGetDriverDescriptionA(x, strName, 100, strVer, 100)
'
' If there was a device add device name to the list
'
If bReturn Then lstDevices.Items.Add(strName.Trim)
x += CType(1, Short)
Loop Until bReturn = False
End Sub
Private Sub OpenPreviewWindow()
Dim iHeight As Integer = Piccapture.Height
Dim iWidth As Integer = Piccapture.Width
'
' Open Preview window in picturebox
'
hHwnd = capCreateCaptureWindowA(DeviceID.ToString, WS_VISIBLE Or WS_CHILD, 0, 0, 1280, _
1024, Piccapture.Handle.ToInt32, 0)
'
' Connect to device
'
If SendMessage(hHwnd, WM_CAP_DRIVER_CONNECT, DeviceID, 0) Then
'
'Set the preview scale
'
SendMessage(hHwnd, WM_CAP_SET_SCALE, True, 0)
'
'Set the preview rate in milliseconds
'
SendMessage(hHwnd, WM_CAP_SET_PREVIEWRATE, 66, 0)
'
'Start previewing the image from the camera
'
SendMessage(hHwnd, WM_CAP_SET_PREVIEW, True, 0)
'
' Resize window to fit in picturebox
'
SetWindowPos(hHwnd, HWND_BOTTOM, 0, 0, Piccapture.Width, Piccapture.Height, _
SWP_NOMOVE Or SWP_NOZORDER)
btnSave.Enabled = True
btnStop.Enabled = True
btnStart.Enabled = False
Else
'
MsgBox("No Device Connected", MsgBoxStyle.Information, "RStar")
'
DestroyWindow(hHwnd)
btnSave.Enabled = False
End If
End Sub
Private Sub btnStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStart.Click
DeviceID = lstDevices.SelectedIndex
'If DeviceID = 0 Then
' MsgBox("No Device Found", MsgBoxStyle.Information, "RStar")
' Exit Sub
'End If
OpenPreviewWindow()
Dim bReturn As Boolean
Dim s As CAPSTATUS
bReturn = SendMessage(hHwnd, WM_CAP_GET_STATUS, Marshal.SizeOf(s), s)
Debug.WriteLine(String.Format("Video Size {0} x {1}", s.uiImageWidth, s.uiImageHeight))
End Sub
Private Sub ClosePreviewWindow()
'
' Disconnect from device
'
SendMessage(hHwnd, WM_CAP_DRIVER_DISCONNECT, DeviceID, 0)
'
' close window
'
DestroyWindow(hHwnd)
End Sub
Private Sub btnStop_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStop.Click
ClosePreviewWindow()
btnSave.Enabled = False
btnStart.Enabled = True
btnStop.Enabled = False
End Sub
Private Sub btnSave_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnSave.Click
Dim data As IDataObject
Dim bmap As Bitmap
Dim filepath As String
'
' Copy image to clipboard
'
SendMessage(hHwnd, WM_CAP_EDIT_COPY, 0, 0)
'
' Get image from clipboard and convert it to a bitmap
'
data = Clipboard.GetDataObject()
If data.GetDataPresent(GetType(System.Drawing.Bitmap)) Then
bmap = CType(data.GetData(GetType(System.Drawing.Bitmap)), Bitmap)
Piccapture.Image = bmap
ClosePreviewWindow()
btnSave.Enabled = False
btnStop.Enabled = False
btnStart.Enabled = True
Trace.Assert(Not (bmap Is Nothing))
filepath = Application.StartupPath & "\Images\" & frmChartOfAccounts.txtAcName.Text & frmChartOfAccounts.txtRegNo.Text & ".jpeg"
bmap.Save(filepath)
frmChartOfAccounts.txtimg.Text = filepath
End If
End Sub
Private Sub Form1_Closing(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing
If btnStop.Enabled Then
ClosePreviewWindow()
End If
End Sub
Private Sub btnInfo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
'SendMessage(hHwnd, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub
Private Sub cmdExit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdExit.Click
Close()
End Sub
End Class
Hope it will help you.

Related

base64 string to byte to image

I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function

How can I get any Browser's URL in VB6?

Recently, I was trying to make a program for saving all visited URLs in a text file from any browser using Visual Basic 6. I have found some codes for VB.NET, but I like programming in VB6.
VB.NET Code for getting browser URL
Option Explicit On
Imports System.Text
Imports System.Runtime.InteropServices.Marshal
Module CurrentUrl
#Region " Overview & References "
'Overview:
'Function GetCurrentUrl returns the URL of the selected browser (IE or Chrome; Firefox to be added).
'Most of the code is based on the references listed below, but this function starts with
'the browser's main window handle and returns only 1 URL.
'It also builds a simple "treeview" of the windows up to the target window's classname.
'References:
'http://www.xtremevbtalk.com/archive/index.php/t-129988.html
'http://social.msdn.microsoft.com/forums/en-us/vbgeneral/thread/321D0EAD-CD50-4517-BC43-29190542DCE0
'http://social.msdn.microsoft.com/Forums/en/vbgeneral/thread/02a67f3a-4a26-4d9a-9c67-0fdff1428a66
#End Region
#Region " Declares, Constants, and Variables"
Private Delegate Function EnumProcDelegate(ByVal hwnd As IntPtr, ByVal lParam As IntPtr) As Boolean 'Delegate added
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As EnumProcDelegate, ByVal lParam As IntPtr) As Boolean
Private Declare Auto Function GetWindowText Lib "user32" (ByVal hWnd As IntPtr, ByVal lpString As StringBuilder, ByVal nMaxCount As Integer) As Integer
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As IntPtr, ByVal wCmd As IntPtr) As IntPtr
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As IntPtr, ByVal lpClassName As String, ByVal nMaxCount As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As IntPtr, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDFIRST = 0
Private sURL As String 'String that will contain the URL
Private cbWindows As ComboBox 'Treeview"
Private sIndent As String 'Spaces
Private sBrowser As String 'Starting window (IE or Chrome)
Private sClassName As String = "Edit" 'Default
#End Region
Public Function GetCurrentUrl(ByVal hwnd As IntPtr, ByVal browser As String, ByVal classname As String, ByVal combo As ComboBox) As String
sBrowser = browser
sClassName = classname
cbWindows = combo
If cbWindows IsNot Nothing Then
If cbWindows.GetType.Name = "ComboBox" Then
cbWindows.Items.Clear()
Else
cbWindows = Nothing
End If
End If
sURL = ""
sIndent = ""
EnumWindows(AddressOf EnumProc, hwnd) 'hwnd - originally IntPtr.Zero
Return sURL
End Function
' Enumerate the windows
' Find the URL in the browser window
Private Function EnumProc(ByVal hWnd As IntPtr, ByVal lParam As IntPtr) As Boolean
Dim buf As StringBuilder = New StringBuilder(256) 'String * 1024
Dim title As String
Dim length As Integer
' Get the window's title.
length = GetWindowText(hWnd, buf, buf.Capacity)
title = Left(buf.ToString, length)
' See if the title ends with the browser name
Dim s As String = sBrowser
Dim inprivate = sBrowser & " - [InPrivate]" 'IE adds this to the window title
If title <> "" Then
If (Right(title, s.Length) = s) Or (Right(title, inprivate.Length) = inprivate) Then
' This is it. Find the URL information.
sURL = EditInfo(hWnd, cbWindows)
Return False
End If
End If
' Continue searching
Return True
End Function
' If this window is of the Edit class (IE) or Chrome_AutocompleteEditView (Google), return its contents.
' Otherwise search its children for such an object.
Private Function EditInfo(ByVal window_hwnd As IntPtr, ByRef cbWindows As ComboBox) As String
Dim txt As String = ""
Dim buf As String
Dim buflen As Integer
Dim child_hwnd As IntPtr
Dim children() As IntPtr = {}
Dim num_children As Integer
Dim i As Integer
'Get the class name.
buflen = 256
buf = Space(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left(buf, buflen)
'Add an item to the window list combo, indent as required
If cbWindows IsNot Nothing Then
cbWindows.Items.Add(sIndent & buf)
End If
' See if we found an Edit/AutocompleteEditView object.
If buf = sClassName Then
Return WindowText(window_hwnd)
End If
' It's not an Edit/AutocompleteEditView object. Search the children.
' Make a list of the child windows.
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve children(0 To num_children) 'was 1 to ..
children(num_children) = child_hwnd
child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
End While
' Get information on the child windows.
sIndent &= " "
For i = 1 To num_children
txt = EditInfo(children(i), cbWindows)
If txt <> "" Then Exit For
Next i
sIndent = Left(sIndent, sIndent.Length - 4)
Return txt
End Function
' ************************************************
' Return the text associated with the window.
' ************************************************
Private Function WindowText(ByVal window_hwnd As IntPtr) As String
Dim txtlen As Integer
Dim txt As String
txt = "" 'WindowText = ""
If window_hwnd = 0 Then Return "" 'Exit Function
'Get the size of the window text
txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
If txtlen = 0 Then Return "" 'Exit Function
'Extra for terminating char
txtlen = txtlen + 1
'Alloc memory for the buffer that recieves the text
Dim buffer As IntPtr = AllocHGlobal(txtlen)
'Send The WM_GETTEXT Message
txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, buffer) 'byval txt
'Copy the characters from the unmanaged memory to a managed string
txt = PtrToStringAnsi(buffer)
Return Left(txt, txtlen)
End Function
End Module

MoveWindow API in windows 8

I need to open an external window from an external exe (eg Notepad) and move & size it to a predefined size & position.
I am trying to use MoveWindow API but is seems it is not working. I am using Windows 8 x64 and VS2012.
Here is my code:
<DllImport("user32.dll")> _
Public Function MoveWindow(ByVal hWnd As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Boolean) As Boolean
End Function
Public Sub NoveNotepad()
Dim ApplicationProcess = System.Diagnostics.Process.Start("Notepad.exe")
ApplicationProcess.WaitForInputIdle()
Dim ApplicationHandle = ApplicationProcess.MainWindowHandle
Dim z = MoveWindow(ApplicationHandle, 600, 600, 600, 600, True) ' THIS RETURNS TRUE
End Sub
You could try using SetWindowPos() instead? Not sure why MoveWindow() wouldn't work...
Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" _
(ByVal hwnd As IntPtr, ByVal hWndInsertAfter As Integer, _
ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, _
ByVal wFlags As Integer) As Integer
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim ApplicationProcess = System.Diagnostics.Process.Start("Notepad.exe")
ApplicationProcess.WaitForInputIdle()
Dim ApplicationHandle = ApplicationProcess.MainWindowHandle
SetWindowPos(ApplicationHandle, 0, 600, 600, 600, 600, 0)
End Sub

Saving a picture from a webcam displayed video in a PictureBox in VB6

I have used a code from the internet to show my webcam in a certain form, however, i dont know how to capture an image and save it automatically to my local disk drive via command button click. would anyone help me ASAP :))
here is my code for the form.
Option Explicit
Const ws_visible = &H10000000
Const ws_child = &H40000000
Const WM_USER = 1024
Const WM_CAP_EDIT_COPY = WM_USER + 30
Const wm_cap_driver_connect = WM_USER + 10
Const wm_cap_set_preview = WM_USER + 50
Const wm_cap_set_overlay = WM_USER + 51
Const WM_CAP_SET_PREVIEWRATE = WM_USER + 52
Const WM_CAP_SEQUENCE = WM_USER + 62
Const WM_CAP_SINGLE_FRAME_OPEN = WM_USER + 70
Const WM_CAP_SINGLE_FRAME_CLOSE = WM_USER + 71
Const WM_CAP_SINGLE_FRAME = WM_USER + 72
Const DRV_USER = &H4000
Const DVM_DIALOG = DRV_USER + 100
Const PREVIEWRATE = 30
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 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
Dim hwndc As Long
Dim saveflag As Integer
Dim pictureindex As Integer
Dim filter1(-1 To 1, -1 To 1) As Single
Dim filter2(-1 To 1, -1 To 1) As Single
Dim temp As String
Private Sub Command2_Click()
Unload Me
Main.Show
End Sub
Private Sub Form_Load()
On Error GoTo handler:
hwndc = capCreateCaptureWindow("CaptureWindow", ws_child Or ws_visible, 0, 0, Pichwnd.Width, Pichwnd.Height, Pichwnd.hWnd, 0)
If (hwndc <> 0) Then
temp = SendMessage(hwndc, wm_cap_driver_connect, 0, 0)
temp = SendMessage(hwndc, wm_cap_set_preview, 1, 0)
temp = SendMessage(hwndc, WM_CAP_SET_PREVIEWRATE, PREVIEWRATE, 0)
temp = SendMessage(Me.hWnd, WM_CAP_EDIT_COPY, 1, 0)
Picture1.Picture = Clipboard.GetData
Else
MsgBox "Unable to capture video.", vbCritical
End If
Exit Sub
handler:
End
End Sub
Private Sub Form_Initialize()
If Me.WindowState <> vbMaximized Then
Me.WindowState = vbMaximized
Else
Me.WindowState = vbNormal
End If
End Sub
my code might be too long but i just learned some vb6 via tutorials as i need to make a GUI to my Grad project. Finally thanks for help
Send the WM_CAP_FILE_SAVEDIB message to your hwndc with the filename to save to.
A better option is to handle the video callbacks yourself with WM_CAP_SET_CALLBACK_FRAME message or the capVideoStreamCallback callback function.
Also, take a look at the examples at http://www.shrinkwrapvb.com/videocap.htm.
Note that VfW capture is very outdated and should be replaced with Directshow (but is very difficult to do properly in VB6)

How can I stop Excel workbook flicker on automation open?

I'm using GetObject with a workbook path to either create a new or grab an existing Excel instance. If it's grabbing an existing user-created instance, the application window is visible; if the workbook path in question is closed, it will open and hide, but not before it flickers on the screen. Application.ScreenUpdating does not help with this.
I don't think I can use the Win32Api call LockWindowUpdate, because I don't know whether I'm getting or creating before the file is open. Is there some other VBA-friendly way (i.e. WinAPI) to freeze the screen long enough to get the object?
EDIT: Just to clarify, because the first answer suggests using the Application object... These are the steps to reproduce this behavior.
1. Open Excel--make sure you're only running one instance--save and close the default workbook. Excel window now visible but "empty"
2. Open Powerpoint or Word, insert a module, add the following code
Public Sub Open_SomeWorkbook()
Dim MyObj As Object
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'uncomment the next line to see the workbook again'
'MyObj.Parent.Windows(MyObj.Name).Visible = True'
'here's how you work with the application object... after the fact'
Debug.Print MyObj.Parent.Version
End Sub
Note the flicker as Excel opens the file in the existing instance, and then hides it... because it's automation
Note also, however, that there is no application object to work with, until the flickering is done. This is why I'm looking for some larger API method to "freeze" the screen.
Try,
Application.VBE.MainWindow.Visible = False
If that doesn't work try
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal ClassName As String, ByVal WindowName As String) As Long
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hWndLock As Long) As Long
Sub EliminateScreenFlicker()
Dim VBEHwnd As Long
On Error GoTo ErrH:
Application.VBE.MainWindow.Visible = False
VBEHwnd = FindWindow("wndclass_desked_gsk", _
Application.VBE.MainWindow.Caption)
If VBEHwnd Then
LockWindowUpdate VBEHwnd
End If
'''''''''''''''''''''''''
' your code here
'''''''''''''''''''''''''
Application.VBE.MainWindow.Visible = False
ErrH:
LockWindowUpdate 0&
End Sub
Both found here Eliminating Screen Flicker During VBProject Code
Ok you didn't mention multiple instances... [1. Open Excel--make sure you're only running one instance] :)
How about something like this.....
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
ByVal lCmdShow As Long) As Boolean
Public Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Sub GetWindowHandle()
Const SW_HIDE As Long = 0
Const SW_SHOW As Long = 5
Const SW_MINIMIZE As Long = 2
Const SW_MAXIMIZE As Long = 3
'Const C_WINDOW_CLASS = "XLMAIN"
Const C_WINDOW_CLASS = vbNullString
Const C_FILE_NAME = "Microsoft Excel - Flickerbook.xlsx"
'Const C_FILE_NAME = vbNullString
Dim xlHwnd As Long
xlHwnd = FindWindow(lpClassName:=C_WINDOW_CLASS, _
lpWindowName:=C_FILE_NAME)
'Debug.Print xlHwnd
if xlHwnd = 0 then
Dim MyObj As Object
Dim objExcel As Excel.Application
Set objExcel = GetObject(, "Excel.Application")
objExcel.ScreenUpdating = False
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'uncomment the next line to see the workbook again'
'MyObj.Parent.Windows(MyObj.Name).Visible = True
'here's how you work with the application object... after the fact'
Debug.Print MyObj.Parent.Version
MyObj.Close
objExcel.ScreenUpdating = True
else
'Either HIDE/SHOW or MINIMIZE/MAXIMISE
ShowWindow xlHwnd, SW_HIDE
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
ShowWindow xlHwnd, SW_SHOW
'Or LockWindowUpdate then Unlock
LockWindowUpdate xlHwnd
Set MyObj = GetObject("C:\temp\MyFlickerbook.xlsx")
'manage MyObj
LockWindowUpdate 0
end if
' 'Get Window Name
' Dim strWindowTitle As String
' strWindowTitle = Space(260) ' We must allocate a buffer for the GetWindowText function
' Call GetWindowText(xlHwnd, strWindowTitle, 260)
' debug.print (strWindowTitle)
End Sub
I ended up basically ditching GetObject, because it wasn't granular enough, and wrote my own flickerless opener, with some inspiration from osknows and great code samples from here and here. Thought I would share it in case others found it useful. First the complete module
'looping through, parent and child (see also callbacks for lpEnumFunc)
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
ByVal lParam As Long) As Long
'title of window
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
'class of window object
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
'control window display
Private Declare Function ShowWindow Lib "user32" (ByVal lHwnd As Long, _
ByVal lCmdShow As Long) As Boolean
Private Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Public Enum swcShowWindowCmd
swcHide = 0
swcNormal = 1
swcMinimized = 2 'but activated
swcMaximized = 3
swcNormalNoActivate = 4
swcShow = 5
swcMinimize = 6 'activates next
swcMinimizeNoActivate = 7
swcShowNoActive = 8
swcRestore = 9
swcShowDefault = 10
swcForceMinimized = 11
End Enum
'get application object using accessibility
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, _
ByVal dwId As Long, _
ByRef riid As GUID, _
ByRef ppvObject As Object) _
As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, _
ByRef lpiid As GUID) As Long
'Const defined in winuser.h
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
'IDispath pointer to native object model
Private Const Guid_Excel As String = "{00020400-0000-0000-C000-000000000046}"
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'class names to search by (Excel, in this example, is XLMAIN)
Private mstrAppClass As String
'title (a.k.a. pathless filename) to search for
Private mstrFindTitle As String
'resulting handle outputs - "default" app instance and child with object
Private mlngFirstHwnd As Long
Private mlngChildHwnd As Long
'------
'replacement GetObject
'------
Public Function GetExcelWbk(pstrFullName As String, _
Optional pbleShow As Boolean = False, _
Optional pbleWasOpenOutput As Boolean) As Object
Dim XLApp As Object
Dim xlWbk As Object
Dim strWbkNameOnly As String
Set XLApp = GetExcelAppForWbkPath(pstrFullName, pbleWasOpenOutput)
'other stuff can be done here if the app needs to be prepared for the load
If pbleWasOpenOutput = False Then
'load it, without flicker, if you plan to show it
If pbleShow = False Then
XLApp.ScreenUpdating = False
End If
Set xlWbk = XLApp.Workbooks.Open(pstrFullName)
Else
'get it by its (pathless, if saved) name
strWbkNameOnly = PathOrFileNm("FileNm", pstrFullName)
Set xlWbk = XLApp.Workbooks(strWbkNameOnly)
End If
Set GetExcelWbk = xlWbk
Set xlWbk = Nothing
Set XLApp = Nothing
End Function
Private Function GetExcelAppForWbkPath(pstrFullName As String, _
pbleWbkWasOpenOutput As Boolean, _
Optional pbleLoadAddIns As Boolean = True) As Object
Dim XLApp As Object
Dim bleAppRunning As Boolean
Dim lngHwnd As Long
'get a handle, and determine whether it's for a workbook or an app instance
lngHwnd = WbkOrFirstAppHandle(pstrFullName, pbleWbkWasOpenOutput)
'if a handle came back, at least one instance of Excel is running
'(this isnt' particularly useful; just check XLApp.Visible when you're done getting/opening;
'if it's a hidden instance, it wasn't running)
bleAppRunning = (lngHwnd > 0)
'get an app instance.
Set XLApp = GetAppForHwnd(lngHwnd, pbleWbkWasOpenOutput, pbleLoadAddIns)
Set GetExcelAppForWbkPath = XLApp
Set XLApp = Nothing
Exit Function
End Function
Private Function WbkOrFirstAppHandle(pstrFullName As String, _
pbleIsChildWindowOutput As Boolean) As Long
Dim retval As Long
'defaults
mstrAppClass = "XLMAIN"
mstrFindTitle = PathOrFileNm("FileNm", pstrFullName)
mlngFirstHwnd = 0
mlngChildHwnd = 0
'find
retval = EnumWindows(AddressOf EnumWindowsProc, 0)
If mlngChildHwnd > 0 Then
pbleIsChildWindowOutput = True
WbkOrFirstAppHandle = mlngChildHwnd
Else
WbkOrFirstAppHandle = mlngFirstHwnd
End If
'clear
mstrAppClass = ""
mstrFindTitle = ""
mlngFirstHwnd = 0
mlngChildHwnd = 0
End Function
Private Function GetAppForHwnd(plngHWnd As Long, _
pbleIsChild As Boolean, _
pbleLoadAddIns As Boolean) As Object
On Error GoTo HandleError
Dim XLApp As Object
Dim AI As Object
If plngHWnd > 0 Then
If pbleIsChild = True Then
'get the parent instance using accessibility
Set XLApp = GetExcelAppForHwnd(plngHWnd)
Else
'get the "default" instance
Set XLApp = GetObject(, "Excel.Application")
End If
Else
'no Excel running
Set XLApp = CreateObject("Excel.Application")
If pbleLoadAddIns = True Then
'explicitly reload add-ins (automation doesn't)
For Each AI In XLApp.AddIns
If AI.Installed Then
AI.Installed = False
AI.Installed = True
End If
Next AI
End If
End If
Set GetAppForHwnd = XLApp
Set AI = Nothing
Set XLApp = Nothing
Exit Function
End Function
'------
'API wrappers and utilities
'------
Public Function uWindowClass(ByVal hWnd As Long) As String
Dim strBuffer As String
Dim retval As Long
strBuffer = Space(256)
retval = GetClassName(hWnd, strBuffer, 255)
uWindowClass = Left(strBuffer, retval)
End Function
Public Function uWindowTitle(ByVal hWnd As Long) As String
Dim lngLen As Long
Dim strBuffer As String
Dim retval As Long
lngLen = GetWindowTextLength(hWnd) + 1
If lngLen > 1 Then
'title found - pad buffer
strBuffer = Space(lngLen)
'...get titlebar text
retval = GetWindowText(hWnd, strBuffer, lngLen)
uWindowTitle = Left(strBuffer, lngLen - 1)
End If
End Function
Public Sub uShowWindow(ByVal hWnd As Long, _
Optional pShowType As swcShowWindowCmd = swcRestore)
Dim retval As Long
retval = ShowWindow(hWnd, pShowType)
Select Case pShowType
Case swcMaximized, swcNormal, swcRestore, swcShow
BringWindowToTop hWnd
SetFocus hWnd
End Select
End Sub
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim strThisClass As String
Dim strThisTitle As String
Dim retval As Long
Dim bleMatch As Boolean
'mlngWinCounter = mlngWinCounter + 1
'type of window is all you need for parent
strThisClass = uWindowClass(hWnd)
bleMatch = (strThisClass = mstrAppClass)
If bleMatch = True Then
strThisTitle = uWindowTitle(hWnd)
'Debug.Print "Window #"; mlngWinCounter; " : ";
'Debug.Print strThisTitle; "(" & strThisClass & ") " & hWnd
If mlngFirstHwnd = 0 Then mlngFirstHwnd = hWnd
'mlngChildWinCounter 0
retval = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
If mlngChildHwnd > 0 Then
'If mbleFindAll = False And mlngChildHwnd > 0 Then
'stop EnumWindows by setting result to 0
EnumWindowsProc = 0
Else
EnumWindowsProc = 1
End If
Else
EnumWindowsProc = 1
End If
End Function
Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Dim strThisClass As String
Dim strThisTitle As String
Dim retval As Long
Dim bleMatch As Boolean
strThisClass = uWindowClass(hWnd)
strThisTitle = uWindowTitle(hWnd)
If Len(mstrFindTitle) > 0 Then
bleMatch = (strThisTitle = mstrFindTitle)
Else
bleMatch = True
End If
If bleMatch = True Then
mlngChildHwnd = hWnd
EnumChildProc = 0
Else
EnumChildProc = 1
End If
End Function
Public Function GetExcelAppForHwnd(pChildHwnd As Long) As Object
Dim o As Object
Dim g As GUID
Dim retval As Long
'for child objects only, e.g. must use a loaded workbook to get its parent Excel.Application
'make a valid GUID type
retval = IIDFromString(StrPtr(Guid_Excel), g)
'get
retval = AccessibleObjectFromWindow(pChildHwnd, OBJID_NATIVEOM, g, o)
If retval >= 0 Then
Set GetExcelAppForHwnd = o.Application
End If
End Function
Public Function PathOrFileNm(pstrPathOrFileNm As String, _
pstrFileNmWithPath As String)
On Error GoTo HandleError
Dim i As Integer
Dim j As Integer
Dim strChar As String
If Len(pstrFileNmWithPath) > 0 Then
i = InStrRev(pstrFileNmWithPath, "\")
If i = 0 Then
i = InStrRev(pstrFileNmWithPath, "/")
End If
If i > 0 Then
Select Case pstrPathOrFileNm
Case "Path"
PathOrFileNm = Left(pstrFileNmWithPath, i - 1)
Case "FileNm"
PathOrFileNm = Mid(pstrFileNmWithPath, i + 1)
End Select
ElseIf pstrPathOrFileNm = "FileNm" Then
PathOrFileNm = pstrFileNmWithPath
End If
End If
End Function
And then some sample/test code.
Public Sub Test_GetExcelWbk()
Dim MyXLApp As Object
Dim MyXLWbk As Object
Dim bleXLWasRunning As Boolean
Dim bleWasOpen As Boolean
Const TESTPATH As String = "C:\temp\MyFlickerbook.xlsx"
Const SHOWONLOAD As Boolean = False
Set MyXLWbk = GetExcelWbk(TESTPATH, SHOWONLOAD, bleWasOpen)
If Not (MyXLWbk Is Nothing) Then
Set MyXLApp = MyXLWbk.Parent
bleXLWasRunning = MyXLApp.Visible
If SHOWONLOAD = False Then
If MsgBox("Show " & TESTPATH & "?", vbOKCancel) = vbOK Then
MyXLApp.Visible = True
MyXLApp.Windows(MyXLWbk.Name).Visible = True
End If
End If
If bleWasOpen = False Then
If MsgBox("Close " & TESTPATH & "?", vbOKCancel) = vbOK Then
MyXLWbk.Close SaveChanges:=False
If bleXLWasRunning = False Then
MyXLApp.Quit
End If
End If
End If
End If
Set MyXLWbk = Nothing
Set MyXLApp = Nothing
End Sub
Hope someone else finds this useful.

Resources