Icons disappearing in PopUp menu after setting the main (first) PopUp menu item Visible property to False, but they come back when Visible property switched back to Enable, why?
Option Explicit
Private Const MF_BITMAP = &H4&
Private Const MF_BYPOSITION As Long = &H400& '&H404&
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Public Sub SetPopUpMenuIcons(objFRM As Form)
On Error Resume Next
Dim lgRet As Long
Dim lgMnu As Long
Dim lgSubMnu As Long
lgMnu = GetMenu(objFRM.hwnd)
lgSubMnu = GetSubMenu(lgMnu, 0)
With objFRM
lgRet = SetMenuItemBitmaps(lgSubMnu, 0, MF_BYPOSITION, .imgMnu(0).Picture, 0)
lgRet = SetMenuItemBitmaps(lgSubMnu, 1, MF_BYPOSITION, .imgMnu(1).Picture, 0)
lgRet = SetMenuItemBitmaps(lgSubMnu, 2, MF_BYPOSITION, .imgMnu(2).Picture, 0)
lgRet = SetMenuItemBitmaps(lgSubMnu, 3, MF_BYPOSITION, .imgMnu(3).Picture, 0)
lgRet = SetMenuItemBitmaps(lgSubMnu, 4, MF_BYPOSITION, .imgMnu(4).Picture, 0)
End With
Exit Sub
End Sub
I believe that the VB6 PopupMenu method actually creates a new popup menu (by calling CreatePopupMenu) and then uses the hidden menu items as templates for creating items via InsertMenu or AppendMenu, but without using the bitmap flag and handles which it doesn't know you added behind its back.
You might have to do all of the work yourself, calling CreatePopupMenu and then InsertMenuItem instead of InsertMenu/AppendMenu for each item (in order to have both a bitmap and text), and use subclassing to get the selection "event" if any, and so on.
In other words there may be no trivial way to do what you want. The VB6 menu plumbing seems to be based on old 16-bit Windows (Win 3.x) logic and API calls.
Too bad we never got a real VB7! Microsoft had accumulated a vast list of such feature enhancements before pulling the plug in favor of .Net.
There may be a 3rd party menu control that could make this easier.
Related
I created an on click button event, which is supposed to move my popup form to the top left corner of the screen. The function that I used was:
Private Sub Command1_Click()
DoCmd.MoveSize(0 ,0)
End Sub
I noticed that if my popup form is positioned on my second monitor it will send the popup form to the top left corner of my primary monitor.
Is there a way to send the form to the top left corner of whichever monitor the form is being opened in?
I tried a different idea where I will use a function to use the ".Move" property of the form. I came up with this:
Private Sub Command1_Click()
Form.Move(0, 0)
End Sub
This didn't work either, as it seems that the "0, 0" coordinates are relative to wherever the Access Window is positioned on the screen and not the top left corner of the monitor.
Is this a limitation of Access VBA or is it doable using some other technique?
While this seems trivial, unfortunately, it isn't, and we're going to need to use a fair amount of WinAPI. That makes it really hard for beginners.
We need a couple of things:
We need to be able to determine on which monitor the form is
We need to be able to determine where that monitor is in the "virtual screen" (think about positioning monitors relative to eachother)
We need to be able to determine the size of the current window in pixels
We need to be able to position the form on the "virtual screen".
For that, we need a couple of declarations. These are best kept on separate modules, but if you're 100% sure they will only be used on this form, they can go on the form too.
First, the type and value declarations:
'https://learn.microsoft.com/en-us/windows/win32/api/windef/ns-windef-rect
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/ns-winuser-monitorinfo
Public Type MONITORINFO
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
End Type
'Either look this one up by Googling, or create a C++ program that references winuser.h and print it
Public Const MONITOR_DEFAULTTONEAREST = &H2
Then, the function declarations:
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getmonitorinfow
Public Declare PtrSafe Function GetMonitorInfoW Lib "User32.dll" (ByVal hMonitor As LongPtr, ByRef lpmi As MONITORINFO) As Boolean
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-monitorfromwindow
Public Declare PtrSafe Function MonitorFromWindow Lib "User32.dll" (ByVal hWnd As LongPtr, ByVal dwFlags As Long) As LongPtr
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-movewindow
Public Declare PtrSafe Function MoveWindow Lib "User32.dll" (ByVal hWnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Boolean) As Boolean
'https://learn.microsoft.com/en-us/windows/win32/api/winuser/nf-winuser-getwindowrect
Public Declare PtrSafe Function GetWindowRect Lib "User32.dll" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Boolean
And then, on the form, putting it all to work:
Private Sub Command0_Click()
Dim mi As MONITORINFO
Dim monitor As LongPtr
Dim myrect As RECT
'Get the current size and position of the window
GetWindowRect Me.hWnd, myrect
'Determine which monitor it is on
monitor = MonitorFromWindow(Me.hWnd, MONITOR_DEFAULTTONEAREST)
'Make sure WinAPI knows the size of the MONITORINFO struct we're working with
mi.cbSize = LenB(mi)
'Get the monitor info
GetMonitorInfoW monitor, mi
'Move the window to the top right, keep width and height equal to the current values
MoveWindow Me.hWnd, mi.rcMonitor.left, mi.rcMonitor.top, myrect.right - myrect.left, myrect.bottom - myrect.top, True
End Sub
Unfortunately, that's quite a lot more code and more complicated concepts than DoCmd.MoveSize(0 ,0), but I do not know of a simpler approach. VBA doesn't really have any support for multiple monitors, so you'll often have to go to WinAPI to account for them.
I have an excel vba application that runs a separate process. During the external process a progress indicator with abort button is initialized. It is crucial for the end users that the abort button is available. It is also usefull to see the external process running.
I would like to have the progress indicator/abort button placed on top of the external process. but I do NOT wont to force the userform on top of everything.
I have tried to use findwindow / setwindowpos, resulting in the following problems:
If I initialize HWND_TOPMOST before running the process, then the userform is always on top, regardless of what the user wants. I find this very annoying, especially if some sort of errors occur where the debuging window might be blocked by the inactive vba userform. However the workbook remains in the background which is desired.
If I use HWND_TOP (after the external process is up and running) then the entire workbook is activated (not just the userform), which then hides to progress of the external application. Not very benificial compared to activating the workbook.
Are there any suggestions on how to put the userform in front of the external applicaiton, while still allowing the user to deactivate it?
code snippets:
Option Explicit
' Code stolen with pride from various sources.
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd 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
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public id As Integer
Public ProgressForm As fProgress
' Main routine, launch application and progress indicator.
Sub LoadForm()
Set ProgressForm = New fProgress
ProgressForm.Show
' Force userform to front, makes it on top but does not allow reorder of windows.
ForceToFront ProgressForm
' Run external process, notepad used for example.
id = Shell("notepad", vbNormalFocus)
End Sub
' Routine to bring userform to front after the external program is up and running.
Sub TestBringToFront()
BringToFront ProgressForm
End Sub
Sub BringToFront(fm As fProgress)
Dim hwnd As Long, ret As Variant
hwnd = FindWindow("ThunderDFrame", fm.Caption)
ret = SetWindowPos(hwnd, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
Sub ForceToFront(fm As fProgress)
Dim hwnd As Long, ret As Variant
hwnd = FindWindow("ThunderDFrame", fm.Caption)
ret = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Sub
Unfortunately this is the designated behaviour of windows and applications. However, I can suggest some workarounds:
Use TOPMOST option and make the userform clickable, e.g. capture the ProgressForm_Click and toggle between TOPMOST and NOTOPMOST state. ALternatively use can employ an "Always On Top" checkbox on ProgressForm like it is in the Task Manager.
Use TOP option and resize the workbook window behind to as small as possible, or even move aside (out of the screen), and restore size and position after the external app finished.
It may be worthy making a try with ProgressForm.Show(vbModeless) and TOP
I'm have a VB.NET application using the SetParent API to put a Worddocument inside a GroupBox-control of my application.
Public Class myForm
Dim mwrdApp As Microsoft.Office.Interop.Word.Application
Dim mwrdDoc As Microsoft.Office.Interop.Word.Document
Dim mwrdHwnd As Integer
Dim sTemp As String
Public Structure RECT 'for GetWindowRect API
Dim Left As Integer
Dim Top As Integer
Dim Right As Integer
Dim Bottom As Integer
End Structure
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer
Declare Function GetWindowRect Lib "user32" (ByVal Hwnd As Integer, ByRef lpRect As RECT) As Integer
Declare Function MoveWindow Lib "user32" (ByVal Hwnd As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Integer) As Integer
Declare Function SetParent Lib "user32" (ByVal hWndChild As Integer, ByVal hWndNewParent As Integer) As Integer
Private Sub myForm_Load(sender As Object, e As EventArgs) Handles MyBase.Load
mwrdApp = New Microsoft.Office.Interop.Word.Application
mwrdDoc = mwrdApp.Documents.Add
sTemp = mwrdDoc.ActiveWindow.Caption 'save document-caption
mwrdDoc.ActiveWindow.Caption = "besuretofindthisinstance" 'set detectable caption
mwrdHwnd = FindWindow("OpusApp", mwrdDoc.ActiveWindow.Caption & " - " & mwrdApp.Caption) 'find Word window handle
mwrdDoc.ActiveWindow.Caption = sTemp 'restore original caption
mwrdApp.Visible = True
mwrdApp.ScreenUpdating = True
mwrdDoc.ActiveWindow.Visible = True
MsgBox("Worddocument-window before SetParent")
SetParent(mwrdHwnd, myGroupBox.Handle.ToInt32) 'put Word in myGroupBox
Dim myGroupBoxRect As RECT
GetWindowRect(myGroupBox.Handle.ToInt32, myGroupBoxRect) 'Get size of myGroupBox
MoveWindow(mwrdHwnd, 0, 0, myGroupBox.Right - myGroupBox.Left, myGroupBox.Bottom - myGroupBox.Top, True) 'Size the Word window to fit inside myGroupBox:
End Sub
End Class
After opening Word on the desktop the code is halted with the messagebox, then the Wordwindow (Word 2013) is looking totally normal.
Then the SetParent-API moves the Wordwindow from the desktop into myGroupBox on myForm. This has been working well with any operating system until now, however I recently switched my application to Windows-8 (on a MS Surface Pro 3) and now after the SetParent the framed Wordwindows shows increased menus and ribbon.
Now all titles and tabs in the Word-menu and the ribbon controls have increased sizes all of a sudden; the font size is much larger (BTW: Word itself is functioning correctly and also any text in the Worddocument itself is not affected).
Has anybody an idea how this can happen? Can this programmatically be prevented or otherwise corrected afterwards?
What you are trying to achieve is not supported oficically. You can embed your application into Word (but not the reverse) developing an add-in with a task pane. Consider using any third-party components for displaying Word documents on Windows Forms.
Also take a look at the following similar threads:
How to Embed Microsoft office in Win form?
How do i embed MS word to a windows form app?
I can manually shorten or lengthen the Name Box (which is just to the left of the Formula Bar) by dragging the "dot" to the right or left. (This also shortens or lengthens the Formula Bar.)
How can I do the adjustment with VBA??
PHEW!!!!
Things that you throw my way!!! :P
When I realized that there are is no native way to achieve what you want, I resorted to the API way but then I was again disappointed because the "Name Box" only exposed WS_CHILDWINDOW, WS_VISIBLE, CBS_DROPDOWN, CBSAUTOHSCROLL and CBS_HASSTRINGS. The "Dot" doesn't even have a handle.
Out of frustration, I started thinking along the lines of what Mark proposed in his answer. The Registry way. It took me some 20 odd mins to find the Registry key. But Alas, that joy also didn't last long when I realized that changing the registry key didn't have any effect till I restarted Excel.
After this there was only one way left Simulation of the mouse. I would have smashed my laptop on the ground if that didn't work!.
I tried with some hardcoded values in the beginning and was happy with the results. So here is the final version...
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function SetCursorPos Lib "user32" _
(ByVal X As Integer, ByVal Y As Integer) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim pos As RECT
Sub Sample()
Dim hwndExcel As Long
Dim hwndPanel As Long
Dim hwndCombo As Long
Dim dest_x As Long
Dim dest_y As Long
Dim cur_x As Long
Dim cur_y As Long
Dim Position As POINTAPI
'~~> Get the handle of the Excel Window
hwndExcel = FindWindow("XLMAIN", Application.Caption)
If hwndExcel = 0 Then Exit Sub
'MsgBox "Excel Window Found"
'~~> Get the handle of the Panel where the Name Box is
hwndPanel = FindWindowEx(hwndExcel, ByVal 0&, "EXCEL;", vbNullString)
If hwndPanel = 0 Then Exit Sub
'MsgBox "Excel Panel Found"
hwndCombo = FindWindowEx(hwndPanel, ByVal 0&, "Combobox", vbNullString)
If hwndCombo = 0 Then Exit Sub
'MsgBox "Excel Name Box Found"
'~~> Retrieve the dimensions of the bounding rectangle of the
'~~> specified window. The dimensions are given in screen
'~~> coordinates that are relative to the upper-left corner of the screen.
GetWindowRect hwndCombo, pos
'~~> Get the approx location of the DOT. It is where the Combobox ends
cur_x = pos.Right
cur_y = pos.Top + 10
'~~> New Destination
dest_x = cur_x + 500 '<~~ Change width here
dest_y = cur_y
'~~> Move the cursor to the specified screen coordinates of the DOT.
SetCursorPos cur_x, cur_y
Wait 1 '<~~ Wait 1 second
'~~> Press the left mouse button on the DOT
mouse_event MOUSEEVENTF_LEFTDOWN, cur_x, cur_y, 0, 0
'~> Set the new destination. Take cursor there
SetCursorPos dest_x, dest_y
'~~> Press the left mouse button again to release it
mouse_event MOUSEEVENTF_LEFTUP, dest_x, dest_y, 0, 0
Wait 1
MsgBox "done"
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
Instructions
Paste this code in a module and then from the sheet press ALT+F8 and then select Sample and press ALT+R
Tested in Excel 2010
Before
After
As there isn't a NameBox object within VBA Excel.Application I don't think it's possible in native VBA.
You'd have to delve into REGISTRY. The registry key is
Note: Even if you set the value, for it to take effect, you will have to close and open Excel.
I want to develop an app which won't allow the user to open or jump to another application while it is open. It should be in Visual Basic. For example, if my application is open (running) and the user tries to open any other windows application like "media player" then it shouldn't open. The app should not even allow "task manager" to run. The application should completely block the windows environment while it is running.
A very good question. :)
Is is possible to achieve it in VB?
The answer is Yes!
Is it Easy?
Definitely not!
However here are few tips on how to approach the problem.
1) Disable the Task Manager
Sub DisableTaskManager()
Shell "REG add HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System /v DisableTaskMgr /t REG_DWORD /d 1 /f", vbNormalFocus
End Sub
Sub EnableTaskManager()
Shell "REG add HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System /v DisableTaskMgr /t REG_DWORD /d 0 /f", vbNormalFocus
End Sub
2) Ensure your program is always on top
a) Hide the task bar
Option Explicit
'~~> http://allapi.mentalis.org/apilist/FindWindow.shtml
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName _
As String) As Long
'~~> http://allapi.mentalis.org/apilist/SetWindowPos.shtml
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 SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
'~~> Show/Hide Taskbar
Sub Sample()
'~~> To show the taskbar
ShowTskBar True
'~~> To hide the taskbar
ShowTskBar False
End Sub
Sub ShowTskBar(ShouldI As Boolean)
Dim Sid As Long
Sid = FindWindow("Shell_traywnd", "")
If ShouldI = True Then
If Sid > 0 Then _
Sid = SetWindowPos(Sid, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
Else
If Sid > 0 Then _
Sid = SetWindowPos(Sid, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End If
End Sub
b) Show your application Always on top
'~~> http://www.allapi.net/apilist/SetWindowPos.shtml
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
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Private Sub Form_Activate()
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End Sub
b) Show your application in maximized mode
Maximize your form so that the desktop shows only your form as it shows in a Kiosk application. Depending on the need you can also disable the minimize button or the title bar. In such a case do remember to add a button so that user can click that to exit the form.
3) Disable the Start Menu
This code depends on the Windows version that you are using. Do a search on Google, you will find plenty of examples.
Similarly, you have to take care of few small small things but this post will give you a good start. If you are looking for a complete solution in one place then I doubt you will ever get it ;)
HTH
Take a look at the Desktop APIi to create your own "sandbox" but very careful as it's very easy to lock yourself out of the primary desktop.
Also see this question for a bit more information.