I'm trying to fasten up the loading of one form, which populates several combobox with a big amount of data. I did my best stopping the UI while loading ecc shredding the loading time from 20s to 13s, but still the only bottleneck remaining is loading data into ComboBox which takes about 3-4s each. I did research on the internet and found that using Windows API you can fasten it up a lot more. So I did the code:
Private Const CB_ERR As Integer = -1
Private Const CB_ADDSTRING As Integer = &H143
Private Const CB_SETITEMDATA As Integer = &H151
<DllImport("user32.dll", CharSet:=CharSet.Auto)>
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As IntPtr, lParam As String) As IntPtr
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto)>
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As IntPtr, <MarshalAs(UnmanagedType.AsAny)> lParam As Object) As IntPtr
End Function
Public Sub AddItem(cmb As ComboBox, Item As Object)
Dim l As IntPtr
Dim kryptoncmb As KryptonComboBox
Try
kryptoncmb = TryCast(cmb.Parent.Parent, KryptonComboBox)
If kryptoncmb Is Nothing Then kryptoncmb = TryCast(cmb.Parent.Parent, KubaUtility.KryptonComboBox)
If kryptoncmb IsNot Nothing Then
l = SendMessage(kryptoncmb.Handle, CB_ADDSTRING, IntPtr.Zero, Item.ToString())
SendMessage(kryptoncmb.Handle, CB_SETITEMDATA, l, Item)
Else
l = SendMessage(cmb.Handle, CB_ADDSTRING, IntPtr.Zero, Item.ToString())
SendMessage(cmb.Handle, CB_SETITEMDATA, l, Item)
End If
Catch ex As Exception
End Try
End Sub
My problem is that when it gets to CB_SETITEMDATA, it tries to load the item's data but instead it throws an Exception:
No existing PInvoke conversion for the value passed to the Object type parameter.
The object I try to pass is a custom class but it's plain simple, just bunch of properties.
Related
I've searched, and can't seem to find an answer, so any help would be appreciated.
I want to make a hotkey, but when the hotkey is pressed, I don't want the actual "character" to be displayed, just the action to be performed.
So for example, I have this:
Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As KeyCodeConstants) As Long
Private Const VK_A = &H41
Private Sub keyboardTimer001_Timer()
If KeyDown(VK_A) Then
' do my stuff, but DONT DISPLAY the letter "A"
End If
end sub
So this basically just has a timer (interval 1) checking the async keyboard. If it detects that the letter "a" was pressed, I perform an action. But I want it to do this WITHOUT printing the letter "a".
How would I remove the key from the keyboard buffer/prevent it from displaying? (Side note - not sure if something like 'PeekMessage' would work - if so - does anyone know where I can find a good vb6 code sample where I can peek for stuff like 'ctrl+a' or 'ctrl+alt+a', etc, etc and then just clear the buffer, and perform my action?)
Thanks!
You can use a combination of RegisterHotKey and PeekMessage. The following code defines Key-A and Ctrl-A to perform actions:
Main Form
Option Explicit
Private Done As Boolean
Private Sub Form_Activate()
Done = False
RegisterHotKey Me.hWnd, &HBBBB&, MOD_NONE, vbKeyA
RegisterHotKey Me.hWnd, &HBBBA&, MOD_CONTROL, vbKeyA
ProcessMessages
End Sub
Private Sub ProcessMessages()
Dim Message As Msg
Do While Not Done
WaitMessage
If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then
If Message.wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf Message.wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End If
DoEvents
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
Done = True
Call UnregisterHotKey(Me.hWnd, &HBBBB&)
Call UnregisterHotKey(Me.hWnd, &HBBBA&)
End Sub
The above code works well, but in a production app I might lean towards subclassing the main window. If you prefer subclassing, you will need to use a technique of your choosing and replace the ProcessMessages method with something like this:
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_HOTKEY
If wParam = &HBBBB& Then
MsgBox "This is my Key-A action"
ElseIf wParam = &HBBBA& Then
MsgBox "This is my Ctrl-A action"
End If
End Select
End Function
As you can see, subclassing is a little cleaner. Of course, you need to define the Win API stuff. So in a module, place the following code:
Module
Option Explicit
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function WaitMessage Lib "user32" () As Long
Public Const MOD_NONE = &H0
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const MOD_WIN = &H8
Public Const PM_REMOVE = &H1
Public Const WM_HOTKEY = &H312
Public Type POINTAPI
x As Long
y As Long
End Type
Public Type Msg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
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
Is there a way to get the equivalent of VB's SelStart and SelLength properties from an Internet Explorer_Server object?
I've tried using SendMessage EM_GETSEL but it doesn't return anything.
You have to query the InternetExplorer_Server's HWND for its IHTMLDocument2 interface, and then you can use the browser's DOM interfaces to manipulate the browser content as needed:
How to get IHTMLDocument2 from a HWND
IHTMLDocument2::selection Property
Use this code where you want to calculate SelStart and SelLength. Replace InternetExplorer_Server.hWnd with a handle to your object.
Dim DomObj As IHTMLDocument2
Dim SelObj As IHTMLTxtRange
Set DomObj = IEDOMFromhWnd(InternetExplorer_Server.hWnd)
Set SelObj = DomObj.selection.createRange
TextToCheck$ = DomObj.body.innerText
' Calculate SelLength...
SelLength = Len(SelObj.Text)
SelObj.moveStart "character", -Len(TextToCheck$)
' Calculate SelStart...
SelStart = Len(SelObj.Text)
Requires the following code in a Module:
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Any, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As Long, riid As UUID, ByVal wParam As Long, ppvObject As Any) As Long
Public Function IEDOMFromhWnd(ByVal hwnd As Long) As IHTMLDocument2
Dim IID_IHTMLDocument2 As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hwnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument2
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes
hr = ObjectFromLresult(lRes, IID_IHTMLDocument2, 0, IEDOMFromhWnd)
End If
End Function
I have a listbox with a few thousand items. The code below given by #AngryHacker in this threat work perfect if i want to get the 1st match. But sometimes i have multiple items with the same data. So, i'd like to get all the match, how to do it?
oh, actually, its something like this:
aa4
sds
aa5
aa6
fdf
dsf
From the list, i want to get the index of the items starting with "aa"
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As _
Integer, ByVal lParam As Any) As Long
'constants for searching the ListBox
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_FINDSTRING = &H18F
'function to get find an item in the Listbox
Public Function GetListBoxIndex(hWnd As Long, SearchKey As String, Optional FindExactMatch As Boolean = True) As Long
If FindExactMatch Then
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRINGEXACT, -1, ByVal SearchKey)
Else
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRING, -1, ByVal SearchKey)
End If
End Function
You can utilize the fact that wParam for LB_FINDSTRING and LB_FINDSTRINGEXACT messages lets the caller to specify the first item to be searched:
wParam
The zero-based index of the item before the first item to be searched. When the search reaches the bottom of the list box, it continues searching from the top of the list box back to the item specified by the wParam parameter. If wParam is – 1, the entire list box is searched from the beginning.
So your GetListBoxIndex takes the following form (note StartIndex argument instead of hardcoded -1):
'LB_ constants
Private Const LB_ERR = -1
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "USER32" _
Alias "SendMessageA" (ByVal hWnd As Long _
, ByVal wMsg As Long _
, ByVal wParam As Integer _
, ByVal lParam As Any) As Long
Public Function GetListBoxIndex(hWnd As Long _
, SearchKey As String _
, StartIndex As Long _
, Optional FindExactMatch As Boolean = True) As Long
If FindExactMatch Then
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRINGEXACT, StartIndex, SearchKey)
Else
GetListBoxIndex = SendMessage(hWnd, LB_FINDSTRING, StartIndex, SearchKey)
End If
End Function
The rest depends on what you intend to do with the results afterwards. Below is simple test that merely prints results to Immediate window:
Private Sub Command1_Click()
PrintAllMatches List1.hWnd, Text1.Text
End Sub
Private Sub Form_Load()
List1.AddItem "aa1"
List1.AddItem "bbb"
List1.AddItem "aa2"
End Sub
Private Sub PrintAllMatches(hWnd As Long, SearchKey As String)
Dim firstMatch As Long, nextMatch As Long
nextMatch = GetListBoxIndex(hWnd, SearchKey, -1, False)
If nextMatch = LB_ERR Then
Debug.Print "Not found"
Exit Sub
End If
firstMatch = nextMatch
Do
Debug.Print "Match is at index " & nextMatch
nextMatch = GetListBoxIndex(hWnd, SearchKey, nextMatch, False)
Loop While nextMatch <> firstMatch
End Sub
I have similar case like this how to solve the following code,
Adodc1.Recordset.MoveFirst Adodc1.Recordset.Find "DEBTOR_CODE = '" & Text11.Text & "'" If Adodc1.Recordset.EOF = True Or Adodc1.Recordset.BOF = True Then MsgBox "Record Not Found!", vbApplicationModal Adodc1.Recordset.MoveFirst Me.Combo1.SetFocus Me.Combo1.ListIndex = Me.Text11.Text End If
i have to search debtor_code and each debtor has multiple addresses, i need to get the multiple answers in a combo box
I created a form that has 2 buttons. One button pops a msgbox and the other runs form frmAPI (code is listed below) listed below. If I open the msgbox and leave it open and then run the frmAPI it will list the msgbox and its text and then close it. THis is what I expect it to do. If I open another application and generate a msgbox in that app with my frmAPI still running it will in fact list the other apps msgbox and the text but it does not close the msgbox from the other app. If Irun the frmAPI from the other app and do the same test the results are reversed. So in short it will only close the dialog from within the same app.
I would like to be able to close a dialog from any app based on it being a dialog and having text that will match my criteria. Any help on what I am doing wrong?
Thanks
Imports System.Runtime.InteropServices
Imports System.Text
Partial Public Class TestMSgBoxStuff
Inherits Form
Public Sub New()
InitializeComponent()
End Sub
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindow(lpClassName As String, lpWindowName As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function FindWindowEx(hwndParent As IntPtr, hwndChildAfter As IntPtr, lpszClass As String, lpszWindow As String) As IntPtr
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto, SetLastError:=True)> _
Private Shared Function GetWindowText(hWnd As IntPtr, lpString As StringBuilder, nMaxCount As Integer) As Integer
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function GetWindowTextLength(hWnd As IntPtr) As Integer
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function SendMessage(hWnd As HandleRef, Msg As UInteger, wParam As IntPtr, lParam As IntPtr) As IntPtr
End Function
<DllImport("user32", CharSet:=Runtime.InteropServices.CharSet.Auto, SetLastError:=True, ExactSpelling:=True)>
Private Shared Function SetForegroundWindow(ByVal hwnd As IntPtr) As IntPtr
End Function
Private Const WM_IME_NOTIFY As Integer = &H282
Private Const WM_DESTROY As Integer = &H2
Private Const WM_NCDESTROY As Integer = &H82
Private Const WM_CLOSE As Integer = &H10
Private Const IMN_CLOSESTATUSWINDOW As Integer = &H1
Private Const WM_KILLFOCUS As Integer = &H8
Private Const WM_COMMAND As Integer = &H11
Private Sub TestMSgBoxStuff_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Dim timer As New Timer()
Timer1.Interval = 10000
'detect the MessageBox every seconds
'Timer1.Tick += New EventHandler(Timer1_Tick)
Timer1.Start()
End Sub
Private Sub Timer1_Tick(sender As System.Object, e As System.EventArgs) Handles Timer1.Tick
'Get the MessageBox handle
Dim handle As IntPtr = FindWindow("#32770", Nothing)
Me.RichTextBox1.AppendText("Handle: " + handle.ToString() + vbLf)
'Get the Text window handle
Dim txtHandle As IntPtr = FindWindowEx(handle, IntPtr.Zero, "Static", Nothing)
Me.RichTextBox1.AppendText(vbTab & "text handle: " + txtHandle.ToString() + vbLf)
Dim len As Integer = GetWindowTextLength(txtHandle)
Dim sb As New StringBuilder()
'Get the text
GetWindowText(txtHandle, sb, len + 1)
Me.RichTextBox1.AppendText(vbTab & "text: " + sb.ToString() + vbLf & vbLf)
Me.RichTextBox1.ScrollToCaret()
SetForegroundWindow(handle)
'close the messagebox WM_CLOSE
Dim lResults As Integer = SendMessage(New HandleRef(Nothing, handle), WM_NCDESTROY, IntPtr.Zero, IntPtr.Zero)
End Sub
End Class
You may be running into User Interface Privilege Isolation. That'll block your messages from going to a higher privilege process. See also ChangeWindowsMessageFilter()
I'd suggest trying to send it a WM_COMMAND instead of a WM_CLOSE; WM_COMMAND is generally treated more gently by the system and may get through. Use BN_CLICKED as the high word of WPARAM and IDOK as the low word (assuming it has an OK button), and the handle to the OK button in LPARAM.. Other button messages are here.