Excel VBA 窗体之放大镜窗体 实现代码
发布时间:2022-04-03 11:01:34
在 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 窗体之放大镜窗体 实现代码的下载地址:
猜你喜欢
- 在Excel中经常需要从外部导入数据,而且很多数据都是以0开头的,这些数据通常导入到Excel中往往被自动去0,具体该如何解决自动去0的问题
- 1、切换到“插入”选项卡的“符号”组,在“公式”下拉菜单中选择“插入新公式”,文档中就会出现如下图右侧所示的公式编辑框。2、选中公式编辑框中
- 在项目或者运动员编号时经常需要输入例如001号这样的数字,但是excel在默认为数字的状态下式不能显示前面两0的,只能显示1。今天,小编就教
- 一篇word文档,有时要避开目录(为了演示此经验的重点,省去了生成目录过程),单独为正文设置页码,那么要怎样实现呢?今天,小编就教大家在Wo
- Excel是常用的办公软件,大部分小伙伴都有过忘记保存就关掉了文件,也有的小伙伴遭遇过停电、蓝屏不肯抗拒的因素,那么如果忘记保存了怎么办呢?
- 1.将鼠标移到需要记忆的地方,然后点击Ctrl+S对WPS文档进行保存。保存后直接关闭文档 2.接着重新打开WPS
- 在Word里面摄氏度符号怎么打,这下子把人给难住了。平常最多也只是输入些平方米、立方米、直径符号等,这次还真不知道该如何输入这个摄氏度符号了
- 其实在我们的Word编辑中,段落的样式是十分的多的,有时候在一个文档中,我们懒得重新设置样式,就可以将其他文本中的样式复制过来,不仅有效而且
- 我们在使用Win10系统时程序无响应怎么办?我们经常会遇到程序无响应的问题,程序卡死之后无法使用,多点几次就出现是否结束进程,或者直接闪退,
- 怎么把几个word合并成一个word?有些朋友在整理Word文档的时候,需要把多个文档的内容整理到一块,今天小Q来教大家一个快速合并多个文档
- 身份证号码是当前电子表格中常用的一个数据,由于其数位多,使用量大,不少单位的填表人要求个人填写好电子表再上交,如此一来,不少新手面临电子表格
- Excel表格多页怎么打印表头?我们用Excle制作表格时,一般都会制作一个表头增强阅读性,合适的表头能够让我们的表格更美观、逻辑更清晰。小
- excel中rmb函数有什么作用?很多朋友都不是很清楚,下面小编就为大家详细介绍excel中rmb函数,操作很简单的,我们一起来看看吧exc
- excel主要用于数据整理、统计、分析,而对于数据整理利用表格进行分类是不可或缺的,今天小编给大家带来一些excel制表以及表内画线的教程供
- Word2010插入软件自带的kg公斤符号的方法教学。有用户在接收到的Word文档时,发现里面有一些kg公斤符号,它使用的是软件自带的符号,
- 在Excel中经常会遇到一些需要多重条件筛选的数据情况,这个时候就要利用到Excel的函数功能,下面是由小编分享的如何使用excel多重选择
- 在使用其中的Word编辑专业文档时,我们可能会遇到“改变页边距后,再使用MathType插入右编号公式时,公式编号不能靠右对齐”的棘手情况,
- 这篇教程是向脚本之家的朋友介绍将Excel表格原封不动转换成Word文档的方法,教程比较实用,推荐到脚本之家,希望能对大家有所帮助怎么将Ex
- Excel统计数据等非常方便,但是在使用的过程中也会遇到很多的问题,比如在Excel中如何输入0开头的数字?很多伙伴会遇到这样的问题,在输入
- vb6.0怎么生成exe程序实现返回参数功能?想要编写一个exe程序,用来返回参数值,该怎么实现呢?下面我们就来看看详细的变成方法,需要的朋