How to enable free diction speech recognition in VB6 using SAPI - vb6

Recently I have been attempting to create a chatbot for school, and one of the features I wanted was speech recognition. Unfortunately, due to the deprecated nature of VB6, there are very few tutorials on using SAPI for speech recognition with VB6, and none at all for enabling free diction (simply speaking without a grammar set and converting speech into text).

Automation Interfaces and Objects (SAPI 5.4) has the documentation.
Trivial example:
Option Explicit
'See "Automation Interfaces and Objects (SAPI 5.4)" at MSDN.
Private WithEvents RC As SpeechLib.SpInProcRecoContext
Private RG As SpeechLib.ISpeechRecoGrammar
Private Sub Form_Load()
With New SpeechLib.SpInprocRecognizer
Set RC = .CreateRecoContext()
Set .AudioInput = .GetAudioInputs().Item(0)
End With
With RC
.EventInterests = SRERecognition Or SREFalseRecognition
Set RG = .CreateGrammar()
End With
RG.DictationSetState SGDSActive
End Sub
Private Sub Form_Resize()
If WindowState <> vbMinimized Then
Text1.Move 0, 0, ScaleWidth, ScaleHeight
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
RG.DictationSetState SGDSInactive
End Sub
Private Sub RC_FalseRecognition( _
ByVal StreamNumber As Long, _
ByVal StreamPosition As Variant, _
ByVal Result As SpeechLib.ISpeechRecoResult)
With Text1
.SelStart = &H7FFF
.SelText = "False Rec: "
.SelText = Result.PhraseInfo.GetText()
.SelText = vbNewLine
End With
End Sub
Private Sub RC_Recognition( _
ByVal StreamNumber As Long, _
ByVal StreamPosition As Variant, _
ByVal RecognitionType As SpeechLib.SpeechRecognitionType, _
ByVal Result As SpeechLib.ISpeechRecoResult)
With Text1
.SelStart = &H7FFF
.SelText = "Rec: "
.SelText = Result.PhraseInfo.GetText()
.SelText = vbNewLine
End With
End Sub

Related

vb6 WebView2 get innerhtml and http cookies data

How do I Get the Login Cookies when am logged into a site?
I am searching for answers and now turned to StackOverflow pro members for your expertise and help to get this out of the way so I can move on to making my software.
i need to get the cookies login/visit /get/post anything how do i get it using the new webview2 browser kindly shed some light please anyone
Option Explicit
'Note, that this Demo requires the properly registered RC6-Binaries
'and in addition an installed "Chromium-Edge" (in its "evergreen" WebView2-incarnation)
'installable from its official MS-Download-URL: https://go.microsoft.com/fwlink/p/?LinkId=2124703
Private WithEvents WV As cWebView2 'declare a WebView-variable WithEvents
Private Sub Form_Load()
Visible = True '<- it's important, that the hosting TopLevel-Form is visible...
'...(and thus the Child-PicBox indirectly as well) - before we Bind the PicBox to the WebView
Set WV = New_c.WebView2 'create the instance
If WV.BindTo(picWV.hWnd) = 0 Then MsgBox "couldn't initialize WebView-Binding": Exit Sub
' Set WV = New_c.WebView2(picWV.hWnd) 'create the instance
' If WV Is Nothing Then MsgBox "couldn't initialize WebView-Binding": Exit Sub
End Sub
'*** VB-Command-Button-Handlers
Private Sub cmdNavigate_Click()
WV.Navigate "https://google.com" '<- alternatively WV.jsProp("location.href") = "https://google.com" would also work
'the call below, just to show that our initially added js-functions, remain "in place" - even when we re-navigate to something else
WV.jsRunAsync "test", 2, 3
End Sub
Private Sub WV_NavigationCompleted(ByVal IsSuccess As Boolean, ByVal WebErrorStatus As Long)
Debug.Print "NavigationCompleted welaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
End Sub
Private Sub picWV_Resize() 'when the hosting picBox got resized, we have to call a syncSize-method on the WebView
If Not WV Is Nothing Then WV.SyncSizeToHostWindow
End Sub
Private Sub picWV_GotFocus() 'same thing here... when the hosting picBox got the focus, we tell the WebView about it
If Not WV Is Nothing Then WV.SetFocus
End Sub
'*** the above two EventHandlers (of the hosting VB-PicBox-Container-Ctl) are basically all what's needed "GUI-Binding-wise"
'*** the rest of the EventHandlers below, are raised by the WebView-instance itself
Private Sub WV_InitComplete()
Debug.Print "WV_InitComplete"
End Sub
'Private Sub WV_NavigationCompleted(ByVal IsSuccess As Long, ByVal WebErrorStatus As Long)
'Debug.Print "WV_NavigationCompleted"
'End Sub
Private Sub WV_DocumentComplete()
Debug.Print "WV_DocumentComplete"
End Sub
Private Sub WV_GotFocus(ByVal Reason As eWebView2FocusReason)
Debug.Print "WV_GotFocus", Reason
End Sub
Private Sub WV_JSAsyncResult(Result As Variant, ByVal Token As Currency, ByVal ErrString As String)
Debug.Print "WV_JSAsyncResult "; Result, Token, ErrString
Text2.Text = Result
End Sub
Private Sub WV_JSMessage(ByVal sMsg As String, ByVal sMsgContent As String, oJSONContent As cCollection)
Debug.Print sMsg, sMsgContent
Select Case sMsg
Case "btn1_click": MsgBox "txt1.value: " & WV.jsProp("document.getElementById('txt1').value")
End Select
End Sub
Private Sub WV_LostFocus(ByVal Reason As eWebView2FocusReason)
Debug.Print "WV_LostFocus", Reason
End Sub
Private Sub WV_UserContextMenu(ByVal ScreenX As Long, ByVal SreenY As Long)
Debug.Print "WV_UserContextMenu", ScreenX, SreenY
End Sub

