现在的位置: 首页 > 窗体增强 > 正文

VBA 窗体之放大镜窗体

2014年06月25日 窗体增强 ⁄ 共 3898字 ⁄ 字号 暂无评论 ⁄ 阅读 1,927 次

 

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

 

001

 

  

附件下载:

点击从百度网盘下载

 

操作如下:

  •  在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

 

给我留言

您必须 [ 登录 ] 才能发表留言!