定制化窗体之放大镜

来源:百度文库 编辑:神马文学网 时间:2024/03/29 10:06:34
定制化窗体之放大镜(1)
2007-12-12 15:26
主     题
定制化窗体之放大镜
版     本
Excel2000及其以后版本
说     明
本示例运用API函数来定制Excel中的用户窗体,制作了一个放大镜窗体。(Code By 王明柏)
在WINDOWS的附件中有一个放大镜,这东西感觉很有意思。那我也来作一个。
l         在Excel 的VBE窗口中插入一个用户窗体,将其命名为 FangDaJing 。然后再添加一个模块。在窗体和模块中添加后面所列代码。
l         在工作薄中的任意工作表中添加一窗体按钮控件,将指定其 设置宏 为 ShowForm。其供示范之用
l         代码:
模块1代码:
Option Explicit
'//****************************************************************************************************************************************
'//此模块为回调函数和工作表中按钮调用程序
'//****************************************************************************************************************************************
'//释放设备场景
Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal Hwnd As Long, _
ByVal hdc As Long) _
As Long
'//获取鼠标指针的当前位置
Private Declare Function GetCursorPos _
Lib "user32" ( _
lpPoint As POINTAPI) _
As Long
'//取得设备场景
Private Declare Function _
GetDC Lib "user32" ( _
ByVal Hwnd As Long) _
As Long
'//将一幅位图从一个设备场景复制到另一个
Private 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
'//查找窗口
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
'//以下定义类型
Private Type POINTAPI
x As Long
y As Long
End Type
'//以下声明常数和变量
Private Const SRCCOPY = &HCC0020
Private MyPoint As POINTAPI
'//****************************************************************************************************************************************
'//Settimer函数的回调函数
'//****************************************************************************************************************************************
Public Function TimeOutProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
Dim HwndForm As Long
Dim dx As Long
Dim dy As Long
Dim dl As Long
Dim hdc As Long
'//获得当前鼠标位置
dl = GetCursorPos(MyPoint)
dx = MyPoint.x
dy = MyPoint.y
'//取得窗口句柄
HwndForm = FindWindow(vbNullString, FangDaJing.Caption)
'//取得窗体设备场景
hdc = GetDC(HwndForm)
'//将位图复制到窗体设备场景
dl = StretchBlt(hdc, 0, 0, FangDaJing.InsideWidth * 4 / 3, FangDaJing.InsideHeight * 4 / 3, GetDC(0), dx, dy, 100, 100 * FangDaJing.InsideHeight / FangDaJing.InsideWidth, SRCCOPY)
'//释放设备场景,记住一定要释放
ReleaseDC HwndForm, hdc
End Function
'//--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'//此程序为工作表中按钮调用
Sub ShowForm()
'//显示窗体(无模式)
FangDaJing.Show 0
End Sub
定制化窗体之放大镜(2)
2007-12-12 15:27
FangDaJing窗体代码:
Option Explicit
'//****************************************************************************************************************************************
'//此模块示范了一个放大镜
'//****************************************************************************************************************************************
'//以下声明API函数
'//设置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 Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" ( _
ByVal Hwnd As Long, _
ByVal nIndex As Long) _
As Long
'//设置窗口样式
Private Declare Function SetWindowLong _
Lib "user32" _
Alias "SetWindowLongA" ( _
ByVal Hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) _
As Long
'//查找窗口
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As Long
'//以下定义常数及变量
Private Const WS_EX_TOOLWINDOW = &H80                     '工具窗体样式
Private Const GWL_EXSTYLE = (-20)                              '拓展窗体样式
Private TID As Long
Private Hwnd As Long                                            '用于寄存窗体句柄
'//****************************************************************************************************************************************
'//                             过程
'//****************************************************************************************************************************************
Private Sub UserForm_Initialize()
Dim Istype As Long
'//取得窗口句柄
Hwnd = FindWindow(vbNullString, Me.Caption)
'//取得窗口拓展样式位
Istype = GetWindowLong(Hwnd, GWL_EXSTYLE)
'//窗口样式:原样式和工具窗口
Istype = Istype Or WS_EX_TOOLWINDOW
'//重设窗体样式位
SetWindowLong Hwnd, GWL_EXSTYLE, Istype
'//设置Settimer 过程
TID = SetTimer(Hwnd, 0, 20, AddressOf TimeOutProc)
End Sub
'//--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'//结束Settimer 过程
If TID <> 0 Then KillTimer Hwnd, TID
End Sub