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.
Related
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 have a code which can ccontrol transparent of a userform so, I want to make a fake userform which has the logo for the company and make it transparent to all other userform the problem is how can show 2 userforms at same time and make the fake userform as a layer in the front of other userform and be able to work with the behind userform, I hope I explain my point well
this is a photo of what I want to do:
this is the code for userform transparent
Private Declare Function FindWindow _
Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 SetLayeredWindowAttributes _
Lib "user32" _
(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2&
Public hWnd As Long
Sub MakeTransparent(frm As Object, TransparentValue As Integer)
Dim bytOpacity As Byte
'Control the opacity setting. bytOpacity = TransparentValue
hWnd = FindWindow("ThunderDFrame", frm.Caption)
Call SetWindowLong(hWnd, GWL_EXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(hWnd, 0, bytOpacity, LWA_ALPHA)
End Sub
the following code I put it in the second userform which I have work on it and it will be behind the first userform which it has the transparent logo, I got an error when I run the code but it's displayed after error message like the screenshot which I attached up
Private Sub UserForm_Initialize()
Me.Show vbModeless
UserForm1.Top = Me.Top + 20
UserForm1.Left = Me.Left + 20
UserForm1.Show vbModeless
End Sub
If you want to ask me for any more explain i am waiting for discuss
thank you in advance for support
this is the code what I talked about in my comment
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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
'// Constants for SetWindowPos hWndInsertAfter Parameter
'Private Const HWND_TOP = 0
'Private Const HWND_BOTTOM = 1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
'// Constants for SetWindowPos wFlags Parameter
Private Const SWP_NOACTIVATE = &H10
'Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOMOVE = &H2
'Private Const SWP_NOOWNERZORDER = &H200
'Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Function OnTop(bOnTop As Boolean) As Boolean
Dim hwnd As Long
'// Find the Window using it's caption - Make sure the
'// caption is reasonably unique
hwnd = FindWindow(vbNullString, UserForm1.Caption)
If hwnd > 0 Then
If bOnTop Then
OnTop = CBool(SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOACTIVATE Or _
SWP_SHOWWINDOW Or _
SWP_NOMOVE Or _
SWP_NOSIZE))
Else
OnTop = CBool(SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, _
SWP_NOACTIVATE Or _
SWP_SHOWWINDOW Or _
SWP_NOMOVE Or _
SWP_NOSIZE))
End If
Else
OnTop = False
End If
End Function
Nothing is impossible, just sometimes we need to change our way of thinking with more focus and try all possible tricks to circumvent the problem and cross the obstacle and give up the important for the most important, with your support and advice finally I reached what I was looking for.
I made the main userforms is the Layer and the logo is fixed in the background and I made the logo on an excel sheet with some modifications to the Excel sheet I reached this result on the attached screenshot below. I think it's not so bad and it works.
thank you again for stackoverflow team for your support
I have created a VB6 program which runs in the background to another program. It means the program window will be in the back only to this other program. I am using this code for it,
Private Declare Function FindWindow1 Lib "User32" Alias "FindWindowA" (ByVal lpclassname As String, ByVal lpWindowName As String) 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_HWNDPARENT = -8
Private parenthwnd As Long
Private strTitle As String
Private Sub Form_Load()
strTitle = "My Program" 'Title of the program window
parenthwnd = FindWindow1(vbNullString, strTitle)
Dim R As Long
R = SetWindowLong(parenthwnd, GWL_HWNDPARENT, Me.hWnd)
End Sub
The other program will run this VB6 program which sets it-self to the background to the other program window. It works. But there are two problems.
When the VB6 program executes the code R = SetWindowLong(parenthwnd, GWL_HWNDPARENT, Me.hWnd), the other program along with VB6 program goes to the background. How to make other program active when it is run and the VB6 program is executed?
When the other program is closed, it has the code to terminate the VB6 program. But this does not close the VB6 program. I think this may be due to running the code R = SetWindowLong(parenthwnd, GWL_HWNDPARENT, Me.hWnd). How to fix this?
If I understand you question correctly (and I'm not sure I do) here's the code I use to send a form to the background or send the form to the top. Perhaps it's what you're looking for.
' Declares and constants for BringToFront and SendToBack
Public 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_BOTTOM = 1
Public Const HWND_TOP = 0
Public Sub BringToFront(frm As Form)
Dim flags As Long
flags = SWP_NOSIZE Or SWP_NOMOVE
SetWindowPos frm.hWnd, HWND_TOP, 0, 0, 0, 0, flags
End Sub
Public Sub SendToBack(frm As Form)
Dim flags As Long
flags = SWP_NOSIZE Or SWP_NOMOVE
SetWindowPos frm.hWnd, HWND_BOTTOM, 0, 0, 0, 0, flags
End Sub
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