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 Integer, lParam As String) As Integer
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto)>
Private Function SendMessage(ByVal hWnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Object) As Integer
End Function
Public Sub AddItem(cmb As ComboBox, Item As Object)
Dim l As Integer
l = SendMessage(cmb.Handle, CB_ADDSTRING, 0&, Item.ToString())
SendMessage(cmb.Handle, CB_SETITEMDATA, l, Item)
End Sub
But on CB_ADDSTRING the program crashes with this error (that can be catched):
InvalidArgument=Value of '0' not valid for 'index'. Parameter Name: index
Since I'm using Krypton Controls, I had to shuffle trough Parents until I found KryptonComboBox, and then pass it's Handle value.
Related
I am using Common Dialog Control of VB6 to select Font by calling ShowFont method. Here I can select desired font, font size, bold, italic, strike thru etc. I also select Arabic from script combo box. The problem is not able to get the value which I selected from the Script combo box. Any one please help.
Code:
With CommonDialog1.ShowFont
FontObject.Name = .FontName
FontObject.Bold = .FontBold
FontObject.Italic = .FontItalic
FontObject.Size = .FontSize
FontObject.Strikethrough = .FontStrikethru
FontObject.Underline = .FontUnderline
End With
You have two options:
Subclass the Common Dialog Window -
Here is an example from VBForum
Use the Windows API to call the ChooseFont Common Dialog by your self
Here is a snippet using the second approach:
Option Explicit
Private FontObject As New StdFont
Const FW_REGULAR As Integer = 400
Const FW_BOLD As Integer = 700
Const CF_BOTH = &H3
Const CF_EFFECTS = &H100
Const CF_INITTOLOGFONTSTRUCT = &H40
Const LF_FACESIZE = 32
Const LOGPIXELSY As Long = 90
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ChooseFontA Lib "comdlg32.dll" (pChoosefont As CHOOSEFONT) As Long
Private Sub String2ByteArr(ByVal str As String, ByRef arr)
Dim b() As Byte, i As Long, l As Long
b = StrConv(str & Chr(0), vbFromUnicode)
l = UBound(b)
For i = 0 To l
arr(i) = b(i)
Next
End Sub
Private Function ByteArr2String(ByRef arr) As String
Dim b() As Byte
b = StrConv(arr, vbUnicode)
bytearray2string = Left$(b, InStr(b, Chr$(0)) - 1)
End Function
Private Sub FontDialog()
Dim cf As CHOOSEFONT, lf As LOGFONT, hWnd As Long, hDC As Long, ppi As Long
hWnd = GetDesktopWindow
hDC = GetDC(hWnd)
ppi = GetDeviceCaps(hDC, LOGPIXELSY)
With lf
String2ByteArr FontObject.Name, lf.lfFaceName
.lfHeight = -(FontObject.Size * ppi) / 72
.lfWeight = IIf(FontObject.Bold, FW_BOLD, FW_REGULAR)
.lfItalic = FontObject.Italic
.lfUnderline = FontObject.Underline
.lfStrikeOut = FontObject.Strikethrough
.lfCharSet = FontObject.Charset
End With
With cf
.lStructSize = Len(cf)
.hDC = hDC
.flags = CF_BOTH Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
.hwndOwner = Me.hWnd
.lpLogFont = VarPtr(lf)
.lpTemplateName = vbNullString
End With
If ChooseFontA(cf) Then
With FontObject
.Name = ByteArr2String(lf.lfFaceName)
.Size = (-72 * lf.lfHeight) / ppi
.Bold = lf.lfWeight >= FW_BOLD
.Italic = lf.lfItalic
.Underline = lf.lfUnderline
.Strikethrough = lf.lfStrikeOut
.Charset = lf.lfCharSet
End With
' If you choose Arabic charset, this will print 178
Debug.Print "CharSet:", FontObject.Charset
End If
Call ReleaseDC(hWnd, hDC)
End Sub
Please note: as this topic is quite old, you will find many other examples by googling on the net (ChooseFont: Using the ChooseFont Common Dialog API, Karl E. Peterson and so on).
All.
I'm attempting to develop a 'sidebar' application with vb6, which I want to behave like windows Vista's gadget sidebar or Google Desktop sidebar, in the respect that other windows could not maximize over it.
I'm aware that chances of this happening are probably very little, but I'm asking just in case.
Currently, I've got a form that has multiple controls, and runs a function on load which makes itself the exact height of the screen, minus the taskbar, and it's 'left' location is set by a timer to be 'screen.width - me.width', so it will start at full height on the far right of the screen, and cannot be moved. Code for the height is as follows, if it is necessary.
Declare Function GetUserNameA Lib "advapi32.dll" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" ( _
ByVal hwnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Public Const GWL_STYLE = (-16)
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2
Private Const ABM_GETTASKBARPOS = &H5
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long
End Type
Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Function Fixheight()
Dim ABD As APPBARDATA
SHAppBarMessage ABM_GETTASKBARPOS, ABD
Form1.Height = Screen.Height - ((ABD.rc.Bottom - ABD.rc.Top) * 12)
If Form1.Height <= 600 Then
Form1.Height = Screen.Height
End If
End Function
To be clear, I do not want an 'always on top' function. I already have that, and it's driving me insane, as the form has to me closed or minimized in order to maximize, minimize of close another program (i.e. chrome, word, etc) behind it. This form must instead not allow other programs to maximize over it, so that if for example, the user maximized Chrome, chrome would maximize minus form1.width.
I doubt that this is possible because as far as I'm concerned, that would mean taking control of chrome, and essentially making it's maximize function as
me.height = screen.height - ((ABD.rc.Bottom - ABD.rc.Top) * 12)
me.width = screen.width - form1.width
which isn't possible.
Anyway, hopefully someone out there can help. As I said, I seriously doubt the possibility of having this work, but if so, all the better.
Thanks in advance!
Thanks to Ken White, I googled SHAppBarMessage and found the following website, offering a downloadable source with the very feature I needed. I just have to implement it now!!
Very glad I asked! Thank you!
Edit: Found this spanish website, which while needed some help from Google Translate, is more suited to my needs. Just need to figure out how to make it work on the Right Hand Side! Thanks again!
I am trying to get the UserAgent of the default browser using the ObtainUserAgentString API in Visual Basic 6. I found the documentation on the MSDN and tried to convert it to Visual Basic 6 but it did not work.
C++ (MSDN)
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Visual Basic 6 API
Private Declare Function ObtainUserAgentString Lib "Urlmon.dll" (ByVal dwOption As Long, ByRef pcszUAOut As String, ByRef cbSize As Long) As Long
Private Function BrowserUserAgent() As String
Dim httpUseragent As String
Dim szhttpUserAgent As Long
httpUseragent = Space(512)
szhttpUserAgent = Len(httpUseragent)
Call ObtainUserAgentString(0, httpUseragent, szhttpUserAgent)
BrowserUserAgent = httpUseragent
End Function
Private Sub Command1_Click()
MsgBox BrowserUserAgent
End Sub
Aside from the fact this is a cruddy old ANSI entrypoint, everything you need appears to be documented.
Option Explicit
Private Const NOERROR As Long = 0
Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Enum UAS_OPTIONSENUM
[_UAS_EXACTLEGACY] = &H1000&
UAS_DEFAULT = 0
UAS_7 = 7 'Compatible mode.
UAS_7_LEGACY = 7 Or [_UAS_EXACTLEGACY]
UAS_8 = 8
UAS_9 = 9
UAS_10 = 10
UAS_11 = 11
End Enum
Private Declare Function ObtainUserAgentString Lib "urlmon" ( _
ByVal dwOption As Long, _
ByVal pcszUAOut As Long, _
ByRef cbSize As Long) As Long
Private Function BrowserUserAgent( _
Optional ByVal Options As UAS_OPTIONSENUM = UAS_DEFAULT) As String
Const MAX_BUFFER As Long = 2048
Dim Size As Long
Dim Buffer() As Byte
Dim HRESULT As Long
Do
Size = Size + 128
ReDim Buffer(Size - 1)
HRESULT = ObtainUserAgentString(Options, VarPtr(Buffer(0)), Size)
Loop While HRESULT = E_OUTOFMEMORY And Size < MAX_BUFFER
If HRESULT = NOERROR Then
BrowserUserAgent = StrConv(LeftB$(Buffer, Size - 1), vbUnicode)
Else
Err.Raise &H8004D000, _
, _
"ObtainUserAgentString error &H" & Hex$(HRESULT)
End If
End Function
Private Sub Form_Load()
AutoRedraw = True
Print BrowserUserAgent()
Print BrowserUserAgent(UAS_7)
Print BrowserUserAgent(UAS_7_LEGACY)
Print BrowserUserAgent(UAS_8)
Print BrowserUserAgent(UAS_11)
End Sub
HRESULT ObtainUserAgentString(
_In_ DWORD dwOption = 0,
_Out_ LPCSTR *pcszUAOut,
_Out_ DWORD *cbSize
);
Param 2 is LongPointerCString. You always pass C strings ByVal which in reality passes the C string part of the B String ByRef. If it was a IN param you would have to end the string with a Chr(0) which is what real C strings have.
String arguments are a special case. Passing a string by value means you are passing the address of the first data byte in the string; passing a string by reference means you are passing the memory address where another address is stored; the second address actually refers to the first data byte of the string. How you determine which approach to use is explained in the topic "Passing Strings to a DLL Procedure" later in this chapter.
From Visual Basic Concepts in Help.
hello friends，i want to monitor an IP address control's（created by CreateWindowEx） input events which is on a form.i have used the API SetWindowsHookEx to hook WH_GETMESSAGE message ,but now i cannt eat the input message as (MSG)lParam->message = WM_NULL like in C,So i need your help,friends. can you give me the solution?
here is the code:
Private Function GetMsgProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Long) As Long
CopyMemory p, ByVal lParam, LenB(p)
If p.message = WM_RBUTTONDOWN And GetParent(p.hWnd) = lngHWNDCtl Then
GetMsgProc = 0
Else
GetMsgProc = CallNextHookEx(hHook, nCode, wParam, ByVal lParam)
End If
End Function
Public Sub SetHook(ByVal lngThread As Long, lngHWND As Long, bFlag As Boolean)
If bFlag Then
lngHWNDCtl = lngHWND
hHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf GetMsgProc, 0, lngThread)
Else
If hHook Then UnhookWindowsHookEx hHook
End If
End Sub
Skipping the call to CallNextHookEx in GetMsgProc filter function is generally a bad idea. If you do this then other filter functions in the chain will not be called. Maybe, there are none on a dev machine, but 'in the wild' there will be other applications that installed hooks. Those applications will misbehave if you prevent their filter functions from being called.
You probably wouldn't want to analyze messages that have been merely peeked from the queue, but not removed from it. GetMsgProc is called with wParam = PM_REMOVE for messages that have been removed from queue.
VB6 or C++ or whatever, it is a deadly practice to ignore MSDN specification for API. This is how GetMsgProc filter function should make a decision based on a value of its first argument:
code [in]
Specifies whether the hook procedure must process the
message. If code is HC_ACTION, the hook procedure must process the
message. If code is less than zero, the hook procedure must pass the
message to the CallNextHookEx function without further processing and
should return the value returned by CallNextHookEx.
http://msdn.microsoft.com/en-us/library/windows/desktop/ms644981%28v=vs.85%29.aspx
Although CopyMemory should work (assuming you declare it correctly), I wouldn't bother with it here. It's perfectly OK to declare 3rd parameter of filter function as ByRef lParam As MSG.
Here is the code that should be placed in a standard module (as any other code that installs hooks). It works for me if I use it to sniff WM_RBUTTONDOWN messages to, say, TextBox control placed on a main form.
Option Explicit
'http://msdn.microsoft.com/en-us/library/windows/desktop/dd162805%28v=vs.85%29.aspx
Private Type tagPOINT
x As Long
y As Long
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms644958%28v=vs.85%29.aspx
Private Type MSG
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As tagPOINT
End Type
Private bHooked As Boolean
Private hHook As Long
Private hHwndToSniff As Long
Private Const HC_Action As Long = &H0
Private Const PM_NOREMOVE As Long = &H0
Private Const PM_REMOVE As Long = &H1
Private Const WH_GETMESSAGE As Long = &H3
Private Const WM_RBUTTONDOWN As Long = &H204
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms644974%28v=vs.85%29.aspx
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms644990%28v=vs.85%29.aspx
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms644993%28v=vs.85%29.aspx
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Public Sub RemoveHook()
If bHooked Then
UnhookWindowsHookEx hHook
bHooked = False
End If
End Sub
Public Sub SetHook(ByVal hThreadToHook As Long, hHwndFilter As Long)
If Not bHooked Then
hHook = SetWindowsHookEx(WH_GETMESSAGE, AddressOf GetMsgProc, 0, hThreadToHook)
If hHook > 0 Then
bHooked = True
hHwndToSniff = hHwndFilter
Else
Debug.Assert False
End If
End If
End Sub
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms644981%28v=vs.85%29.aspx
Private Function GetMsgProc(ByVal uCode As Long _
, ByVal wParam As Long _
, ByRef lParam As MSG) As Long
If uCode = 0 Then
If wParam = PM_REMOVE Then
If lParam.message = WM_RBUTTONDOWN Then
If lParam.hWnd = hHwndToSniff Then
MsgBox "You right-clicked a text box!"
End If
End If
End If
End If
GetMsgProc = CallNextHookEx(hHook, uCode, wParam, lParam)
End Function
The hook is installed in a form module in the following fashion:
SetHook App.ThreadID, Me.Text1.hWnd
I'm having a hard time converting this C++ code to VB6 code. I've search the net and haven't found anything. PInvoke.net only has reference to VB.NET code. Here's the code from MSDN:
BOOL IsUserAdmin(VOID)
/*++
Routine Description: This routine returns TRUE if the caller's
process is a member of the Administrators local group. Caller is NOT
expected to be impersonating anyone and is expected to be able to
open its own process and process token.
Arguments: None.
Return Value:
TRUE - Caller has Administrators local group.
FALSE - Caller does not have Administrators local group. --
*/
{
BOOL b;
SID_IDENTIFIER_AUTHORITY NtAuthority = SECURITY_NT_AUTHORITY;
PSID AdministratorsGroup;
b = AllocateAndInitializeSid(
&NtAuthority,
2,
SECURITY_BUILTIN_DOMAIN_RID,
DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0,
&AdministratorsGroup);
if(b)
{
if (!CheckTokenMembership( NULL, AdministratorsGroup, &b))
{
b = FALSE;
}
FreeSid(AdministratorsGroup);
}
return(b);
}
It would be great if somebody can help out in converting this to VB6 code.
Thanks!
EDIT:
I was originally going to use that function but MSDN says:
This function is a wrapper for CheckTokenMembership. It is recommended to call that function directly to determine Administrator group status rather than calling IsUserAnAdmin.
Try this
Option Explicit
Private Const SECURITY_BUILTIN_DOMAIN_RID As Long = &H20
Private Const DOMAIN_ALIAS_RID_ADMINS As Long = &H220
Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" (pIdentifierAuthority As Any, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Sub FreeSid Lib "advapi32.dll" (ByVal pSid As Long)
Private Declare Function CheckTokenMembership Lib "advapi32.dll" (ByVal hToken As Long, ByVal pSidToCheck As Long, pbIsMember As Long) As Long
Private Type SID_IDENTIFIER_AUTHORITY
Value(0 To 5) As Byte
End Type
Private Function pvIsAdmin() As Boolean
Dim uAuthNt As SID_IDENTIFIER_AUTHORITY
Dim pSidAdmins As Long
Dim lResult As Long
uAuthNt.Value(5) = 5
If AllocateAndInitializeSid(uAuthNt, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, pSidAdmins) <> 0 Then
If CheckTokenMembership(0, pSidAdmins, lResult) <> 0 Then
pvIsAdmin = (lResult <> 0)
End If
Call FreeSid(pSidAdmins)
End If
End Function
You've posted the MSDN sample code for CheckTokenMembership - it uses CheckTokenMembership to determine whether the user is an administrator.
In VB6 it's easier to use IsUserAnAdmin, which is a wrapper for CheckTokenMembership. The MSDN docs do say IsUserAnAdmin is deprecated, but it's so much easier to call than CheckTokenMembership.
Private Declare Function IsUserAnAdmin Lib "Shell32" Alias "#680" () As Integer
If IsUserAnAdmin() = 0 Then
MsgBox "Not admin"
Else
MsgBox "Admin"
End If
Unless there is a reason to convert the code, use the API
Private Declare Function IsUserAdmin Lib "Shell32" Alias "#680" () As Boolean
Private Sub Form_Load()
If IsUserAdmin Then MsgBox "User is Admin"
End Sub