Is there any way to remove the small, red circle indicating today in the MonthView control? I've been doing a bit of googling, and the closest I've found is this, which seems to contain a solution, but in VB6, not VBA. Furthermore, having a look at the various files uploaded to that post, I have trouble understanding which part is removing the circle, nevermind if it is possible to use the same solution in Excel-VBA.
Any input on whether what I am hoping to do is at all possible would be much appreciated.
It's pretty simple using API:
Add this to the top of your UserForm:
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 Const GWL_STYLE As Long = -16
Private Const MCS_NOTODAYCIRCLE As Long = 8
And use this to remove it:
Private Sub UserForm_Initialize()
With Me.MonthView1
SetWindowLong .hWnd, GWL_STYLE, GetWindowLong(.hWnd, GWL_STYLE) Or MCS_NOTODAYCIRCLE
End With
End Sub
Related
(I am not a native English speaker, I use google translate, then modify. If something wrong, forgive my poor English.)
My goal is to make a Userform with scrollbar in MS Word, hoping to scroll with the mouse wheel.
But VBA doesn't offer MouseScroll Event Handler. After searching, I know it can be achieved with WinAPI Hook.
I refer to the examples in “Subclassing and Hooking with Visual Basic (O'Reilly, 2001)”. After modification, my code can be successfully executed with modal Userform.
But when I open Userform in Modeless mode, once the hook is executed, the entire Windows system will be stuck, clicking windows of other program didn't respond, and the CPU usage > 80%.
I used Debug.Print to output some text. When I looked at the VBE’s immediate window, the macro was still executing, but it fell into an infinite loop.
My code is below:
(I use Win10 64-bit and Office 365 Word 64-bit. 64-bit API declaration is according to the document on Microsoft's official website.)
MouseHook Module code：
Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
'This structure is just the extension of MOUSEHOOKSTRUCT
Type MOUSEHOOKSTRUCTEX
structMouseHook As MOUSEHOOKSTRUCT
mousedata As Long
End Type
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hhk As LongPtr) As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal nCode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_MOUSE As Long = 7
Private Const HC_ACTION As Long = 0
Public IsHooked As Boolean
Private mhook As LongPtr
Private i As Long
Public Sub SetMouseHook()
If IsHooked Then
MsgBox "Don't hook the MOUSE twice."
Else
'I perform thread-specific Hook
mhook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0, GetCurrentThreadId)
IsHooked = True
End If
End Sub
Public Sub RemoveMouseHook()
Call UnhookWindowsHookEx(mhook)
IsHooked = False
End Sub
Public Function MouseProc( _
ByVal uCode As Long, _
ByVal wParam As LongPtr, _
lParam As MOUSEHOOKSTRUCTEX) As LongPtr
If uCode = HC_ACTION Then
Debug.Print i & "HC_ACTION" & lParam.mousedata: i = i + 1
'To emphasize the keypoint, I omitted some irrelevant code.
'lParam.mousedata gives you the direction of the mousewheel scrolling.
'(by positive or negative)
End If
MouseProc = CallNextHookEx(mhook, uCode, wParam, lParam)
End Function
Userform code:
(The form has two command buttons, which perform sethook and unhook function.)
Option Explicit
Private Sub cmdHook_Click()
Call SetMouseHook
End Sub
Private Sub cmdUnHook_Click()
Call RemoveMouseHook
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call RemoveMouseHook
End Sub
How to solve this problem?
If the Modeless Userform cannot use the WH_MOUSE hook, are there any alternatives, like WH_MOUSE_LL hook or VSTO?
Thank you all.
===== Update =====
In my final test, I find that ‘WH_MOUSE Hook’, ‘WH_MOUSE_LL Hook’, and ‘Instance Subclassing’ all can work in Modeless VBA Userform.
But you should close the VBE first, and then execute the macro from the Macros dialog box (ALT+F8). (I executed the macro with VBE opened before.)
my Subclassing code is below:
Subclassing Userform code:
Option Explicit
'the Userform name is "frmSubclass"
'it contains 2 cmdButtons and 1 Frame with vertical scrollbar
'click the "SetSubclass Button" to SetSubclass
'click the "UnSubclass Button" to unSubclass
Private Sub cmdSetSubclass_Click()
Call SetSubclass
End Sub
Private Sub cmdUnSubclass_Click()
Call unSubclass
End Sub
Private Sub UserForm_Initialize()
Me.Frame1.ScrollBars = fmScrollBarsVertical
Me.Frame1.ScrollHeight = 1000
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call unSubclass
End Sub
Subclassing bas Module code：
Option Explicit
'WinAPI function
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function GetWindow Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal wCmd As Long) As LongPtr
Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByVal hwnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
'Windows constant
Private Const GW_CHILD As Long = 5
Private Const GWLP_WNDPROC As Long = -4
Private Const WM_MOUSEWHEEL As Long = &H20A
'module-level variables
Private m_OrigWndProc As LongPtr
Private m_hwnd As LongPtr
Public Function SetSubclass() As Boolean
'I want to Subclassing the frame window inside the Main Userform
'not the Main userform itself
'get hwnd of Main Userform window which classname is "ThunderDFrame" in VBA
m_hwnd = FindWindow("ThunderDFrame", vbNullString)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of client window of Main Userform
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of Frame window
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'I use spy++ to watch all hwnd values, the 3 values of m_hwnd is correct
'set Subclass and store the Original Window Procedure
If m_OrigWndProc <> 0 Then
Debug.Print "Already subclassed" 'Do not allow to subclass a 2nd time
Else
m_OrigWndProc = SetWindowLongPtr(m_hwnd, GWLP_WNDPROC, AddressOf SubclassWndProc)
Debug.Print "Subclassing succeed."
End If
End Function
Public Function unSubclass() As Boolean
If m_OrigWndProc <> 0 Then
SetWindowLongPtr m_hwnd, GWLP_WNDPROC, m_OrigWndProc
m_OrigWndProc = 0
End If
End Function
Public Function SubclassWndProc( _
ByVal hwnd As LongPtr, _
ByVal uMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
On Error Resume Next
If uMsg = WM_MOUSEWHEEL Then
'the Userform name is "frmSubclass"
frmSubclass.Caption = " wParam = " & wParam
'By observing the value of wParam, we can know
'4287102976 represents scrolling down,7864320 represents scrolling up
If wParam = 4287102976# Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop + 15
ElseIf wParam = 7864320 Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop - 15
End If
End If
'Pass message to the default window procedure
SubclassWndProc = CallWindowProc(m_OrigWndProc, hwnd, uMsg, wParam, lParam)
End Function
starting point bas Module code：
Option Explicit
Sub testSubclass()
frmSubclass.Show vbModeless 'the Userform name is "frmSubclass"
End Sub
The book you mentioned is called "Subclassing and Hooking". You tried "Hooking" when in fact your problem is more suited to "Subclassing" instead.
You should subclass your Userform where you want to process the "WM_MOUSEWHEEL" message. Look into "SetWindowLong" and "CallWindowProc" functions to achieve this goal.
Hi I am new to VBA and this seems like a simple problem.
I am trying to get the dimensions of an image in excel and using the GetDeviceCaps function as a result.
I will get a variable not defined compile error regarding the VERTES parameter.
The code I use is the following:
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, _
ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) _
As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As LongPtr _
, ByVal nIndex As Long _
) As LongPtr
Public Sub Test()
Dim tPOS As POINTAPI
Dim AColor As Long
Dim ADC As Long
Dim width As Integer
ADC = GetWindowDC(0)
width = GetDeviceCaps(ADC, VERTRES)
Call GetCursorPos(tPOS)
AColor = GetPixel(ADC, tPOS.x, tPOS.y)
ActiveWindow.Selection.ShapeRange(1).Fill.ForeColor.RGB = 14588691
Debug.Print "width"
Debug.Print width
End Sub
Questions appears to be so basic there isn't anything specific about this online.
I'm looking to determine how I can adjust the transparency of a shape on a Microsoft Access form. So far I've figured out how to use hWnd to adjust the opacity of the entire form, but I'd like to adjust the opacity of individual form elements/shapes.
This is what I have thus far. Like I mentioned, it adjusts the entire forms transparency instead of an individual object.
Code on the Form associated with a button:
Public Sub FullOpacity_Click()
Dim Transp As Long
Transp = RGB(0, 0, 0) 'This is the color you want your background to be
Me.Detail.BackColor = Transp
Me.Painting = False
SetFormOpacity Me, 0.5, Transp
Me.Painting = True
End Sub
Code in a module
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hwnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long
Private Const LWA_ALPHA As Long = &H2
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_LAYERED As Long = &H80000
Public Sub SetFormOpacity(frm As Form, sngOpacity As Single, TColor As Long)
Dim lngStyle As Long
' get the current window style, then set transparency
lngStyle = GetWindowLong(frm.hwnd, GWL_EXSTYLE)
SetWindowLong frm.hwnd, GWL_EXSTYLE, lngStyle Or WS_EX_LAYERED
SetLayeredWindowAttributes frm.hwnd, TColor, (sngOpacity * 255), LWA_ALPHA
End Sub
The object I'm trying to target is called "rectangle" and it's on the form called "Main".
Thanks so much for any help
I am using the same AlphaBlend function as declared like this:
Public Declare Function AlphaBlend Lib "MSIMG32.dll" (ByVal hDCDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal lBlendFunction As Long) As Long
There are some machines where my code works perfectly fine and does exactely what it should.
On one machine, the very same code works fine in application A, but the same code in application B makes AlphaBlend fail.
Imagine the following:
You have 2 identical twins both eating an apple. Both apples are perfectly the same.
One twin swallows it successfully, the other twin dies trying to do so.
GetLastError returns 0.
How could I investigate what goes wrong?
One some machines, all is fine.
On the one machine in question however, I have compiled the very same code running in two applications: Application A and application B.
In application A, AlphaBlend fails, and in application B, AlphaBlend succeeds.
And it's ALWAYS that it fails in application A.
I have even doubted VB6's sanity and checked if "Len" actually returns the correct length.
I use VB6 since 20 years, but I have never experienced something that crazy.
Does anybody have any idea why the same code might fail in that one application?
Option Explicit
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function AlphaBlend Lib "MSIMG32.dll" (ByVal hDCDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal lBlendFunction As Long) As Long
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub MoveMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const AC_SRC_OVER = &H0
Private Sub Timer1_Timer()
Dim lHwnd&
lHwnd = FindWindow(vbNullString, "twsseetechcamwin")
If lHwnd = 0 Then
Me.Caption = "is null!"
Exit Sub
End If
Me.Caption = "ok"
Dim LBF As Long
Dim bf As BLENDFUNCTION
With bf
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 255
End With
Dim lLen&
lLen = Len(bf) 'just check for sanity... I wanted to make sure that it's 4, and it indeed is
Call MoveMemory(LBF, bf, Len(bf)) 'Copy struct into a Long var
Dim rOtherWin As RECT
GetClientRect lHwnd, rOtherWin
Dim lOtherDC&
lOtherDC = GetDC(lHwnd)
Dim r As RECT
GetClientRect Me.hWnd, r
Dim lret&
lret = AlphaBlend(Me.hdc, 0, 0, (r.Right - r.Left), (r.Bottom - r.Top), lOtherDC, 0, 0, (rOtherWin.Right - rOtherWin.Left), (rOtherWin.Bottom - rOtherWin.Top), LBF)
Dim lWinErr&
lWinErr = GetLastError()
Me.Caption = Time & " ret: " & lret & ", err: " & lWinErr&
ReleaseDC lHwnd, lOtherDC
End Sub
The problem occurs when the OS is set to high DPI settings (like display everything in 150%) AND if the application has a manifest that states dpiaware=true.
There are 2 possible solutions:
Remove dpiaware from the manifest
Add a manifest to the other process as well and declare dpiaware=true in that manifest, too. This way there is no discrepancy between the 2 processes. This of course only works if it's your product / process, and you have the possibility to compile it with a manifest.
Since this is machine-specific (assuming that is accurate) there is a possibility that the two programs A and B are not loading the same copy of MSIMG32.dll.
I would check: are there multiple copies of that DLL on the PC? Especially if there is a copy in the program folder for A or B?
Also you can run Process Monitor and observe the running program to see exactly what DLLs are being loaded. That could at least confirm they are both running the same DLL and eliminate that as a potential cause.
Other than that, personally I would throw in some debug logging and really verify that the inputs to the failing function are the same.
I'm running a program that makes some ALPHA effects on labels, fonts, images using the Windows´ SetLayeredWindowAttributes function. It´s functioning prefectly within Visual Studio 2013, running without Administrator priviledge.
I run in DEBUG and RELEASE mode from VS2013 and I know the ADMIN is not set because I call VS normally and I execute some "drag-and-drop" operations (which require a NORMAL priviledge instead ADMIN).
But, if I compile and run the program within its normal folder (C:\ProgramFiles\etc) in the SAME computer, the function does not appear to be executing - all labels, images and so forth appear suddenly.
So, is this function an ADMIN-PRIVILEDGE required?
The code for testing is:
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" (ByVal hWnd As Integer, _
ByVal nIndex As Integer) As Integer
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" (ByVal hWnd As Integer, _
ByVal nIndex As Integer, ByVal dwNewLong As Integer) _
As Integer
Private Declare Function SetLayeredWindowAttributes Lib _
"user32" (ByVal hWnd As Integer, ByVal crKey As Integer, _
ByVal bAlpha As Byte, ByVal dwFlags As Integer) As Integer
Public Function TransForm(ByVal fhWnd As Long, ByVal Alpha As Byte) As Boolean
'Set alpha between 0-255
' 0 = Invisible , 128 = 50% transparent , 255 = Opaque
SetWindowLong(fhWnd, GWL_EXSTYLE, WS_EX_LAYERED)
SetLayeredWindowAttributes(fhWnd, 0, Alpha, LWA_ALPHA)
LastAlpha = Alpha
TransForm = True
End Function
------ CODE -----
TransForm(lblBottomLeft.Handle.ToInt32, CByte(i))
TransForm(lblBottomRight.Handle.ToInt32, CByte(i))
For i = 255 To 0 Step -5
TransForm(Me.Handle.ToInt32, CByte(i))
sleep(10)
Next
TransForm(Me.Handle.ToInt32, 0)
Thanks for any help.
UPDATE:
Just the labels are not fading, although they fade within VS2013. Since labels have no OPACITY property, it´s clear they won´t fade - at least in the very first moment. But using that API they fade like the form, but ONLY within the VS2013.