Boa noite!!
Veja isso...
Font: http://www.mrexcel.com/forum/showthread.php?t=288381
Autor:Jaafar Tribak
Coloque esse código no Formulário
Option Explicit
Private Declare Function StretchBlt Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private lfrmDC As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
Width As Long
Height As Long
End Type
'________________________________________________________________________
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Long) 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
Const GWL_STYLE = (-16)
Const WS_SYSMENU = &H80000
Private Const WS_CAPTION As Long = &HC00000
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
'_________________________________________________________________________
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private lfrmHwnd As Long
'_________________________________________________________________________
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private objCmb As CommandBar
Private Sub UserForm_Initialize()
Dim lBmp As Long
Dim IPic As IPicture
Dim Screen As POINTAPI
'assign the form handle to a module level var
'will be needed throughout the module
lfrmHwnd = FindWindow(vbNullString, Me.Caption)
'setup the shape of our form so it looks
'like a round magnifying glass
Call FormSetUp(lfrmHwnd)
'get the form dc on which the drawing will be made
lfrmDC = GetDC(lfrmHwnd)
'get the screen dimensions
Screen = GetScreenDims
'get a pointer of the screen bitmap
lBmp = GetScrnBmpHandle(GetDC(0), 0, 0, Screen.Width, Screen.Height)
'create a picture from the bitmap pointer
Set IPic = GetBitmapPic(lBmp)
'save bitmap to disk
stdole.SavePicture IPic, (Environ("Temp")) & "Scr.Bmp"
'set the form picture to display the bitmap
Me.Picture = LoadPicture((Environ("Temp")) & "Scr.Bmp")
'clean up
Kill (Environ("Temp")) & "Scr.Bmp"
End Sub
Private Sub UserForm_Activate()
'the layout event doesn't fire here so refresh form now
Me.Repaint
Call UserForm_Layout
End Sub
Private Sub UserForm_Layout()
'update the userform background upon moving it
StretchBlt _
lfrmDC, 0, 0, Me.Width * 1.5, Me.Height * 1.5, _
lMemoryDC, Me.Left * 1.5, Me.Top * 1.5, _
Me.Width, Me.Height, SRCCOPY
End Sub
Private Sub UserForm_MouseDown _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'show close menu
If Button = 2 Then objCmb.ShowPopup
End Sub
Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'move the captionless form with the mouse
If Button = 1 Then
Call ReleaseCapture
SendMessage lfrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'safety cleanup
On Error Resume Next
DeleteDC lMemoryDC
CommandBars("GlassPopUp").Delete
End Sub
'*** Supporting functions *******************************
Private Function GetScrnBmpHandle _
(lScrDC As Long, lScrnLeft As Long, lScrnTop As Long, _
lScrnWidth As Long, lScrnHeight As Long) As Long
Dim lBmp, lOldBmp As Long
'create a temp memory dc on which to copy the current screen shot
lMemoryDC = CreateCompatibleDC(lScrDC)
'create a bmp
lBmp = CreateCompatibleBitmap(lScrDC, lScrnWidth, lScrnHeight)
'select the bmp onto the temp dc
lOldBmp = SelectObject(lMemoryDC, lBmp)
DeleteObject lBmp
'copy the screen image onto the temp dc
BitBlt lMemoryDC, 0, 0, lScrnWidth, lScrnHeight, _
lScrDC, lScrnLeft, lScrnTop, SRCCOPY
'return our bmp pointer
GetScrnBmpHandle = lBmp
End Function
Private Function GetBitmapPic(ByVal lBmpHandle As Long) As IPicture
Dim r As Long, IPic As IPicture, IID_IDispatch As GUID, Pic As uPicDesc
'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = 1 ' Type of Picture (bitmap)
.hPic = lBmpHandle ' Handle to bitmap
.hPal = 0 ' Handle to palette (may be null)
End With
'create the pic
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
Set GetBitmapPic = IPic
End Function
Private Function GetScreenDims() As POINTAPI
'get screen width an height
Dim r As POINTAPI
With r
.Width = GetSystemMetrics(SM_CXSCREEN)
.Height = GetSystemMetrics(SM_CYSCREEN)
End With
GetScreenDims = r
End Function
Private Sub FormSetUp(lhwnd As Long)
Dim lHr, IStyle As Long
'adjust form dims
Me.Width = 210
Me.Height = 195
'Create rightclick close menu
On Error Resume Next
CommandBars("GlassPopUp").Delete
Set objCmb = Application.CommandBars.Add(Position:=msoBarPopup)
With objCmb
objCmb.Name = "GlassPopUp"
With .Controls.Add(msoControlButton)
.Caption = "CloseMe"
.OnAction = "CloseGlass"
End With
End With
On Error GoTo 0
'set the mouse pointer so it simulates
'that of a magnifying glass
Me.MousePointer = fmMousePointerCross
'make the userform captionless and round
'so it simulates a magnifying glass
IStyle = GetWindowLong(lhwnd, GWL_STYLE)
IStyle = IStyle And Not WS_CAPTION 'And WS_THICKFRAME
SetWindowLong lhwnd, GWL_STYLE, IStyle
DrawMenuBar lhwnd
lHr = CreateEllipticRgn(0, 0, Me.Width, Me.Height)
SetWindowRgn lhwnd, lHr, True
End Sub
Esse código em modulo
Option Explicit
Public lMemoryDC As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Sub CloseGlass()
On Error Resume Next
DeleteDC lMemoryDC
CommandBars("GlassPopUp").Delete
Unload UserForm1
End Sub
Sub Bouton1_QuandClic()
UserForm1.Show
End Sub
Postado : 30/04/2012 6:00 pm