Views

Histats

Vitrine

VBA Excel - Deixe os seus Formulários Transparentes - API Transparent Forms EXCEL VBA




Este é um recurso útil para formulários Splash ou onde a sua imaginação o tornar aplicável.

O que importa é que aprenda aqui como fazê-lo. 

No módulo do formulário acrescente
'============================================================================================== 
' Microsoft® Office Excel by A&A - In Any Place. 
' Copyright© A&A – In Any Place. All Rights Reserved. 
'============================================================================================== 
Option Explicit 

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 crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long 

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 Const GWL_EXSTYLE = (-20) 
Private Const WS_EX_LAYERED = &H80000 
Private Const LWA_ALPHA = &H2& 
Public hWnd As Long 


No evento de inicialização do seu formulário, faça uma chamada a função a seguir

Function OpacityNow()
' Author: Date: Contact: 
' André Bernardes 24/11/2008 10:09 bernardess@gmail.com 
' Deixando o formulário transparente. 

Dim bytOpacity As Byte 

Let bytOpacity = 195 ' Nível de opacidade. 
Let hWnd = FindWindow ("ThunderDFrame", Me.Caption) 

Call SetWindowLong (Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED) 
Call SetLayeredWindowAttributes (Me.hWnd, 0, bytOpacity, LWA_ALPHA) 
End Function 

Abaixo segue um código adaptado a partir do VB 6.0

Dim formEffectIndex As Integer 
Dim mFormRegion As Long 
Dim msg1 As String, msg2 As String 
Dim HWND 
Dim ODIALOG As Object 

Private Sub changeFormEffect (inEffect As Integer, ODIALOG As Object) 
Dim w As Single, h As Single 
Dim edge As Single, topEdge As Single 
Dim mLeft, mTop 
Dim i As Integer 
Dim r As Long 
Dim outer As Long, inner As Long 

' Put width/height in same denomination of scalewidth/scaleheight 
Let w = ODIALOG.Width 'ScaleX(Width, vbTwips, vbPixels) 
Let h = ODIALOG.Height 'ScaleY(Height, vbTwips, vbPixels) 

If inEffect = 0 Then 
Let mFormRegion = CreateRectRgn(0, 0, w, h) 

SetWindowRgn HWND, mFormRegion, True 

Exit Sub 
End If 

Let mFormRegion = CreateRectRgn(0, 0, 0, 0) 

' Frame edges measurement 
Let edge = (w) / 2 '-SCALEWIDTH 
Let topEdge = h - edge - 20 '- ScaleHeight 

' Get frame 
If inEffect = 1 Then 
outer = CreateRectRgn(0, 0, w, h) 
inner = CreateRectRgn(edge, topEdge, w - edge, h - edge) 
CombineRgn mFormRegion, outer, inner, RGN_DIFF 
End If

' Combine regions of controls on form 
' For i = 0 To Me.Controls.Count - 1 
' If Me.Controls(i).Visible = True Then 
' mLeft = Me.Controls(i).Left 'ScaleX(Me.Controls(i).Left, Me.ScaleMode, vbPixels) + edge 
' mTop = Me.Controls(i).Top 'ScaleX(Me.Controls(i).Top, Me.ScaleMode, vbPixels) + topEdge 
' r = CreateRectRgn(mLeft, mTop, _ 
' mLeft + (Me.Controls(i)), _ 
' mTop + (Me.Controls(i).Height)) 
' 'ScaleX(Me.Controls(i).Width, Me.ScaleMode, vbPixels) 
' 'ScaleY(Me.Controls(i).Height, Me.ScaleMode, vbPixels) 
' End If 
' Next 
' We allow toggle

SetWindowRgn HWND, mFormRegion, True 
End Sub 

Private Sub commandBUTTON1_Click() 
Let HWND = FindWindow("ThunderDFrame", ODIALOG.Caption) 

If formEffectIndex <> 0 Then 
Let formEffectIndex = 0 
'Let Text1.Text = msg1 

Else 
Let formEffectIndex = 1 
'Let Text1.Text = msg2 

End If 

changeFormEffect formEffectIndex, Me 
End Sub 

Private Sub commandBUTTON2_Click() 
If formEffectIndex = 1 Then 
Let formEffectIndex = 2 
Else 
Let formEffectIndex = 1 
End If 

changeFormEffect formEffectIndex, Me 
End Sub 


Private Sub command4_Click(Index As Integer) 
Let mShape = Index 

UnloadIfExist "frmShapedForm" 

frmShapedForm.Show 
End Sub 

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 
SetWindowRgn HWND, 0, False 

DeleteObject mFormRegion 
End Sub 


Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 
If Button <> vbLeftButton Then 
Exit Sub 
End If 

ReleaseCapture 

SendMessage Me.HWND, WM_NCLBUTTONDOWN, HTCAPTION, 0& 
End Sub 

' Unlike frmShapedForm, since frmTransparent is transparent, we have to 
' provide a place for user to drag if without frame, so Command0 is used. 

Private Sub Command0_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 
If Button <> vbLeftButton Then 
Exit Sub 
End If 

ReleaseCapture 

SendMessage Me.HWND, WM_NCLBUTTONDOWN, HTCAPTION, 0& 
End Sub 

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWND As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long 
Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long 
Public Declare Function SetWindowRgn Lib "user32" (ByVal HWND As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 
Public Declare Function ReleaseCapture Lib "user32" () As Long 

' RGN_OR creates the union of combined regions 
Public Const RGN_OR = 2 
' RGN_DIFF creates the intersection of combined regions 
Public Const RGN_DIFF = 4 
Public Const WM_NCLBUTTONDOWN = &HA1 
Public Const HTCAPTION = 2 
Public xp As Long, yp As Long 
Public mShape As Integer 

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
Public Declare Function SetWindowPos Lib "user32.dll" (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 Declare Function GetActiveWindow Lib "user32.dll" () 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 BringWindowToTop Lib "user32.dll" (ByVal HWND As Long) As Long 

Const WS_SYSMENU = &H80000 
Const GWL_STYLE = (-16) 

Private Sub UserForm_INITIALIZE() 
Set ODIALOG = UserForm1 

Select Case Int (Val(Application.Version)) 
Case 8 'Excel 97 
HWND = FindWindow("ThunderXFrame", ODIALOG.Caption) 'UserForm 
Case 9, 10 'Excel 2000 
HWND = FindWindow("ThunderDFrame", ODIALOG.Caption) 'UserForm 
End Select 
End Sub


Deixe os seus comentários! Envie este artigo, divulgue este link na sua rede social...

Tags: VBA, 
API, Transparent, Forms, Excel, FORM


LinkWithinBrazilVBAExcelSpecialist

Related Posts Plugin for WordPress, Blogger...