With VB6, is it possible to use LVS_EX_DOUBLEBUFFER to make the common control ListView flicker free? This property is exposed in VB.NET, but not VB6. I will be using version 6 of common controls, so in theory it should work. However I do not know how to implement it.
You could try the free VB6 replacement for the ListView from vbAccelerator. It supports LVS_EX_DOUBLEBUFFER
Alternatively use a manifest to use Common Controls 6 in your VB6. Then in the Form_Load send the LVS_EX_DOUBLEBUFFER message to the ListView. Something like this (based on a .NET sample). Warning - air code!
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const LVM_FIRST = &H1000
Const LVM_SETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 54)
Const LVM_GETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 55)
Const LVS_EX_DOUBLEBUFFER = &H10000
Const LVS_EX_BORDERSELECT = &H8000
Private Sub FormLoad()
Dim styles As Long
styles = SendMessage(listView.hwnd, _
LVM_GETEXTENDEDLISTVIEWSTYLE, 0, ByVal 0&)
styles = Style Or LVS_EX_DOUBLEBUFFER Or LVS_EX_BORDERSELECT
Call SendMessage(listView.hwnd, _
LVM_SETEXTENDEDLISTVIEWSTYLE, 0, ByVal styles)
End Sub
Related
I want to disable the X button on a form depending on a condition.
So something like:
If Boolean Then
ControlBox = False
Else
ControlBox = True
End If
When I try and use this I get an error message saying visual basic does not support this function.
This would be done on the form load and the boolean would not change.
I've searched this forum but can't find an answer to suite me needs.
Thanks in advance.
It looks like you are trying to set the ControlBox property at run-time. As you saw, you cannot do so. However, with a little API magic you can accomplish this task:
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE = (-16)
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOSIZE = &H1
Private Property Let ControlBoxVisible(ByVal Value As Boolean)
Dim style As Long
style = GetWindowLong(Me.hWnd, GWL_STYLE)
style = IIf(Value, style Or WS_SYSMENU, style And Not WS_SYSMENU)
SetWindowLong Me.hWnd, GWL_STYLE, style
SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE
End Property
And then you would use it like this:
Private Sub Form_Load()
ControlBoxVisible = False
End Sub
Using API calls.
Take a look at Enable / Disable Forms Close Button
There is a zipped project file with source code.
I am still supporting and old vb6 application that utilizes GetWindowLong and SetWindowLong to remove the ControlBox at runtime depending on a setting. This works great on all 32-bit systems but when it runs on a 64bit system the main window no longer refreshes properly. The problem seems to be input controls like TextBox, ListBox, or CommandButton. After being covered up by certain windows they don't display until they receive the focus and even then their borders don't show up properly.
I've read the MSDN documentation http://msdn.microsoft.com/en-us/library/ms633591%28v=vs.85%29.aspx that says these functions have been superseded by ...WindowLongPtr functions to be compatible with both 32-bit and 64-bit systems. From everything I've been able to read that is really talking about compiling both 32-bit and 64-bit version instead of running on the different platforms. I've tried changing my declare from
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
To
Public Declare Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
But I get the error "Can't find DLL entry point GetWindowLongPtrA in user32". So I tried leaving the Alias as "...WindowLongA" and that runs and as I would expect doesn't make any difference in the refresh problem.
Has anybody else seen this or have any suggestions.
Here is a sample of how the code is used.
Private Sub Form_Activate()
...
Call SetControlBox(Me.hWnd, DisableFullScreen)
End Sub
Public Sub SetControlBox(ByVal hWnd As Long, ByVal Value As Boolean)
' Set WS_SYSMENU On or Off as requested.
Call FlipBit(hWnd, WS_SYSMENU, Value)
End Sub
Public Function FlipBit(ByVal hWnd As Long, ByVal Bit As Long, ByVal Value As Boolean) As Boolean
Dim nStyle As Long
' Retrieve current style bits.
nStyle = GetWindowLongPtr(hWnd, GWL_STYLE)
' Attempt to set requested bit On or Off,
' and redraw
If Value Then
nStyle = nStyle Or Bit
Else
nStyle = nStyle And Not Bit
End If
Call SetWindowLongPtr(hWnd, GWL_STYLE, nStyle)
Call Redraw(hWnd)
' Return success code.
FlipBit = (nStyle = GetWindowLongPtr(hWnd, GWL_STYLE))
End Function
Public Sub Redraw(ByVal hWnd As Long)
' Redraw window with new style.
Const swpFlags As Long = SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE
SetWindowPos hWnd, 0, 0, 0, 0, 0, swpFlags
End Sub
Thanks
dbl
Try adding SWP_NOACTIVATE (&H10) bit to your swpFlags constant.
Btw, this redraws non-client area only. A name like RedrawNonclient would make it apparent.
I've just tried setting up a scrolling marquee progress bar in one of my VB6 applications, and while it seems to switch into marquee mode, the automatic timer (set via PBM_SETMARQUEE) either fails or is ignored.
I have an appropriate visual style manifest.
I have called InitCommonControls in the form's Initialize event.
I am using the v5 SP2 common controls.
The project is compiled.
I have set the PBS_MARQUEE style via SetWindowLong and confirmed it has applied.
The PBM_SETMARQUEE message returns 1.
The results:
If I minimise and restore the window it progresses one step.
If I set .Value it progresses one step.
If I send PBM_STEPIT it progresses one step.
If I send PBM_SETMARQUEE it sits there doing nothing.
If I don't pass the initial PBM_SETMARQUEE enable message, then the minimise/restore doesn't cause it to progress suggesting the timer is the problem.
This is the same issue discussed in this thread from 2006
Does anyone have any deeper insight as to why the VB wrapper is dropping the PBM_SETMARQUEE message or the associated timer events and why I need to do it "manually"?
Option Explicit
Private Const GWL_STYLE = (-16)
Private Const PBS_MARQUEE = &H8
Private Const WM_USER = &H400
Private Const PBM_STEPIT = WM_USER + 5
Private Const PBM_SETMARQUEE = WM_USER + 10
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Form_Load()
'Set the marquee style
Dim Style As Long
Style = GetWindowLong(ProgressBar1.hWnd, GWL_STYLE)
Style = Style Or PBS_MARQUEE
SetWindowLong ProgressBar1.hWnd, GWL_STYLE, Style
'Set automatic marquee mode
SendMessage ProgressBar1.hWnd, PBM_SETMARQUEE, 1, ByVal 0&
End Sub
This is needed to make it progress.
Private Sub Timer1_Timer()
SendMessage ProgressBar1.hWnd, PBM_STEPIT, 0, ByVal 0&
End Sub
Is there an equivalent to AddressOf in Visual Basic 4?
I am attempting to get some Visual Basic 5/6 code that adds menu items to my form's system menu working in VB4. Below is the code snippet that will not compile:
'Add Custom Menu To System Menu
Call AppendMenu(GetSystemMenu(Me.hWnd, 0&), MF_SEPARATOR, 0&, vbNullString)
Call AppendMenu(GetSystemMenu(Me.hWnd, 0&), MF_STRING, IDM_SYSTEMTRAY, "Minimize To &System Tray")
Call AppendMenu(GetSystemMenu(Me.hWnd, 0&), MF_STRING, IDM_ABOUT, "&About...")
procOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
Here is the API declarations from the module:
' Win32 API
Public Const MF_SEPARATOR = &H800&
Public Const MF_STRING = &H0&
Public Const GWL_WNDPROC = (-4)
Public Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const WM_SYSCOMMAND = &H112
' User Created
Public procOld As Long
Public Const IDM_ABOUT As Long = 1010
Public Const IDM_SYSTEMTRAY As Long = 1011
And finally, the code for WindowProc:
Public Function WindowProc(ByVal hWnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_SYSCOMMAND
Select Case wParam
Case IDM_ABOUT
MsgBox "About goes here..."
Exit Function
Case IDM_SYSTEMTRAY
MsgBox "Send to system tray code goes here..."
Exit Function
End Select
End Select
' Pass all messages on to VB and then return the value to windows
WindowProc = CallWindowProc(procOld, hWnd, iMsg, wParam, lParam)
End Function
Any other pointers or alternate methods of adding items to my form's system menu would be appreciated too!
From: Xtreme VB Talk: AddressOf work around for vb4
[Banjo]
I don't think that you can without resorting to somesort of outside
DLL written in C.
[OnErr0r]
Matt Curland wrote just such a dll. Allows you to get the address of a class function, even works with vb5/6.
You can download callback.zip from the above page after registering. As a fallback, you can get the file here: callback.zip
EDIT: The direct download link has been removed, because it appears that this source code is part of a book by Matt Curland and copyrighted.
i am trying to implement the Jetaudio API in vb6...
i have taken the values of the constants from the API SDK..
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
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 RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Public Const WM_APP As Long = &H8000
Public Const MyMSG As Long = WM_APP + 740
Public Function GetJetAudioSong()
Dim v As Long
Dim JAhwnd As Long
Dim lngMyMsg As Long
lngMyMsg = RegisterWindowMessage(MyMSG)
JAhwnd = FindWindow("COWON Jet-Audio Remocon Class", "Jet-Audio Remote Control")
v = SendMessage(JAhwnd, lngMyMsg, 0, 995)
MsgBox v
End Function
Now, FindWindow() is working cause JAhwnd is set with a value...
its just the sendmessage() that doesn't seem to be working...
the code is suppose to msgbox the version number for the running Jet Audio instance.
i've been at it for days now and i have no way of making sure weather this error is a VB thing or not... i am taking Jet Audio's SDK's word that the values of the const are correct...
the value of v is always 0 where it should be 6 on my system.
what am i doing wrong?
Don't call RegisterWindowMessage, MyMSG is message number that you should send to the Jet-Audio window.
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
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
Public Const WM_APP As Long = &H8000
Public Const MyMSG As Long = WM_APP + 740
Public Function GetJetAudioSong()
Dim v As Long
Dim JAhwnd As Long
Dim lngMyMsg As Long
JAhwnd = FindWindow("COWON Jet-Audio Remocon Class", "Jet-Audio Remote Control")
v = SendMessage(JAhwnd, MyMSG, 0, 995)
MsgBox v
End Function
What Windows Version?
SendMessage and SendKeys no longer works with VB6 code starting at Windows Vista and above.
Do a Google search for it.
I know this is 2 years too late. Please use this as a future reference for anyone reading this in the future.
The fix for your issue is this:
'[ Use 'ByVal' for your lParam to make sure you are passing the actual value not the Reference
v = SendMessage(JAhwnd, lngMyMsg, 0, ByVal 995)
'[ Or you could perform PostMessage(..) and not use ByVal
v = PostMessage(JAhwnd, lngMyMsg, 0, 995)
Also, i HIGHLY recommend against anyone using SendKeys. API is the correct method to ensure you are sending message to the correct hWnd. I would suggest using SendKeys only if in desperation; it can happen.