✔ VBA Dashboards Specialist®: VBA Excel - Deixe os seus Formulários Transparentes

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

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