Excel VBA 窗体之放大镜窗体 实现代码

在 Windows 的附件中有一个工具叫放大镜，看着不错有意思。有时候自己动手做一个也很有感觉。那我们就用 VBA 来做一个简陋版的放大镜，看着简陋其实也不错的。

附件下载：

点击从百度网盘下载

操作如下：
◾ 在Excel 的VBE窗口中插入一个用户窗体，将其命名为 frmMagnifyingGlass。然后再添加一个模块。在窗体和模块中添加后面所列代码。
◾ 在工作薄中的任意工作表中添加一窗体按钮控件，将指定其设置宏为 btnShowMagnifyingGlass_Click。其供示范之用

具体代码：

"mdMagnifyingGlass" 模块代码

Option Explicit
'********************************************
'---此模块为回调函数和工作表中按钮调用程序---
'********************************************
#If Win64 Then '64位
'获取设备数据
Public Declare PtrSafe Function GetDeviceCaps _
Lib "gdi32"( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) _
As Long
'释放设备场景
Public Declare PtrSafe Function ReleaseDC _
Lib "user32" ( _
ByVal Hwnd As LongPtr, _
ByVal hdc As LongPtr) _
As Long
'获取鼠标指针的当前位置
Public Declare PtrSafe Function GetCursorPos _
Lib "user32" ( _
lpPoint As POINTAPI) _
As Long
'取得设备场景
Public Declare PtrSafe Function GetDC _
Lib "user32" ( _
ByVal Hwnd As LongPtr) _
As LongPtr
'将一幅位图从一个设备场景复制到另一个
Public Declare PtrSafe Function StretchBlt _
Lib "gdi32" ( _
ByVal hdc As LongPtr, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As LongPtr, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) _
As Long
'查找窗口
Public Declare PtrSafe Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As LongPtr
Public FHwnd As LongPtr
Public FHdc As LongPtr
#Else
'获取设备数据
Public Declare Function GetDeviceCaps _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) _
As Long
'释放设备场景
Public Declare Function ReleaseDC _
Lib "user32" ( _
ByVal Hwnd As Long, _
ByVal hdc As Long) _
As Long
'获取鼠标指针的当前位置
Public Declare Function GetCursorPos _
Lib "user32" ( _
lpPoint As POINTAPI) _
As Long
'取得设备场景
Public Declare Function GetDC _
Lib "user32" ( _
ByVal Hwnd As Long) _
As Long
'将一幅位图从一个设备场景复制到另一个
Public 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
'查找窗口
Public Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
Public FHwnd As Long
Public FHdc As Long
#End If
'以下定义类型
Private Type POINTAPI
x As Long
y As Long
End Type
'以下声明常数和变量
Public Const SRCCOPY = &HCC0020
Public Const LOGPIXELSX = &H58
Public FLogPixelsx As Long
Private FPoint As POINTAPI
Private dx As Long
Private dy As Long
'***************************
'---Settimer函数的回调函数---
'***************************
Public Function TimeOutProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
'获得当前鼠标位置
Call GetCursorPos(FPoint)
dx = FPoint.x: dy = FPoint.y
'将位图复制到窗体设备场景
Call StretchBlt(FHdc, 0, 0, frmMagnifyingGlass.InsideWidth * FLogPixelsx / 72, frmMagnifyingGlass.InsideHeight * FLogPixelsx / 72, _
GetDC(0), dx, dy, 150, 150 * frmMagnifyingGlass.InsideHeight / frmMagnifyingGlass.InsideWidth, SRCCOPY)
End Function
'此程序为工作表中按钮调用
Sub btnShowMagnifyingGlass_Click()
'显示窗体（无模式）
frmMagnifyingGlass.Show 0
End Sub

"frmMagnifyingGlass" 窗体代码

Option Explicit
'***********************
'------窗体过程代码------
'***********************
'以下声明API函数
#If Win64 Then '64位
'用来设置Settimer过程。
Private Declare PtrSafe Function SetTimer _
Lib "user32" ( _
ByVal Hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerfunc As LongPtr) _
As LongPtr
'结束Settimer过程
Private Declare PtrSafe Function KillTimer _
Lib "user32" ( _
ByVal Hwnd As LongPtr, _
ByVal nIDEvent As LongPtr) _
As Long
'以下定义变量
Private FTID As LongPtr
#Else
'用来设置Settimer过程。
Private Declare Function SetTimer _
Lib "user32" ( _
ByVal Hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerfunc As Long) _
As Long
'结束Settimer过程
Private Declare Function KillTimer _
Lib "user32" ( _
ByVal Hwnd As Long, _
ByVal nIDEvent As Long) _
As Long
'以下定义变量
Private FTID As Long
#End If
Private Sub UserForm_Initialize()
'取得窗口句柄
FHwnd = FindWindow(vbNullString, Me.Caption)
'取得窗体设备场景
FHdc = GetDC(FHwnd)
'取得每英寸所包含的像素
FLogPixelsx = GetDeviceCaps(GetDC(0), LOGPIXELSX)
'设置Settimer 过程
FTID = SetTimer(FHwnd, 0, 100, AddressOf TimeOutProc)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'结束Settimer过程
If FTID <> 0 Then Call KillTimer(FHwnd, FTID)
'释放设备场景，记住一定要释放
Call ReleaseDC(FHwnd, FHdc)
End Sub

Excel VBA 窗体之放大镜窗体 实现代码的下载地址：

本地下载