在 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