String Search in files and populate results as Drop Down list or Combo Box in VB6(Visual basic)

I want to store string variable from the user and then I want to search that string in files of a specific folder. I want to match the stored string within each file. If I find a match to the string, I want a list box or Combo box to be populated with the name of the files. I am working in Visual basic (VB6).
I tried Some VB.net code like getfiles() but those are not working in VB6.
If you index the target folder you can use Windows Search:
Option Explicit
Private Const INDEXED_FOLDER_PATH As String = _
"C:\Program Files\Windows Kits\10\Include\10.0.16299.0\um"
Private WithEvents CN As ADODB.Connection
Private Sub CN_ExecuteComplete( _
ByVal RecordsAffected As Long, _
ByVal pError As ADODB.Error, _
ByRef adStatus As ADODB.EventStatusEnum, _
ByVal pCommand As ADODB.Command, _
ByVal pRecordset As ADODB.Recordset, _
ByVal pConnection As ADODB.Connection)
If adStatus <> adStatusOK Then
MousePointer = vbDefault
'Sadly this DSO is lazy about providing a Description here, so it
'will often be empty along with an empty Errors collection.
MsgBox "Error " & pError.Number & vbNewLine _
& vbNewLine _
& pError.Description
Else
With pRecordset
If .EOF Then
List1.AddItem "*no hits*"
Else
Do Until .EOF
List1.AddItem .Fields(0).Value
.MoveNext
Loop
End If
.Close
End With
MousePointer = vbDefault
End If
Text1.SetFocus
End Sub
Private Sub Command1_Click()
MousePointer = vbHourglass
List1.Clear
'We are doing an async request here because depending on what we are asking
'for it might take a few seconds:
CN.Execute "SELECT System.ItemNameDisplay" _
& " FROM SystemIndex" _
& " WHERE DIRECTORY='file:" & Replace$(INDEXED_FOLDER_PATH, "\", "/") & "'" _
& " AND FREETEXT('" & Text1.Text & "')", _
, _
adCmdText Or adAsyncExecute
End Sub
Private Sub Form_Load()
Set CN = New ADODB.Connection
CN.Open "Provider=Search.CollatorDSO;Extended Properties='Application=Windows'"
End Sub
Private Sub Form_Unload(Cancel As Integer)
CN.Close
End Sub
More info: Querying the Index with Windows Search SQL Syntax

Problems opening and closing the mscomm port in vb6 when interfacing microcontroller

the code is to get data from a microcontroller or any device from serial device using serial port,so i am having problem with port opening and getting data,am having this problem for last 20 days please kindly help me at the earliest :)
Private Sub Command1_Click()
MsgBox ("The port is open " & MSComm1.PortOpen)
If (MSComm1.PortOpen = False) Then
MSComm1.PortOpen = True
End If
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
If (MSComm1.PortOpen = True) Then
MSComm1.PortOpen = False
End If
Command1.Enabled = True
Command2.Enabled = False
End Sub
Private Sub Form_Load()
With MSComm1
.CommPort = 1
.RThreshold = 1
.RTSEnable = True
.Settings = "9600,N,8,1"
.InputLen = 127
.SThreshold = 1
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
If (MSComm1.PortOpen = True) Then
MSComm1.PortOpen = False
End If
End Sub
Private Sub MSComm1_OnComm()
Dim Buffer As String
Select Case MSComm1.CommEvent
Case comEvReceive
'Text1.Text = " "
Buffer = MSComm1.Input
Text1.Text = Text1.Text & Buffer
End Select
End Sub!
Below is the image of interface which contains the MScomm control ,a text box , two command buttons for connecting and disconnecting :
'****** paste this in form'*********
Option Explicit
Dim Portnumber As Integer
Private Sub cmdClose_Click()
On Error GoTo handler
MSComm1.PortOpen = False
Shape1.FillColor = vbRed
cmdOpen.Enabled = True
txtRecieve.Text = ""
Exit Sub
handler: MsgBox Err.Description
End Sub
Private Sub cmdOpen_Click()
On Error GoTo handler
' Debug.Print cboComm.ItemData(cboComm.ListIndex)
portnumber = Mid(cboComm.Text, 4, (Len(cboComm.Text) - 3))
a = Mid(cboComm.Text, 4, (Len(cboComm.Text) - 3))
' If MSComm1.PortOpen = False Then
MSComm1.CommPort = portnumber
MSComm1.PortOpen = True
Shape1.FillColor = vbGreen
cmdOpen.Enabled = False
' End If
Exit Sub
handler: MsgBox Err.Description
End Sub
Private Sub Form_Load()
cboComm.Clear '*** cbo is for combobox
MSComm1.Settings = "9600,n,8,1"
ListComPorts
End Sub
Private Sub ListComPorts()
Dim i As Integer
cboComm.Clear
Static iData As Integer
iData = -1
For i = 1 To 16
If ComAvailable(i) Then
cboComm.AddItem (("COM") & i)
iData = iData + 1
cboComm.ItemData(iData) = i
End If
Next
cboComm.ListIndex = 0
' cmdGet.Enabled = False
End Sub
Private Sub MSComm1_OnComm()
Select Case MSComm1.CommEvent
Case comEvReceive
txtRecieve.Text = MSComm1.Input
Case Else
Debug.Print "Event: " & MSComm1.CommEvent
End Select
End Sub
'**************** End of form code **************
'*********** Now API code******************
'********** Paste in Module**************
Option Explicit
'*** API Declarations
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'*** API Structures
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
'***API Constants
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const OPEN_EXISTING = 3
Public Const FILE_ATTRIBUTE_NORMAL = &H80
'*** Create a Fuction to check whether COM exists or not. If exists return "true" otherwise "false"
Public Function ComAvailable(comnum As Integer) As Boolean
Dim hcom As Long
Dim ret As Long
Dim sec As SECURITY_ATTRIBUTES
hcom = CreateFile("\.\COM" & comnum & "", 0, FILE_SHARE_READ + FILE_SHARE_WRITE, sec, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If hcom = -1 Then
ComAvailable = False
Else
ComAvailable = True
'*** close the CO MPort
ret = CloseHandle(hcom)
End If
End Function
''''''''*******End of module code********
I think this will help you.....
If you get error 8002 then the port probably doesn't exist.
Are you using an rs232 connection, or are you connect via an USB port?
Have a look at the code i posted here .... when you run it, it will give a list of available ports on your system.

Get list of installed network card

I want to fill the combo box with all the installed network adapter name using visual basic 6.0. Is there any way to do so? I also want to know how to add, edit and delete the value of registry?
Simplest way would be to shell out to the ipconfig command, redirect the output to a file, and then parse the file. There are many implementations of a function usually called "ShellAndWait()". I've taken one I had squirreled away - it might not be the best, but it works.
Option Explicit
Private Declare Function CloseHandle Lib "Kernel32.dll" ( _
ByVal hHandle As Long _
) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long _
) As Long
Private Declare Function WaitForSingleObject Lib "Kernel32.dll" ( _
ByVal hHandle As Long, _
ByVal dwMilliseconds As Long _
) As Long
Private Const INFINITE As Long = -1&
Private Const SYNCHRONIZE As Long = &H100000
Private Sub Form_Load()
Dim oNetworkAdapters As VBA.Collection
Dim vNetworkAdapter As Variant
Set oNetworkAdapters = GetNetworkAdapters()
cmbNICs.Clear
For Each vNetworkAdapter In oNetworkAdapters
cmbNICs.AddItem vNetworkAdapter
Next vNetworkAdapter
End Sub
Public Function GetNetworkAdapters() As VBA.Collection
Dim sTempFileName As String
Dim nFileNo As Integer
Dim sLine As String
Dim oNetworkAdapters As VBA.Collection
Set oNetworkAdapters = New VBA.Collection
sTempFileName = Environ$("TEMP") & "\VBTmp" & Format$(Now, "yyyymmddhhnnss")
If ShellAndWait("cmd.exe /c ipconfig > """ & sTempFileName & """", vbHide) Then
nFileNo = FreeFile
Open sTempFileName For Input As #nFileNo
Do Until EOF(nFileNo)
Line Input #nFileNo, sLine
If Len(sLine) > 0 Then
If sLine Like "*:" Then
If Not sLine Like " *:" Then
oNetworkAdapters.Add sLine
End If
End If
End If
Loop
Close #nFileNo
Kill sTempFileName
End If
Set GetNetworkAdapters = oNetworkAdapters
End Function
' Start the indicated program and wait for it to finish, hiding while we wait.
Public Function ShellAndWait(ByRef in_sProgramName As String, _
ByVal in_enmWindowStyle As VbAppWinStyle) As Boolean
Dim nProcessId As Long
Dim hProcess As Long
' Start the program.
On Error GoTo ShellError
nProcessId = Shell(in_sProgramName, in_enmWindowStyle)
On Error GoTo 0
DoEvents
' Wait for the program to finish.
' Get the process handle.
hProcess = OpenProcess(SYNCHRONIZE, 0, nProcessId)
If hProcess <> 0 Then
WaitForSingleObject hProcess, INFINITE
CloseHandle hProcess
End If
ShellAndWait = True
Exit Function
ShellError:
MsgBox "Error starting task '" & in_sProgramName & "'" & vbCrLf & Err.Description, vbOKOnly Or vbExclamation, "Error"
End Function
Here is the simple code that will detect all Ethernet and wireless adaptors
NetworkInterface slectedNic;
IEnumerable<NetworkInterface> nics = NetworkInterface.GetAllNetworkInterfaces().Where(network => network.OperationalStatus == OperationalStatus.Up && (network.NetworkInterfaceType == NetworkInterfaceType.Ethernet || network.NetworkInterfaceType == NetworkInterfaceType.Wireless80211));
foreach (NetworkInterface item in nics)
{
cmbAdptors.Items.Add(item);
}
but if u want to detect only active wireless adaptor
change
.Where(network => network.OperationalStatus == OperationalStatus.Up && (network.NetworkInterfaceType == NetworkInterfaceType.Ethernet || network.NetworkInterfaceType == NetworkInterfaceType.Wireless80211));
to
.Where(network => network.OperationalStatus == OperationalStatus.Up && network.NetworkInterfaceType == NetworkInterfaceType.Wireless80211)

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