在 Windows 的附件中有一个工具叫放大镜，看着不错有意思。有时候自己动手做一个也很有感觉。那我们就用 VBA 来做一个简陋版的放大镜，看着简陋其实也不错的。
附件下载：
点击从百度网盘下载
操作如下：◾ 在Excel 的VBE窗口中插入一个用户窗体，将其命名为 frmMagnifyingGlass。然后再添加一个模块。在窗体和模块中添加后面所列代码。◾ 在工作薄中的任意工作表中添加一窗体按钮控件，将指定其设置宏为 btnShowMagnifyingGlass_Click。其供示范之用
具体代码：
WPS之家https://www.qiangguoshuo.com
"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 LongPtrPublic FHwnd As LongPtrPublic 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 LongPublic FHwnd As LongPublic FHdc As Long#End If'以下定义类型Private Type POINTAPIx As Longy As LongEnd Type'以下声明常数和变量Public Const SRCCOPY = &HCC0020Public Const LOGPIXELSX = &H58Public FLogPixelsx As LongPrivate FPoint As POINTAPIPrivate dx As LongPrivate 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 0End 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 IfPrivate 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 SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)'结束Settimer过程If FTID <> 0 Then Call KillTimer(FHwnd, FTID)'释放设备场景，记住一定要释放Call ReleaseDC(FHwnd, FHdc)End Sub
转载声明：本站发布文章及版权归原作者所有，转载本站文章请注明文章来源！
