五一电子阅读：《贵宾专区》—《VB编程精彩杂文收集》

1 VB编程
〖ALT键+鼠标右键开始╱暂停;鼠标左键控制速度〗
启动自动滚屏功能
VB编程的七个优良习惯
作者:木子
1、"&"替换"+" 2、变量命名大小写,语句错落有秩,源代码维护方面
3、请养成以下的“对象命名约定”良好习惯 4、在简单的选择条件情况下,使用IIf()函数
5、尽量使用Debug.Print进行调试 6、在重复对某一对象的属性进行修改时,尽量使用With....End With
7、MsgBox中尽量使用消息图标,这样程序比较有规范 8、在可能的情况下使用枚举

1、"&"替换"+"
在很多人的编程语言中,用“+”来连接字符串,这样容易导致歧义。良好的习惯是用“&”来连接字符串.

不正确:
Dim sMessage As String
sMessage = "1" + "2"

正确:
Dim sMessage As String
sMessage = "1" & "2"

注意:"&"的后面有个空格

2、变量命名大小写,语句错落有秩,源代码维护方面

下面大家比较一下以下两段代码:

读懂难度很大的代码:

Dim SNAME As String
Dim NTURN As Integer

If NTURN = 0 Then
If SNAME = "vbeden" Then
Do While NTURN < 4
NTURN = NTURN + 1
Loop
End If
End If

容易读懂的代码:

Dim sName As String
Dim nTurn As Integer

If nTurn = 0 Then
   If sName = "vbeden" Then
      Do While nTurn < 4
          nTurn = nTurn + 1
      Loop
   End If
End If

[返回索引]

3、请养成以下的“对象命名约定”良好习惯

推荐使用的控件前缀

控件类型前缀例子
3D Panel pnl pnlGroup
ADO Data ado adoBiblio
Animated button ani aniMailBox
Check box chk chkReadOnly
Combo box, drop-down list box cbo cboEnglish
Command button cmd cmdExit
Common dialog dlg dlgFileOpen
Communications com comFax
Control (当特定类型未知时,在过程中所使用的) ctr ctrCurrent
Data dat datBiblio
Data-bound combo box dbcbo dbcboLanguage
Data-bound grid dbgrd dbgrdQueryResult
Data-bound list box dblst dblstJobType
Data combo dbc dbcAuthor
Data grid dgd dgdTitles
Data list dbl dblPublisher
Data repeater drp drpLocation
Date picker dtp dtpPublished
Directory list box dir dirSource
Drive list box drv drvTarget
File list box fil filSource
Flat scroll bar fsb fsbMove
Form frm frmEntry
Frame fra fraLanguage
Gauge gau gauStatus
Graph gra graRevenue
Grid grd grdPrices
Hierarchical flexgrid flex flexOrders
Horizontal scroll bar hsb hsbVolume
Image img imgIcon
Image combo imgcbo imgcboProduct
ImageList ils ilsAllIcons
Label lbl lblHelpMessage
Lightweight check box lwchk lwchkArchive
Lightweight combo box lwcbo lwcboGerman
Lightweight command button lwcmd lwcmdRemove
Lightweight frame lwfra lwfraSaveOptions
Lightweight horizontal scroll bar lwhsb lwhsbVolume
Lightweight list box lwlst lwlstCostCenters
Lightweight option button lwopt lwoptIncomeLevel
Lightweight text box lwtxt lwoptStreet
Lightweight vertical scroll bar lwvsb lwvsbYear
Line lin linVertical
List box lst lstPolicyCodes
ListView lvw lvwHeadings
MAPI message mpm mpmSentMessage
MAPI session mps mpsSession
MCI mci mciVideo
Menu mnu mnuFileOpen
Month view mvw mvwPeriod
MS Chart ch chSalesbyRegion
MS Flex grid msg msgClients
MS Tab mst mstFirst
OLE container ole oleWorksheet
Option button opt optGender
Picture box pic picVGA
Picture clip clp clpToolbar

作者: 61.142.212.* 2005-10-28 20:38 　回复此发言

--------------------------------------------------------------------------------

2 VB编程
ProgressBar prg prgLoadFile
Remote Data rd rdTitles
RichTextBox rtf rtfReport
Shape shp shpCircle
Slider sld sldScale
Spin spn spnPages
StatusBar sta staDateTime
SysInfo sys sysMonitor
TabStrip tab tabOptions
Text box txt txtLastName
Timer tmr tmrAlarm
Toolbar tlb tlbActions
TreeView tre treOrganization
UpDown upd updDirection
Vertical scroll bar vsb vsbRate

--------------------------------------------------------------------------------
推荐使用的数据访问对象 (DAO) 的前缀
用下列前缀来指示数据访问对象
数据库对象前缀例子
Container con conReports
Database db dbAccounts
DBEngine dbe dbeJet
Document doc docSalesReport
Field fld fldAddress
Group grp grpFinance
Index ix idxAge
Parameter prm prmJobCode
QueryDef qry qrySalesByRegion
Recordset rec recForecast
Relation rel relEmployeeDept
TableDef tbd tbdCustomers
User usr usrNew
Workspace wsp wspMine

--------------------------------------------------------------------------------

应用程序频繁使用许多菜单控件,对于这些控件具备一组唯一的命名约定很实用。除了最前面 "mnu" 标记以外,菜单控件的前缀应该被扩展:对每一级嵌套增加一个附加前缀,将最终的菜单的标题放在名称字符串的最后。下表列出了一些例子。

推荐使用的菜单前缀
菜单标题序列菜单处理器名称
File Open mnuFileOpen
File Send Email mnuFileSendEmail
File Send Fax mnuFileSendFax
Format Character mnuFormatCharacter
Help Contents mnuHelpContents

当使用这种命名约定时,一个特定的菜单组的所有成员一个接一个地列在 Visual Basic 的“属性”窗口中。而且,菜单控件的名字清楚地表示出它们所属的菜单项。

为其它控件选择前缀

对于上面没有列出的控件,应该用唯一的由两个或三个字符组成的前缀使它们标准化,以保持一致性。只有当需要澄清时,才使用多于三个字符的前缀。

常量和变量命名约定
除了对象之外,常量和变量也需要良好格式的命名约定。本节列出了 Visual Basic 支持的常量和变量的推荐约定。并且讨论标识数据类型和范围的问题。

变量应该总是被定义在尽可能小的范围内。全局 (Public) 变量可以导致极其复杂的状态机构,并且使一个应用程序的逻辑非常难于理解。全局变量也使代码的重用和维护更加困难。

Visual Basic 中的变量可以有下列范围

范围声明位置可见位置
过程级过程,子过程或函数过程中的 ‘Private’ 在声明它的过程中
模块级窗体或代码模块(.frm、.bas )的声明部分中的 ‘Private’ 窗体或代码模块中的每一个过程
全局代码模块(.bas)的声明部分中的 ‘Public’ 应用程序中的每一处

在 Visual Basic 的应用程序中,只有当没有其它方便途径在窗体之间共享数据时才使用全局变量。当必须使用全局变量时,在一个单一模块中声明它们,并按功能分组。给这个模块取一个有意义的名称,以指明它的作用,如 Public.bas。

较好的编码习惯是尽可能写模块化的代码。例如,如果应用程序显示一个对话框,就把要完成这一对话任务所需要的所有控件和代码放在单一的窗体中。这有助于将应用程序的代码组织在有用的组件中,并减小它运行时的开销。

除了全局变量(应该是不被传递的),过程和函数应该仅对传递给它们的对象操作。在过程中使用的全局变量应该在过程起始处的声明部分中标识出来。此外,应该用 ByVal 将参数传递给 Sub 过程及 function 过程,除非明显地需要改变已传递的参数值。

随着工程大小的增长,划分变量范围的工作也迅速增加。在类型前缀的前面放置单字母范围前缀标明了这种增长,但变量名的长度并没有增加很多。

作者: 61.142.212.* 2005-10-28 20:38 　回复此发言

--------------------------------------------------------------------------------

3 VB编程

变量范围前缀

范围前缀例子
全局 g gstrUserName
模块级 m mblnCalcInProgress
本地到过程无 dblVelocity

如果一个变量在标准模块或窗体模块中被声明为 Public,那么该变量具有全局范围。如果一个变量在标准模块或窗体模块中被分别声明为 Private,那么该变量有模块级范围。

注意: 一致性是卓有成效地使用这种技术的关键;Visual Basic 中的语法检查器不会捕捉以 "p." 开头的模块级变量。

常量
常量名的主体是大小写混合的,每个单词的首字母大写。尽管标准 Visual Basic 常量不包含数据类型和范围信息,但是象 i、s、g 和 m 这样的前缀对于理解一个常量的值和范围还是很有用的。对于常量名,应遵循与变量相同的规则。例如:

mintUserListMax   '对用户列表的最大限制
                  '(整数值,本地到模块)
gstrNewLine       '新行字符
                  '(字符串,应用程序全局使用)

变量
声明所有的变量将会节省编程时间,因为键入操作引起的错误减少了(例如,究竟是 aUserNameTmp,还是 sUserNameTmp,还是 sUserNameTemp)。在“选项”对话框的“编辑器”标签中,复选“要求变量声明”选项。Option Explicit 语句要求在 Visual Basic 程序中声明所有的变量。

应该给变量加前缀来指明它们的数据类型。而且前缀可以被扩展,用来指明变量范围,特别是对大型程序。

用下列前缀来指明一个变量的数据类型。

变量数据类型

数据类型前缀例子
String (字符串类型) str strFName
Integer (短整数类型) int intQuantity
Long (长整数类型) lng lngDistance
Single (单精度浮点数类型) sng sngAverage
Double (双精度浮点数类型) dbl dblTolerance
Boolean (布尔类型) bln blnFound
Byte (字节类型) byt bytRasterData
Date (日期类型) dte dteNow
Currency (货币计算与定点计算类型) cur curRevenue
Object (对象类型) obj objCurrent
Variant (变体类型) vnt vntCheckSum

描述变量和过程名

变量或过程名的主体应该使用大小写混合形式,并且应该足够长以描述它的作用。而且,函数名应该以一个动词起首,如 InitNameArray 或 CloseDialog。

对于频繁使用的或长的项,推荐使用标准缩略语以使名称的长度合理化。一般来说,超过 32 个字符的变量名在 VGA 显示器上读起来就困难了。

当使用缩略语时,要确保它们在整个应用程序中的一致性。在一个工程中,如果一会儿使用 Cnt, 一会儿使用 Count,将导致不必要的混淆。

用户定义的类型
在一项有许多用户定义类型的大工程中,常常有必要给每种类型一个它自己的三个字符的前缀。如果这些前缀是以 "u" 开始的,那么当用一个用户定义类型来工作时,快速识别这些类型是很容易的。例如,ucli 可以被用来作为一个用户定义的客户类型变量的前缀。

[返回索引]

4、在简单的选择条件情况下,使用IIf()函数

罗索的代码:
If nNum = 0 Then
sName = "sancy"
Else
sName = "Xu"
End If

简单的代码:
sName=IIf(nNum=0,"sancy","Xu")

5、尽量使用Debug.Print进行调试

在很多初学者的调试中,用MsgBox来跟踪变量值.其实用Debug.Print不仅可以达到同样的功效,而且在程序最后编译过程中,会被忽略.而MsgBox必须手动注释或删除.

通常:
MsgBox nName

应该:
Debug.Print nName

6、在重复对某一对象的属性进行修改时,尽量使用With....End With

通常:
Form1.Height = 5000
Form1.Width = 6000
Form1.Caption = "This is MyLabel"

应该:
With Form1
.Height = 5000
.Width = 6000
.Caption = "This is MyLabel"
End With
这种结构程序执行效率比较高,特别在循环语句里。

7、MsgBox中尽量使用消息图标,这样程序比较有规范

作者: 61.142.212.* 2005-10-28 20:38 　回复此发言

--------------------------------------------------------------------------------

4 VB编程

一般来说

vbInformation 用来提示确认或成功操作的消息

vbExclamation 用来提示警告的消息

vbCritical 用来提示危机情况的消息

vbQuestion 用来提示询问的消息

[返回索引]

8、在可能的情况下使用枚举

枚举的格式为
[Public | Private] Enum name
membername [= constantexpression]
membername [= constantexpression]
....
End Enum

Enum 语句包含下面部分:

部分描述
Public 可选的。表示该 Enum 类型在整个工程中都是可见的。Enum 类型的缺省情况是 Public。
Private 可选的。表示该 Enum 类型只在所声明的模块中是可见的。
name 必需的。该 Enum 类型的名称。name 必须是一个合法的 Visual Basic 标识符,在定义该 Enum 类型的变量或参数时用该名称来指定类型。
membername 必需的。用于指定该 Enum 类型的组成元素名称的合法 Visual Basic 标识符。
constantexpression 可选的。元素的值(为 Long 类型)。可以是别的 Enum 类型。如果没有指定 constantexpression,则所赋给的值或者是 0(如果该元素是第一个 membername),或者比其直接前驱的值大 1。

说明
所谓枚举变量,就是指用 Enum 类型定义的变量。变量和参数都可以定义为 Enum 类型。Enum 类型中的元素被初始化为 Enum 语句中指定的常数值。所赋给的值可以包括正数和负数,且在运行时不能改变。例如:

Enum SecurityLevel IllegalEntry = -1 SecurityLevel1 = 0 SecurityLevel2 = 1 End Enum

Enum 语句只能在模块级别中出现。定义 Enum 类型后,就可以用它来定义变量,参数或返回该类型的过程。不能用模块名来限定 Enum 类型。类模块中的 Public Enum 类型并不是该类的成员;只不过它们也被写入到类型库中。在标准模块中定义的 Enum 类型则不写到类型库中。具有相同名字的 Public Enum 类型不能既在标准模块中定义,又在类模块中定义,因为它们共享相同的命名空间。若不同的类型库中有两个 Enum 类型的名字相同,但成员不同,则对这种类型的变量的引用,将取决于哪一个类型库具有更高的引用优先级。

不能在 With 块中使用 Enum 类型作为目标。

Enum 语句示例
下面的示例演示用 Enum 语句定义一个命名常数的集合。在本例中是一些可以选择的颜色常数用于设计数据库的数据输入窗体。

Public Enum InterfaceColors
icMistyRose = &HE1E4FF&
icSlateGray = &H908070&
icDodgerBlue = &HFF901E&
icDeepSkyBlue = &HFFBF00&
icSpringGreen = &H7FFF00&
icForestGreen = &H228B22&
icGoldenrod = &H20A5DA&
icFirebrick = &H2222B2&
End Enum

好处是加快编程速度

作者: 61.142.212.* 2005-10-28 20:38 　回复此发言

--------------------------------------------------------------------------------

5 VB编程基础课
VB编程基础课
什么是API API文本游览器
API函数声明数据类型与"类型安全"
常数结构
小结一些API函数集: 控件与消息函数、硬件与系统函数、菜单函数、绘图函数

什么是API [返回]

首先,有必要向大家讲一讲,什么是API。所谓API本来是为C和C++程序员写的。API说来说去,就是一种函数,他们包含在一个附加名为DLL的动态连接库文件中。用标准的定义来讲,API就是Windows的32位应用程序编程接口,是一系列很复杂的函数,消息和结构,它使编程人员可以用不同类型的编程语言编制出的运行在Windows95和Windows NT操作系统上的应用程序。可以说,如果你曾经学过VC,那么API对你来说不是什么问题。但是如果你没有学过VC,或者你对Windows95的结构体系不熟悉,那么可以说,学习API将是一件很辛苦的事情。

如果你打开WINDOWS的SYSTEM文件夹,你可以发现其中有很多附加名为DLL的文件。一个DLL中包含的API函数并不只是一个,数十个,甚至是数百个。我们能都掌握它嘛?回答是否定的∶不可能掌握。但实际上,我们真的没必要都掌握,只要重点掌握Windos系统本身自带的API函数就可以了。但,在其中还应当抛开掉同VB本身自有的函数重复的函数。如,VB
的etAttr命令可以获得文件属性,SetAttr可以设置文件属性。对API来讲也有对应的函数
GetFileAttributes和SetFileAttributes,性能都差不多。如此地一算,剩下来的也就5、600个。是的,也不少。但,我可以敢跟你说,只要你熟悉地掌握100个,那么你的编程水平比现在高出至少要两倍。尽管人们说VB和WINDOWS具有密切的关系,但我认为,API更接近
WINDOWS。如果你学会了API,首要的收获便是对WINDOWS体系结构的认识。这个收获是来自不易的。

如果你不依靠API会怎么样?我可以跟你说,绝大多是高级编程书本(当然这不是书的名程叫高级而高级的,而是在一开始的《本书内容》中指明《本书的阅读对象是具有一定VB基础的读者》的那些书),首先提的问题一般大都是从API开始。因此可以说,你不学API,你大概将停留在初级水平,无法往上攀登。唯一的途径也许就是向别人求救∶我快死了,快来救救我呀,这个怎么办,那个怎么办?烦不烦呢?当然,现在网上好人太多(包括我在内,嘻嘻),但,你应当明白,通过此途径,你的手中出不了好的作品。这是因为缺乏这些知识你的脑子里根本行不成一种总体的设计构思。
API文本游览器 [返回]

很多API函数都是很长很长的。想看什么样子吗?如下就是作为例子的API DdeClientTransaction函数∶
Declare Function DdeClientTransaction Lib "user32" (pData As Byte, ByVal cbData As Long, ByVal hConv As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal wType As Long, ByVal dwTimeout As Long, pdwResult As Long) As Long
哇!这么长?如果你从来没有接触过API,我想你肯定被吓住了。你也许考虑,该不该继续学下去。不过不要担心,幸运的是Microsoft的设计家们为我们提供了有用的工具,这便是API
文本查看器。

通过API文本查看器,我们可以方便地查找程序所需要的函数声明、结构类型和常数,然后将它复制到剪贴板,最后再粘贴到VB程序的代码段中。在大多数情况下,只要我们确定了程序所需要的函数、结构和常数这三个方面后,就可以通过对API文本游览器的以上操作将他们加入到程序段中,从而程序中可以使用这些函数了。这些是学习API最基本的常识问题,它远远占不到API的庞大的体系内容。今后我们把精力浪费(这绝不是浪费)在哪里呢?那就是∶
什么时候使用什么函数,什么时候使用什么结构类型,什么时候使用什么常数。
API函数声明 [返回]

让我们回想一下。在VB中,如何声明函数呢?我想,如果你正在看此文,那么你绝对能够回答得出这个问题。以下便是你应该很熟悉的函数声明∶
Function SetFocus (ByVal hwnd As Long) As Long

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

6 VB编程基础课
即,这行代码定义了名为SetFocus的函数,此函数具有一个Long型数据类型的参数,并按值传递(ByVal),函数执行后将返回一个Long型数据。
API函数的声明也很类似,如,API中的SetFocus 函数是这样写的∶

Declare Function SetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
有点复杂了一些。是的,是复杂了点。但我可以告诉你,除了这些多出来的部分,其他部分还是和你以前学到的东西是一样的。函数在程序中的调用也是一样。如:
Dim dl As Long
dl&=SetFoucs(Form1.Hwnd)
但,一点是清楚的。它不象你自己写的程序那样能够看到里面的运行机理,也不像VB
自带的函数那样,能够从VB的联机帮助中查到其用法。唯一的方法就是去学、查VB以外的资料。

Declare 语句用于在模块级别中声明对动态链接库 (DLL) 中外部过程的引用。对此,你只要记住任何API函数声明都必须写这个语句就可以了。
Iib 指明包含所声明过程或函数的动态链接库或代码资源。也就是说,它说明的是,函数或过程从何而来的问题。
如在上例中,SetFocus Lib "user32"说明函数 SetFocus 来自 user32.dll文件。主要的dll动态连接库文件有∶
user32.dll Windows管理。生成和管理应用程序的用户接口。

GDI32.dll 图形设备接口。产生Windows设备的图形输出
Kernel32.dll 系统服务。访问操作系统的计算机资源。
注意,当DLL文件不在Windows或System文件夹中的时候,必须在函数中说明其出处(
路径)。如,SetFocus Lib "c:\Mydll\user32"
函数声明中的Alias 是可选的。表示将被调用的过程在动态链接库 (DLL) 中还有另外的名称(别名)。如,Alias "SetFocus" ,说明SetFocus函数在User32.dll中的另外一个名称是,
SetFocus。怎么两个名都一样呢?当然,也可以是不同的。在很多情况下,Alias说明的函数名,即别名最后一个字符经常是字符A,如SetWindowsText函数的另一个名称是
SetWindowsTextA,表示为Alias "SetWindowsTextA"。这个A只不过是设计家们的习惯的命名约定,表示函数属于ANSI版本。

那么,别名究竟有什么用途呢?从理论上讲,别名提供了用另一个名子调用API的函数方法。如果你指明了别名,那么尽管我们按Declare语句后面的函数来调用该函数,但在函数的实际调用上是以别名作为首要选择的。如,以下两个函数(Function,ABCD)声明都是有效的,他们调用的是同一个 SetFocus函数∶
Declare Function SetFocus Lib "user32" "SetFocus" (ByVal hwnd As Long) As Long
Declare ABCD SetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long

需要注意的是,选用Alias的时候,应注意别名的大小写;如果不选用Alias 时的时候,函数名必须注意大小写,而且不能改动。当然,在很多情况下,由于函数声明是直接从API
文本游览器中拷贝过来的,所以这种错误的发生机会是很少的,但您有必要知道这一点。
最后提醒你一句,API声明(包括结构、常数)必须放在窗体或模块的"通用(General Declarations)段。
数据类型与"类型安全" [返回]

API函数中使用的数据类型基本上和VB中的一样。但作为WIN32的API函数中,不存在Integer
数据类型。另外一点是在API函数中看不到Boolean数据类型。 Variant数据类型在API函数中是以Any的形式出现,如Data As Any。尽管其含义是允许任意参数类型作为一个该API函数的参数传递,但这样做存在一定的缺点。其原因是,这将会使得对目标参数的所有类型检查都会被关闭。这自然会给各种类型的参数调用带来了产生错误的机会。

为了强制执行严格的类型检查,并避免上面提到的问题,一个办法是在函数里使用上面提到到Alias技术。如对API函数 GetDIBits 可进行另外一种声明方法。如下∶
GetDIBits函数的原型∶
Public Declare Function GetDIBits Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

7 VB编程基础课
GetDIBits函数的改型∶

Public Declare Function GetDIBitsLong Lib "gdi32" Alias "GetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Long, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
通过本课程前面所学到的知识,我们已经可以得知原型 GetDIBits函数也好,改型 GetDIBitsLong函数也好,实际将调用的都是Alias所指定的 GetDIBits原函数。但你应当看到,两者的区别在于,我们在改型的函数中强制指定lpBits参数为Long形。这样就会使得函数调用中发生的错误机率减少到了最小。这种方法叫做"安全类型"声明。

API函数中经常看到的数据类型有∶Long,String,Byte,Any....(也就这些吧。)
常数 [返回]

对于API常数来讲,没有什么太特别的学问。请看VB中的以下代码∶
Msg = MsgBox("您好", vbOKCancel)
我们知道, vbOKCancel这个常数的值等于1。对上面的代码我们完全可以这样写,而不会影响代码的功能∶
Msg = MsgBox("您好", 1)
但你大概不太愿意选择后一种,因为这会使得看懂代码费劲起来。这种方法也被API采取了。只是API常数必须在事情之前做好初始化声明VB本身是看不懂的。其内容仍然来自与API
文本游览器。具体形式如下等等∶

Public Const ABM_ACTIVATE = &H6
Public Const RIGHT_CTRL_PRESSED = &H4
Public Const RPC_E_SERVER_DIED = &H80010007
Private Const RPC_S_CALL_FAILED_DNE = 1727&
在常数的初始化中,有些程序使用Global,如Global Const ABM_ACTIVATE = &H6,但我认为Public完全可以代替它。过去我也用过Global,但现在不大用了。一会儿用这个,一会儿用那个,各程序之间不能保持一致性了,起码看起来别扭。
结构 [返回]

结构是C和C++语言中的说法。在VB中一般称为自定义数据类型。想必很多朋友都已经认识它。在API领域里,我更喜欢把它叫做结构,因为API各种结构类型根本不是我定义(
自定义)的。
在VB中,API结构同样由TYPE.......END TYPE语句来定义。如,在API中,点(Point)结构的定义方法如下:
Public Type POINTAPI
X As Long '点在X坐标(横坐标)上的坐标值

Y As Long '点在Y坐标(纵坐标)上的坐标值
End Type
又如,API中矩形(Rect)结构的定义如下∶
Public Type RECT
Left As Long '矩形左上角的X坐标
Top As Long '矩形左上角的Y坐标
Right As Long '矩形右下角的X坐标
Bottom As Long '矩形右下角的Y坐标

End Type
这些内容同样可以从API文本游览器中拷贝过来。这些结构中的变量名可随意改动,而不会影响结构本身。也就是说,这些成员变量都是虚拟的。如,POINTAPI结构可改为如下∶
Public Type POINTAPI
MyX As Long '点在X坐标(横坐标)上的坐标值
MyY As Long '点在Y坐标(纵坐标)上的坐标值
End Type
不过,一般来讲,是没有这种必要的。结构本身是一种数据类型,因此,使用时必须声明具体变量为该结构型,才能在程序中真正使用到该结构。结构的声明方法和其他数据的声明方法一样,如,以下语句把变MyPoint声明为POINTAPI结构类型∶

MyPoint As POINTAPI
引用结构中的成员变量也十分简单,在结构名后面加上一个"．",然后紧接着写要引用的成员变量即可。这很象VB中的引用一个对象的某个属性。如,假如我们把上面已经声明的MyPoint结构中的X变量的值赋给变量Temp&
则代码如下∶
Temp&=MyPoint.X
但,特别注意的是,你千万不要认为上例中的MyPoint是一个值。它不是值,而是地址(
指针)。值和地址是完全不同的概念。结构要求按引用传递给WINDOWS函数,即所有API
函数中,结构都是按ByRef传递的(在Declare语句中ByRef是默认型)。对于结构的传递,你不要试图采用ByVal,你将一无所获。由于结构名实际上就是指向这个结构的指针(这个结构的首地址),所以,你也就传送特定的结构名就可以了(参见小结,我用红色字体来突出了这种传递方式)。

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

8 VB编程基础课

由于结构传送的是指针,所以函数将直接对结构进行读写操作。这种特性很适合于把函数执行的结果装载在结构之中。
小结 [返回]

以下的程序是为了总结本课中学到的内容而给出的。启动VB,新建一个项目,添加一个命令按钮,并把下面的代码拷贝到代码段中,运行它。

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI '定义点(Point)结构
X As Long '点在X坐标(横坐标)上的坐标值
Y As Long '点在Y坐标(纵坐标)上的坐标值
End Type
Sub PrintCursorPos( )
Dim dl AS Long
Dim MyPoint As POINTAPI
dl&= GetCursorPos(MyPoint) '调用函数,获取屏幕鼠标坐标

Debug.Print "X=" & Str(MyPoint.X) & " and " & "Y=" & Str(MyPoint.Y)
End Sub
Private Sub Command1_Click()
PrintCursorPos

End Sub

输出结果为(每次运行都可能得到不同的结果,这得由函数调用时鼠标指针在屏幕中所处的位置而决定)∶
X= 240 and Y= 151

程序中,GetCursorPos函数用来获取鼠标指针在屏幕上的位置。

以上例子中,你可以发现,以参数传递的MyPpint结构的内容在函数调用后发生了实质性变化。这是由于结构是按ByRef传递的原因。
一些API函数集 [返回]

Windows API

1.控件与消息函数
AdjustWindowRect 给定一种窗口样式,计算获得目标客户区矩形所需的窗口大小
AnyPopup 判断屏幕上是否存在任何弹出式窗口
ArrangeIconicWindows 排列一个父窗口的最小化子窗口
AttachThreadInput 连接线程输入函数
BeginDeferWindowPos 启动构建一系列新窗口位置的过程
BringWindowToTop 将指定的窗口带至窗口列表顶部
CascadeWindows 以层叠方式排列窗口
ChildWindowFromPoint 返回父窗口中包含了指定点的第一个子窗口的句柄

ClientToScreen 判断窗口内以客户区坐标表示的一个点的屏幕坐标
CloseWindow 最小化指定的窗口
CopyRect 矩形内容复制
DeferWindowPos 该函数为特定的窗口指定一个新窗口位置
DestroyWindow 清除指定的窗口以及它的所有子窗口
DrawAnimatedRects 描绘一系列动态矩形
EnableWindow 指定的窗口里允许或禁止所有鼠标及键盘输入
EndDeferWindowPos 同时更新DeferWindowPos调用时指定的所有窗口的位置及状态
EnumChildWindows 为指定的父窗口枚举子窗口

EnumThreadWindows 枚举与指定任务相关的窗口
EnumWindows 枚举窗口列表中的所有父窗口
EqualRect 判断两个矩形结构是否相同
FindWindow 寻找窗口列表中第一个符合指定条件的顶级窗口
FindWindowEx 在窗口列表中寻找与指定条件相符的第一个子窗口
FlashWindow 闪烁显示指定窗口
GetActiveWindow 获得活动窗口的句柄
GetCapture 获得一个窗口的句柄,这个窗口位于当前输入线程,且拥有鼠标捕获(鼠标活动由它接收)
GetClassInfo 取得WNDCLASS结构(或WNDCLASSEX结构)的一个副本,结构中包含了与指定类有关的信息

GetClassLong 取得窗口类的一个Long变量条目
GetClassName 为指定的窗口取得类名
GetClassWord 为窗口类取得一个整数变量
GetClientRect 返回指定窗口客户区矩形的大小
GetDesktopWindow 获得代表整个屏幕的一个窗口(桌面窗口)句柄
GetFocus 获得拥有输入焦点的窗口的句柄
GetForegroundWindow 获得前台窗口的句柄
GetLastActivePopup 获得在一个给定父窗口中最近激活过的弹出式窗口的句柄
GetLastError 针对之前调用的api函数,用这个函数取得扩展错误信息

GetParent 判断指定窗口的父窗口
GetTopWindow 搜索内部窗口列表,寻找隶属于指定窗口的头一个窗口的句柄
GetUpdateRect 获得一个矩形,它描叙了指定窗口中需要更新的那一部分
GetWindow 获得一个窗口的句柄,该窗口与某源窗口有特定的关系

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

9 VB编程基础课
GetWindowContextHelpId 取得与窗口关联在一起的帮助场景ID
GetWindowLong 从指定窗口的结构中取得信息
GetWindowPlacement 获得指定窗口的状态及位置信息
GetWindowRect 获得整个窗口的范围矩形,窗口的边框、标题栏、滚动条及菜单等都在这个矩形内

GetWindowText 取得一个窗体的标题(caption)文字,或者一个控件的内容
GetWindowTextLength 调查窗口标题文字或控件内容的长短
GetWindowWord 获得指定窗口结构的信息
InflateRect 增大或减小一个矩形的大小
IntersectRect 这个函数在lpDestRect里载入一个矩形,它是lpSrc1Rect与lpSrc2Rect两个矩形的交集
InvalidateRect 屏蔽一个窗口客户区的全部或部分区域
IsChild 判断一个窗口是否为另一窗口的子或隶属窗口

IsIconic 判断窗口是否已最小化
IsRectEmpty 判断一个矩形是否为空
IsWindow 判断一个窗口句柄是否有效
IsWindowEnabled 判断窗口是否处于活动状态
IsWindowUnicode 判断一个窗口是否为Unicode窗口。这意味着窗口为所有基于文本的消息都接收Unicode文字
IsWindowVisible 判断窗口是否可见
IsZoomed 判断窗口是否最大化
LockWindowUpdate 锁定指定窗口,禁止它更新
MapWindowPoints 将一个窗口客户区坐标的点转换到另一窗口的客户区坐标系统

MoveWindow 改变指定窗口的位置和大小
OffsetRect 通过应用一个指定的偏移,从而让矩形移动起来
OpenIcon 恢复一个最小化的程序,并将其激活
PtInRect 判断指定的点是否位于矩形内部
RedrawWindow 重画全部或部分窗口
ReleaseCapture 为当前的应用程序释放鼠标捕获
ScreenToClient 判断屏幕上一个指定点的客户区坐标
ScrollWindow 滚动窗口客户区的全部或一部分
ScrollWindowEx 根据附加的选项,滚动窗口客户区的全部或部分

SetActiveWindow 激活指定的窗口
SetCapture 将鼠标捕获设置到指定的窗口
SetClassLong 为窗口类设置一个Long变量条目
SetClassWord 为窗口类设置一个条目
SetFocusAPI 将输入焦点设到指定的窗口。如有必要,会激活窗口
SetForegroundWindow 将窗口设为系统的前台窗口
SetParent 指定一个窗口的新父
SetRect 设置指定矩形的内容
SetRectEmpty 将矩形设为一个空矩形
SetWindowContextHelpId 为指定的窗口设置帮助场景(上下文)ID

SetWindowLong 在窗口结构中为指定的窗口设置信息
SetWindowPlacement 设置窗口状态和位置信息
SetWindowPos 为窗口指定一个新位置和状态
SetWindowText 设置窗口的标题文字或控件的内容
SetWindowWord 在窗口结构中为指定的窗口设置信息
ShowOwnedPopups 显示或隐藏由指定窗口所有的全部弹出式窗口
ShowWindow 控制窗口的可见性
ShowWindowAsync 与ShowWindow相似
SubtractRect 装载矩形lprcDst,它是在矩形lprcSrc1中减去lprcSrc2得到的结果

TileWindows 以平铺顺序排列窗口
UnionRect 装载一个lpDestRect目标矩形,它是lpSrc1Rect和lpSrc2Rect联合起来的结果
UpdateWindow 强制立即更新窗口
ValidateRect 校验窗口的全部或部分客户区
WindowFromPoint 返回包含了指定点的窗口的句柄。忽略屏蔽、隐藏以及透明窗口

2.硬件与系统函数

ActivateKeyboardLayout 激活一个新的键盘布局。键盘布局定义了按键在一种物理性键盘上的位置与含义
Beep 用于生成简单的声音
CharToOem 将一个字串从ANSI字符集转换到OEM字符集
ClipCursor 将指针限制到指定区域
ConvertDefaultLocale 将一个特殊的地方标识符转换成真实的地方ID
CreateCaret 根据指定的信息创建一个插入符(光标),并将它选定为指定窗口的默认插入符
DestroyCaret 清除(破坏)一个插入符
EnumCalendarInfo 枚举在指定“地方”环境中可用的日历信息

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

10 VB编程基础课
EnumDateFormats 列举指定的“当地”设置中可用的长、短日期格式
EnumSystemCodePages 枚举系统中已安装或支持的代码页
EnumSystemLocales 枚举系统已经安装或提供支持的“地方”设置
EnumTimeFormats 枚举一个指定的地方适用的时间格式
ExitWindowsEx 退出windows,并用特定的选项重新启动
ExpandEnvironmentStrings 扩充环境字串
FreeEnvironmentStrings 翻译指定的环境字串块
GetACP 判断目前正在生效的ANSI代码页

GetAsyncKeyState 判断函数调用时指定虚拟键的状态
GetCaretBlinkTime 判断插入符光标的闪烁频率
GetCaretPos 判断插入符的当前位置
GetClipCursor 取得一个矩形,用于描述目前为鼠标指针规定的剪切区域
GetCommandLine 获得指向当前命令行缓冲区的一个指针
GetComputerName 取得这台计算机的名称
GetCPInfo 取得与指定代码页有关的信息
GetCurrencyFormat 针对指定的“地方”设置,根据货币格式格式化一个数字
GetCursor 获取目前选择的鼠标指针的句柄

GetCursorPos 获取鼠标指针的当前位置
GetDateFormat 针对指定的“当地”格式,对一个系统日期进行格式化
GetDoubleClickTime 判断连续两次鼠标单击之间会被处理成双击事件的间隔时间
GetEnvironmentStrings 为包含了当前环境字串设置的一个内存块分配和返回一个句柄
GetEnvironmentVariable 取得一个环境变量的值
GetInputState 判断是否存在任何待决(等待处理)的鼠标或键盘事件
GetKBCodePage 由GetOEMCP取代,两者功能完全相同
GetKeyboardLayout 取得一个句柄,描述指定应用程序的键盘布局

GetKeyboardLayoutList 获得系统适用的所有键盘布局的一个列表
GetKeyboardLayoutName 取得当前活动键盘布局的名称
GetKeyboardState 取得键盘上每个虚拟键当前的状态
GetKeyboardType 了解与正在使用的键盘有关的信息
GetKeyNameText 在给出扫描码的前提下,判断键名
GetKeyState 针对已处理过的按键,在最近一次输入信息时,判断指定虚拟键的状态
GetLastError 针对之前调用的api函数,用这个函数取得扩展错误信息
GetLocaleInfo 取得与指定“地方”有关的信息

GetLocalTime 取得本地日期和时间
GetNumberFormat 针对指定的“地方”,按特定的格式格式化一个数字
GetOEMCP 判断在OEM和ANSI字符集间转换的windows代码页
GetQueueStatus 判断应用程序消息队列中待决(等待处理)的消息类型
GetSysColor 判断指定windows显示对象的颜色
GetSystemDefaultLangID 取得系统的默认语言ID
GetSystemDefaultLCID 取得当前的默认系统“地方”
GetSystemInfo 取得与底层硬件平台有关的信息

GetSystemMetrics 返回与windows环境有关的信息
GetSystemPowerStatus 获得与当前系统电源状态有关的信息
GetSystemTime 取得当前系统时间,这个时间采用的是“协同世界时间”(即UTC,也叫做GMT)格式
GetSystemTimeAdjustment 使内部系统时钟与一个外部的时钟信号源同步
GetThreadLocale 取得当前线程的地方ID
GetTickCount 用于获取自windows启动以来经历的时间长度(毫秒)
GetTimeFormat 针对当前指定的“地方”,按特定的格式格式化一个系统时间

GetTimeZoneInformation 取得与系统时区设置有关的信息
GetUserDefaultLangID 为当前用户取得默认语言ID
GetUserDefaultLCID 取得当前用户的默认“地方”设置
GetUserName 取得当前用户的名字
GetVersion 判断当前运行的Windows和DOS版本
GetVersionEx 取得与平台和操作系统有关的版本信息
HideCaret 在指定的窗口隐藏插入符(光标)
IsValidCodePage 判断一个代码页是否有效
IsValidLocale 判断地方标识符是否有效

keybd_event 这个函数模拟了键盘行动
LoadKeyboardLayout 载入一个键盘布局

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

11 VB编程基础课
MapVirtualKey 根据指定的映射类型,执行不同的扫描码和字符转换
MapVirtualKeyEx 根据指定的映射类型,执行不同的扫描码和字符转换
MessageBeep 播放一个系统声音。系统声音的分配方案是在控制面板里决定的
mouse_event 模拟一次鼠标事件
OemKeyScan 判断OEM字符集中的一个ASCII字符的扫描码和Shift键状态
OemToChar 将OEM字符集的一个字串转换到ANSI字符集

SetCaretBlinkTime 指定插入符(光标)的闪烁频率
SetCaretPos 指定插入符的位置
SetComputerName 设置新的计算机名
SetCursor 将指定的鼠标指针设为当前指针
SetCursorPos 设置指针的位置
SetDoubleClickTime 设置连续两次鼠标单击之间能使系统认为是双击事件的间隔时间
SetEnvironmentVariable 将一个环境变量设为指定的值
SetKeyboardState 设置每个虚拟键当前在键盘上的状态
SetLocaleInfo 改变用户“地方”设置信息

SetLocalTime 设置当前地方时间
SetSysColors 设置指定窗口显示对象的颜色
SetSystemCursor 改变任何一个标准系统指针
SetSystemTime 设置当前系统时间
SetSystemTimeAdjustment 定时添加一个校准值使内部系统时钟与一个外部的时钟信号源同步
SetThreadLocale 为当前线程设置地方
SetTimeZoneInformation 设置系统时区信息
ShowCaret 在指定的窗口里显示插入符(光标)
ShowCursor 控制鼠标指针的可视性
SwapMouseButton 决定是否互换鼠标左右键的功能

SystemParametersInfo 获取和设置数量众多的windows系统参数
SystemTimeToTzSpecificLocalTime 将系统时间转换成地方时间
ToAscii 根据当前的扫描码和键盘信息,将一个虚拟键转换成ASCII字符
ToUnicode 根据当前的扫描码和键盘信息,将一个虚拟键转换成Unicode字符
UnloadKeyboardLayout 卸载指定的键盘布局
VkKeyScan 针对Windows字符集中一个ASCII字符,判断虚拟键码和Shift键的状态
完

3.菜单函数

AppendMenu 在指定的菜单里添加一个菜单项
CheckMenuItem 复选或撤消复选指定的菜单条目
CheckMenuRadioItem 指定一个菜单条目被复选成“单选”项目
CreateMenu 创建新菜单
CreatePopupMenu 创建一个空的弹出式菜单
DeleteMenu 删除指定的菜单条目
DestroyMenu 删除指定的菜单
DrawMenuBar 为指定的窗口重画菜单
EnableMenuItem 允许或禁止指定的菜单条目
GetMenu 取得窗口中一个菜单的句柄
GetMenuCheckMarkDimensions 返回一个菜单复选符的大小

GetMenuContextHelpId 取得一个菜单的帮助场景ID
GetMenuDefaultItem 判断菜单中的哪个条目是默认条目
GetMenuItemCount 返回菜单中条目(菜单项)的数量
GetMenuItemID 返回位于菜单中指定位置处的条目的菜单ID
GetMenuItemInfo 取得(接收)与一个菜单条目有关的特定信息
GetMenuItemRect 在一个矩形中装载指定菜单条目的屏幕坐标信息
GetMenuState 取得与指定菜单条目状态有关的信息
GetMenuString 取得指定菜单条目的字串
GetSubMenu 取得一个弹出式菜单的句柄,它位于菜单中指定的位置

GetSystemMenu 取得指定窗口的系统菜单的句柄
HiliteMenuItem 控制顶级菜单条目的加亮显示状态
InsertMenu 在菜单的指定位置处插入一个菜单条目,并根据需要将其他条目向下移动
InsertMenuItem 插入一个新菜单条目
IsMenu 判断指定的句柄是否为一个菜单的句柄
LoadMenu 从指定的模块或应用程序实例中载入一个菜单
LoadMenuIndirect 载入一个菜单
MenuItemFromPoint 判断哪个菜单条目包含了屏幕上一个指定的点
ModifyMenu 改变菜单条目

RemoveMenu 删除指定的菜单条目
SetMenu 设置窗口菜单
SetMenuContextHelpId 设置一个菜单的帮助场景ID
SetMenuDefaultItem 将一个菜单条目设为默认条目

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

12 VB编程基础课
SetMenuItemBitmaps 设置一幅特定位图,令其在指定的菜单条目中使用,代替标准的复选符号(√)
SetMenuItemInfo 为一个菜单条目设置指定的信息
TrackPopupMenu 在屏幕的任意地方显示一个弹出式菜单
TrackPopupMenuEx 与TrackPopupMenu相似,只是它提供了额外的功能

完

以下是几个关于菜单函数的类型定义
MENUITEMINFO 这个结构包含了菜单条目的信息
TPMPARAMS 这个结构用于TrackPopupMenuEx函数以支持额外的功能

4.绘图函数

AbortPath 抛弃选入指定设备场景中的所有路径。也取消目前正在进行的任何路径的创建工作
AngleArc 用一个连接弧画一条线
Arc 画一个圆弧
BeginPath 启动一个路径分支
CancelDC 取消另一个线程里的长时间绘图操作
Chord 画一个弦
CloseEnhMetaFile 关闭指定的增强型图元文件设备场景,并将新建的图元文件返回一个句柄
CloseFigure 描绘到一个路径时,关闭当前打开的图形
CloseMetaFile 关闭指定的图元文件设备场景,并向新建的图元文件返回一个句柄

CopyEnhMetaFile 制作指定增强型图元文件的一个副本(拷贝)
CopyMetaFile 制作指定(标准)图元文件的一个副本
CreateBrushIndirect 在一个LOGBRUSH数据结构的基础上创建一个刷子
CreateDIBPatternBrush 用一幅与设备无关的位图创建一个刷子,以便指定刷子样式(图案)
CreateEnhMetaFile 创建一个增强型的图元文件设备场景
CreateHatchBrush 创建带有阴影图案的一个刷子
CreateMetaFile 创建一个图元文件设备场景
CreatePatternBrush 用指定了刷子图案的一幅位图创建一个刷子

CreatePen 用指定的样式、宽度和颜色创建一个画笔
CreatePenIndirect 根据指定的LOGPEN结构创建一个画笔
CreateSolidBrush 用纯色创建一个刷子
DeleteEnhMetaFile 删除指定的增强型图元文件
DeleteMetaFile 删除指定的图元文件
DeleteObject 删除GDI对象,对象使用的所有系统资源都会被释放
DrawEdge 用指定的样式描绘一个矩形的边框
DrawEscape 换码(Escape)函数将数据直接发至显示设备驱动程序
DrawFocusRect 画一个焦点矩形

DrawFrameControl 描绘一个标准控件
DrawState 为一幅图象或绘图操作应用各式各样的效果
Ellipse 描绘一个椭圆,由指定的矩形围绕
EndPath 停止定义一个路径
EnumEnhMetaFile 针对一个增强型图元文件,列举其中单独的图元文件记录
EnumMetaFile 为一个标准的windows图元文件枚举单独的图元文件记录
EnumObjects 枚举可随同指定设备场景使用的画笔和刷子
ExtCreatePen 创建一个扩展画笔(装饰或几何)
ExtFloodFill 在指定的设备场景里,用当前选择的刷子填充一个区域

FillPath 关闭路径中任何打开的图形,并用当前刷子填充
FillRect 用指定的刷子填充一个矩形
FlattenPath 将一个路径中的所有曲线都转换成线段
FloodFill 用当前选定的刷子在指定的设备场景中填充一个区域
FrameRect 用指定的刷子围绕一个矩形画一个边框
GdiComment 为指定的增强型图元文件设备场景添加一条注释信息
GdiFlush 执行任何未决的绘图操作
GdiGetBatchLimit 判断有多少个GDI绘图命令位于队列中
GdiSetBatchLimit 指定有多少个GDI绘图命令能够进入队列

GetArcDirection 画圆弧的时候,判断当前采用的绘图方向
GetBkColor 取得指定设备场景当前的背景颜色
GetBkMode 针对指定的设备场景,取得当前的背景填充模式
GetBrushOrgEx 判断指定设备场景中当前选定刷子起点
GetCurrentObject 获得指定类型的当前选定对象
GetCurrentPositionEx 在指定的设备场景中取得当前的画笔位置
GetEnhMetaFile 取得磁盘文件中包含的一个增强型图元文件的图元文件句柄
GetEnhMetaFileBits 将指定的增强型图元文件复制到一个内存缓冲区里

GetEnhMetaFileDescription 返回对一个增强型图元文件的说明
GetEnhMetaFileHeader 取得增强型图元文件的图元文件头
GetEnhMetaFilePaletteEntries 取得增强型图元文件的全部或部分调色板
GetMetaFile 取得包含在一个磁盘文件中的图元文件的图元文件句柄
GetMetaFileBitsEx 将指定的图元文件复制到一个内存缓冲区
GetMiterLimit 取得设备场景的斜率限制(Miter)设置
GetNearestColor 根据设备的显示能力,取得与指定颜色最接近的一种纯色

GetObjectAPI 取得对指定对象进行说明的一个结构
GetObjectType 判断由指定句柄引用的GDI对象的类型
GetPath 取得对当前路径进行定义的一系列数据
GetPixel 在指定的设备场景中取得一个像素的RGB值
GetPolyFillMode 针对指定的设备场景,获得多边形填充模式
GetROP2 针对指定的设备场景,取得当前的绘图模式
GetStockObject 取得一个固有对象(Stock)
GetSysColorBrush 为任何一种标准系统颜色取得一个刷子

GetWinMetaFileBits 通过在一个缓冲区中填充用于标准图元文件的数据,将一个增强型图元文件转换成标准windows图元文件
InvertRect 通过反转每个像素的值,从而反转一个设备场景中指定的矩形
LineDDA 枚举指定线段中的所有点
LineTo 用当前画笔画一条线,从当前位置连到一个指定的点

作者: 61.142.212.* 2005-10-28 20:43 　回复此发言

--------------------------------------------------------------------------------

13 怎样关闭一个正在运行的程序
怎样关闭一个正在运行的程序
〖ALT键+鼠标右键开始╱暂停;鼠标左键控制速度〗
启动自动滚屏功能
你可以使用API函数FindWindow和PostMessage去寻找指定的窗口,并关闭它。下面的例子教给你怎样找到并关掉一个Caption为“Caluclator”的程序。

Dim winHwnd As Long

Dim RetVal As Long

winHwnd = FindWindow(vbNullString, "Calculator")

Debug.Print winHwnd

If winHwnd <> 0 Then

RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)

If RetVal = 0 Then

MsgBox "置入消息错误!"

End If

Else

MsgBox "Calculator没有打开!"

End If

为了让以上的代码工作,你必须在模块文件中什么以下API函数:

Declare Function FindWindow Lib "user32" Alias _

"FindWindowA" (ByVal lpClassName As String, _

ByVal lpWindowName As String) As Long

Declare Function PostMessage Lib "user32" Alias _

"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _

ByVal wParam As Long, lParam As Any) As Long

Public Const WM_CLOSE = &H10

作者: 61.142.212.* 2005-10-28 20:45 　回复此发言

--------------------------------------------------------------------------------

14 用API函数打开颜色对话框。
Option Explicit

Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

--------------
Option Explicit

Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long

Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Option Explicit

Dim rtn As String

Private Sub Cancel_Click()

Unload Me 'exit the program

End Sub

Private Sub Command2_Click()

Dim cc As ChooseColor

cc.lStructSize = Len(cc)
cc.hwndOwner = Me.hWnd
cc.hInstance = App.hInstance
cc.flags = 0
cc.lpCustColors = String$(16 * 4, 0)

rtn = ChooseColor(cc)

If rtn >= 1 Then
Colourpreview.BackColor = cc.rgbResult
Colour.Text = "Custom Colour is: " & cc.rgbResult
Else
Colour.Text = "Cancel Was Pressed"
End If

End Sub

Private Sub Form_Load()

Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2 'centre the form on the screen

'This project was downloaded from
'
'http://www.brianharper.demon.co.uk/
'
'Please use this project and all of its source code however you want.
'
'UNZIPPING
'To unzip the project files you will need a 32Bit unzipper program that
'can handle long file names. If you have a latest copy of Winzip installed
'on your system then you may use that. If you however dont have a copy,
'then visit my web site, go into the files section and from there you can
'click on the Winzip link to goto their site and download a copy of the
'program. By doing this you will now beable to unzip the project files
'retaining their proper long file names.
'Once upzipped, load up your copy of Visual Basic and goto
'File/Open Project. Locate the project files to where ever you unzipped
'them, then click Open. The project files will be loaded and are now ready
'for use.
'
'THE PROJECT
'Do you ever get sick and tired of having to attach many different OCX files
'with your finished programs, that can be sometimes about half a megabyte in
'size and can almost triple the size of distribution of your program. Instead
'of using Visual Basic's OCX for the Custom Colour Dialog, you can call the
'default Windows 95 one with only one API call to the system. This can be very
'handy indead and can help a lot if your distribution size of your program must
'be kept to a minimum.
'
'NOTES
'I have only provided the necessary project files with the zip. This keeps
'the size of the zip files down to a minimum and enables me to upload more
'prjects files to my site.
'
'I hope you find the project usful in what ever you are programming. I
'have tried to write out a small explanation of what each line of code
'does in the project, although most of it is pretty simple to understand.
'
'If you find any bugs in the code then please dont hesitate to Email me and
'I will get back to you as soon as possible. If you however need help on a
'different matter concerning Visual Basic then please please Email me as
'I like to here from people and here what they are programming.
'
'My Email address is:
'Brian@brianharper.demon.co.uk
'
'My web site is:
'http://www.brianharper.demon.co.uk/
'
'Please visit my web site and find many other useful projects like this.
'

End Sub

作者: 61.142.212.* 2005-10-28 20:57 　回复此发言

--------------------------------------------------------------------------------

15 鼠标控制演示。提供了一个鼠标控制的类,包括移动、限制、隐藏等功
Option Explicit
DefLng A-Z

Dim Cursor As cCursor

Private Sub cmdConfine_Click()

Static Confined As Boolean

If Not Confined Then
Cursor.ClipTo cmdConfine
Confined = True
Else
Cursor.ClipTo Screen
Confined = False
End If

End Sub

Private Sub cmdSnap_Click()

Cursor.SnapTo cmdVisible

End Sub

Private Sub cmdVisible_Click()

Cursor.Visible = Not Cursor.Visible

End Sub

Private Sub Form_Click()

Static Clipped As Boolean

If Not Clipped Then
Cursor.ClipTo Me
Else
Cursor.ClipTo Screen
End If
Clipped = Not Clipped

End Sub

Private Sub Form_Load()

Set Cursor = New cCursor

End Sub

Private Sub txtX_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
KeyAscii = 0
Cursor.X = Val(txtX)
End If

End Sub

Private Sub txtY_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
KeyAscii = 0
Cursor.Y = Val(txtY)
End If

End Sub
-----------------
'===============cCursor.cls===============
'Purpose: To provide quick and easy access
' to cursor functions.
'
'Functions/Subs/Properties:
' -- X (Get/Let): Sets cursor X position
' -- Y (Get/Let): Sets cursor Y position
' -- SnapTo: Puts a cursor in the center
' of a control.
' -- ClipTo: Restricts the cursor to any
' square area of movement.
'=========================================

Option Explicit
DefLng A-Z

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private CurVisible As Boolean
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ClipCursor Lib "user32" (lpRect As RECT) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Public Property Get X() As Long

Dim tmpPoint As POINTAPI
Call GetCursorPos(tmpPoint)
X = tmpPoint.X

End Property

Public Property Let X(ByVal vNewValue As Long)

Call SetCursorPos(vNewValue, Y)

End Property

Public Property Get Y() As Long

Dim tmpPoint As POINTAPI
Call GetCursorPos(tmpPoint)
Y = tmpPoint.Y

End Property

Public Property Let Y(ByVal vNewValue As Long)

Call SetCursorPos(X, vNewValue)

End Property

Public Sub SnapTo(ctl As Control)

'Snaps the cursor to the center of
'a given control.

Dim pnt As POINTAPI
Dim xx As Long
Dim yy As Long

pnt.X = pnt.Y = 0
'Get Left-Top corner of control
Call ClientToScreen(ctl.hWnd, pnt)
xx = pnt.X + (ctl.Width \ 2)
yy = pnt.Y + (ctl.Height \ 2)
'xx = pnt.X + ctl.Width / (2 * (Screen.ActiveForm.Left + ctl.Left) / pnt.X)
'yy = pnt.Y + ctl.Height / (2 * (Screen.ActiveForm.Top + ctl.Top) / pnt.Y)
Call SetCursorPos(xx, yy)

End Sub

Public Sub ClipTo(ToCtl As Object)

On Error Resume Next

Dim tmpRect As RECT
Dim pt As POINTAPI

With ToCtl

If TypeOf ToCtl Is Form Then
tmpRect.Left = (.Left \ Screen.TwipsPerPixelX)
tmpRect.Top = (.Top \ Screen.TwipsPerPixelY)
tmpRect.Right = (.Left + .Width) \ Screen.TwipsPerPixelX
tmpRect.Bottom = (.Top + .Height) \ Screen.TwipsPerPixelY
ElseIf TypeOf ToCtl Is Screen Then
tmpRect.Left = 0
tmpRect.Top = 0
tmpRect.Right = (.Width \ Screen.TwipsPerPixelX)
tmpRect.Bottom = (.Height \ Screen.TwipsPerPixelY)
Else
pt.X = 0
pt.Y = 0
Call ClientToScreen(.hWnd, pt)
tmpRect.Left = pt.X
tmpRect.Top = pt.Y
pt.X = .Width
pt.Y = .Height
Call ClientToScreen(.hWnd, pt)
tmpRect.Bottom = pt.Y
tmpRect.Right = pt.X
End If

Call ClipCursor(tmpRect)

End With

End Sub

Private Sub Class_Initialize()

CurVisible = True

End Sub

Public Property Get Visible() As Boolean

Visible = CurVisible

End Property

Public Property Let Visible(ByVal vNewValue As Boolean)

CurVisible = vNewValue
Call ShowCursor(CurVisible)

End Property

作者: 61.142.212.* 2005-10-28 21:01 　回复此发言

--------------------------------------------------------------------------------

16 读取注册表的例子,利用了API可读注册表中所有的项目。
Option Explicit
Private Sub cmdDone_Click()

End

End Sub
Private Sub cmdQuery_Click()
'* Demonstration of using sdaGetRegEntry to query
' the system registry
' Stu Alderman -- 2/30/96

Dim lngType As Long, varRetString As Variant
Dim lngI As Long, intChar As Integer

varRetString = sdaGetRegEntry(cboStartKey, _
txtRegistrationPath, txtRegistrationParameter, _
lngType)

txtResult = varRetString
txtDataType = lngType
txtDataLength = Len(varRetString)

txtHex = ""
If Len(varRetString) Then
For lngI = 1 To Len(varRetString)
intChar = Asc(Mid(varRetString, lngI, 1))
If intChar > 15 Then
txtHex = txtHex & Hex(intChar) & " "
Else
txtHex = txtHex & "0" & Hex(intChar) & " "
End If
Next lngI
End If

End Sub
Private Sub Form_Load()

cboStartKey.AddItem "HKEY_CLASSES_ROOT"
cboStartKey.AddItem "HKEY_CURRENT_CONFIG"
cboStartKey.AddItem "HKEY_CURRENT_USER"
cboStartKey.AddItem "HKEY_DYN_DATA"
cboStartKey.AddItem "HKEY_LOCAL_MACHINE"
cboStartKey.AddItem "HKEY_PERFORMANCE_DATA"
cboStartKey.AddItem "HKEY_USERS"

End Sub
----------------
Option Explicit

Public Const READ_CONTROL = &H20000
Public Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) _
And (Not SYNCHRONIZE))
Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or _
KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY _
Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) _
And (Not SYNCHRONIZE))
Public Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))

Public Const ERROR_SUCCESS = 0&

Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long

Function sdaGetRegEntry(strKey As String, _
strSubKeys As String, strValName As String, _
lngType As Long) As String
'* Demonstration of win32 API's to query
' the system registry
' Stu Alderman -- 2/30/96

On Error GoTo sdaGetRegEntry_Err

Dim lngResult As Long, lngKey As Long
Dim lngHandle As Long, lngcbData As Long
Dim strRet As String

Select Case strKey
Case "HKEY_CLASSES_ROOT": lngKey = &H80000000
Case "HKEY_CURRENT_CONFIG": lngKey = &H80000005
Case "HKEY_CURRENT_USER": lngKey = &H80000001
Case "HKEY_DYN_DATA": lngKey = &H80000006
Case "HKEY_LOCAL_MACHINE": lngKey = &H80000002
Case "HKEY_PERFORMANCE_DATA": lngKey = &H80000004
Case "HKEY_USERS": lngKey = &H80000003
Case Else: Exit Function
End Select

If Not ERROR_SUCCESS = RegOpenKeyEx(lngKey, _
strSubKeys, 0&, KEY_READ, _
lngHandle) Then Exit Function

lngResult = RegQueryValueEx(lngHandle, strValName, _
0&, lngType, ByVal strRet, lngcbData)
strRet = Space(lngcbData)
lngResult = RegQueryValueEx(lngHandle, strValName, _
0&, lngType, ByVal strRet, lngcbData)

If Not ERROR_SUCCESS = RegCloseKey(lngHandle) Then _
lngType = -1&

sdaGetRegEntry = strRet

sdaGetRegEntry_Exit:
On Error GoTo 0
Exit Function

sdaGetRegEntry_Err:
lngType = -1&
MsgBox Err & "> " & Error$, 16, _
"GenUtils/sdaGetRegEntry"
Resume sdaGetRegEntry_Exit

End Function

作者: 61.142.212.* 2005-10-28 21:03 　回复此发言

--------------------------------------------------------------------------------

17 查找/替换
Option Explicit
'Find/Replace Type Structure
Private Type FINDREPLACE
lStructSize As Long 'size of this struct 0x20
hwndOwner As Long 'handle to owner's window
hInstance As Long 'instance handle of.EXE that contains cust. dlg. template
flags As Long 'one or more of the FR_??
lpstrFindWhat As String 'ptr.to search string
lpstrReplaceWith As String 'ptr.to replace string
wFindWhatLen As Integer 'size of find buffer
wReplaceWithLen As Integer 'size of replace buffer
lCustData As Long 'data passed to hook fn.
lpfnHook As Long 'ptr.to hook fn. or NULL
lpTemplateName As String 'custom template name
End Type

'Common Dialog DLL Calls
Private Declare Function FindText Lib "comdlg32.dll" Alias "FindTextA" _
(pFindreplace As FINDREPLACE) As Long

Private Declare Function ReplaceText Lib "comdlg32.dll" Alias "ReplaceTextA" _
(pFindreplace As FINDREPLACE) As Long

'Delcaration of the type structure
Dim frText As FINDREPLACE

Private Sub cmdFind_Click()
'Call the find text function
FindText frText
End Sub

Private Sub cmdReplace_Click()
'Call the replace text function
ReplaceText frText
End Sub

Private Sub Form_Load()
'Set the Find/Replace Type properties
With frText
.lpstrReplaceWith = "Replace Text"
.lpstrFindWhat = "Find Text"
.wFindWhatLen = 9
.wReplaceWithLen = 12
.hInstance = App.hInstance
.hwndOwner = Me.hWnd
.lStructSize = LenB(frText)
End With
End Sub

作者: 61.142.212.* 2005-10-28 21:04 　回复此发言

--------------------------------------------------------------------------------

18 在任务栏中隐藏。
Private Sub Form_Load()
Dim OwnerhWnd As Integer
Dim ret As Integer

' Make sure the form is invisible:
Form1.Visible = False

' Set interval for timer for 5 seconds, and make sure it is enabled:

Timer1.Interval = 5000
Timer1.Enabled = True

' Grab the background or owner window:
OwnerhWnd = GetWindow(Me.hwnd, GW_OWNER)
' Hide from task list:
ret = ShowWindow(OwnerhWnd, SW_HIDE)

End Sub

Private Sub timer1_Timer()

Dim ret As Integer

' Display a message box:

ret = MsgBox("Visible by Alt+Tab. Cancel to Quit", 1, "Invisible Form")
' If cancel clicked, end the program:
If ret = 2 Then
Timer1.Enabled = False
Unload Me
End
End If

End Sub
---------------
' Enter each of the following Declare statements as one, single line:

#If Win16 Then
Declare Function ShowWindow Lib "User" (ByVal hwnd As Integer, ByVal nCmdShow As Integer) As Integer
Declare Function GetWindow Lib "User" (ByVal hwnd As Integer, ByVal wCmd As Integer) As Integer
#Else
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
#End If

Const SW_HIDE = 0
Const GW_OWNER = 4

作者: 61.142.212.* 2005-10-28 21:05 　回复此发言

--------------------------------------------------------------------------------

19 系统托盘System Tray。
Option Explicit

Private Const SW_SHOW = 1

Private Declare Function ShellExecute Lib _
"shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Public Sub Navigate(frm As Form, ByVal WebPageURL As String)

Dim hBrowse As Long
hBrowse = ShellExecute(frm.hwnd, "open", WebPageURL, "", "", SW_SHOW)

End Sub

Private Sub cmdOK_Click()

Unload Me

End Sub

Private Sub lbl_Click(Index As Integer)

If Index = 2 Then 'mailto link
Navigate Me, "mailto:psyborg@cyberhighway.com"
ElseIf Index = 5 Then
Navigate Me, "http://www.cyberhighway.com/~psy/"
End If

End Sub

----------------
Option Explicit
Private Sub Form_Load()

'Add the icon to the system tray...
With nfIconData
.hwnd = Me.hwnd
.uID = Me.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon.Handle
.szTip = "System Tray Example" & Chr$(0)
.cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(NIM_ADD, nfIconData)

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If frmAbout.Visible And X = 7740 Then frmAbout.Hide

Select Case X
Case 7680 'MouseMove

Case 7695 'LeftMouseDown
frmAbout.Show

Case 7710 'LeftMouseUp

Case 7725 'LeftDblClick

Case 7740 'RightMouseDown
PopupMenu mnuPopup, 0, , , mnuClose

Case 7755 'RightMouseUp

Case 7770 'RightDblClick

End Select

End Sub

Private Sub Form_Unload(Cancel As Integer)

Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
End

End Sub

Private Sub mnuAbout_Click()

frmAbout.Show

End Sub

Private Sub mnuClose_Click()

Unload Me

End Sub

---------------
Option Explicit

'Author:
' Ben Baird <psyborg@cyberhighway.com>
' Copyright © 1997, Ben Baird
'
'Purpose:
' Demonstrates setting an icon in the taskbar's
' system tray without the overhead of subclassing
' to receive events.

Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Public Const WM_MOUSEMOVE = &H200
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const MAX_TOOLTIP As Integer = 64

Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * MAX_TOOLTIP
End Type
Public nfIconData As NOTIFYICONDATA

作者: 61.142.212.* 2005-10-28 21:08 　回复此发言

--------------------------------------------------------------------------------

20 用CommonDialog公共对话框选取多个文件。
Option Explicit

Private Sub Command1_Click()

Dim DlgInfo As DlgFileInfo
Dim I As Integer

On Error GoTo ErrHandle

'清除List1中的项
List1.Clear

'选择文件
With CommonDialog1
.CancelError = True
.MaxFileSize = 32767 '被打开的文件名尺寸设置为最大,即32K
.Flags = cdlOFNHideReadOnly Or cdlOFNAllowMultiselect Or cdlOFNExplorer Or cdlOFNNoDereferenceLinks
.DialogTitle = "选择文件"
.Filter = "所有类型的文件(*.*)|*.*"
.ShowOpen
DlgInfo = GetDlgSelectFileInfo(.FileName)
.FileName = "" '在打开了*.pif文件后须将Filename属性置空,
'否则当选取多个*.pif文件后,当前路径会改变
End With

For I = 1 To DlgInfo.iCount
List1.AddItem DlgInfo.sPath & DlgInfo.sFile(I)
Next I

Exit Sub

ErrHandle:
' 按了“取消”按钮

End Sub

Private Sub Command2_Click()
End
End Sub

-------------
Option Explicit

'包含函数: GetDlgSelectFileInfo
'函数功能: 获取从CommonDialog中选取的文件信息

'自定义类型,用于DlgSelectFileInfo函数
Type DlgFileInfo
iCount As Long
sPath As String
sFile() As String
End Type

'功能: 返回CommonDialog所选择的文件数量和文件名
'参数说明: strFileName是CommonDialog.Filename
'函数类型: DlgFileInfo。这是一个自定义类型,声明如下:
' Type DlgFileInfo
' iCount As Long
' sPath As String
' sFile() As String
' End Type
' 其中,iCount为选择文件的数量,sPath为所选文件的路径,sFile()为所选择的文件名
'注意事项: 在CommonDialog.ShowOpen后立即使用,以免当前路径被更改
' 在打开了*.pif文件后须将Filename属性置空,否则当选取多个*.pif文件后,当前路径会改变会
' 在CommonDialong.Flags属性中使用cdlOFNNoDereferenceLinks风格,就可以正确的返回*.pif文件的文件名了

Public Function GetDlgSelectFileInfo(strFilename As String) As DlgFileInfo

'思路: 用CommonDialog控件选择文件后,其Filename属性值如下:
' 1、如果选择的是"C:\Test.txt", Filename="C:\Test.txt", CurDir()="C:\"
' 2、如果选择的是"C:\1\Test.txt",Filename="C:\1\Test.txt", CurDir()="C:\1"
' 3、如果选择的是"C:\1.txt"和"C:\2.txt",则:
' Filename="C:\1 1.txt 2.txt", CurDir()="C:\1"
' 因此先将路径分离开,再利用多文件之间插入的Chr$(0)字符分解各个文件名即可。

Dim sPath, tmpStr As String
Dim sFile() As String
Dim iCount As Integer
Dim I As Integer

On Error GoTo ErrHandle

sPath = CurDir() '获得当前的路径,因为在CommonDialog中改变路径时会改变当前的Path
tmpStr = Right$(strFilename, Len(strFilename) - Len(sPath)) '将文件名分离出来

If Left$(tmpStr, 1) = Chr$(0) Then
'选择了多个文件(表现为第一个字符为空格)
For I = 1 To Len(tmpStr)
If Mid$(tmpStr, I, 1) = Chr$(0) Then
iCount = iCount + 1
ReDim Preserve sFile(iCount)
Else
sFile(iCount) = sFile(iCount) & Mid$(tmpStr, I, 1)
End If
Next I
Else
'只选择了一个文件(注意:根目录下的文件名除去路径后没有"\")
iCount = 1
ReDim Preserve sFile(iCount)
If Left$(tmpStr, 1) = "\" Then tmpStr = Right$(tmpStr, Len(tmpStr) - 1)
sFile(iCount) = tmpStr
End If

GetDlgSelectFileInfo.iCount = iCount
ReDim GetDlgSelectFileInfo.sFile(iCount)

If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
GetDlgSelectFileInfo.sPath = sPath

For I = 1 To iCount
GetDlgSelectFileInfo.sFile(I) = sFile(I)
Next I

Exit Function

ErrHandle:
MsgBox "GetDlgSelectFileInfo函数执行错误!", vbOKOnly + vbCritical, "自定义函数错误"

End Function

作者: 61.142.212.* 2005-10-28 21:13 　回复此发言

--------------------------------------------------------------------------------

21 图标提取器(可提取DLL和EXE文件里的ICON)。
Private Sub Command1_Click()
Dim l1 As Long

IconPosX = 0: IconPosY = 0
l1 = IconMoudle
If l1 Then
Me.Picture1.Cls
Me.Picture2.Cls
For i = 0 To IconMax
IconCounter(i) = 0
Next i
IconMax = 0
If EnumResourceNames(l1, RT_ICON, AddressOf EnumResProc, 3&) Then
End If
End If

End Sub

Private Sub COpen_Click()
If FreeLibrary(IconMoudle) Then
End If
IconMoudle = 0
CommonDialog1.ShowOpen

Form1.Picture1.Cls
Form1.Picture2.Cls
lCount = ExtractIcon(App.hInstance, CommonDialog1.FileName, -1)
If lCount > 0 Then
IconMoudle = LoadLibraryEx(CommonDialog1.FileName, 0&, 2&)
Else
If CommonDialog1.FileName <> "" Then
X1 = MsgBox("这个文件没有包含图标资源")
End If
End If
Command1_Click
End Sub

Private Sub Form_Click()
Dim l As Long
Dim LG1 As Long
Dim xt As myType
Dim lTemp As Long
Dim apIcon As ICONINFO

LG1 = OleGetIconOfFile("c:\windows\system\ole32.dll", 0&)
Debug.Print LG1, GlobalSize(LG1)
Call CopyMemory(xt.astr(0), LG1, Len(xt))
lTemp = CreateIconFromResource(xt.astr(0), 1000, 1, &H30000)
Debug.Print lTemp
If GetIconInfo(lTemp, apIcon) Then
Debug.Print lTemp
lTemp = CreateIconIndirect(apIcon)
End If
Form1.Picture1.Cls
If DrawIcon(Form1.Picture1.hdc, 0&, 0&, lTemp) Then
End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim l As Long
Dim l1 As Long

If Button = vbKeyRButton Then
l = (X \ Screen.TwipsPerPixelX) \ 32
l1 = (Y \ Screen.TwipsPerPixelY) \ 32
lIconCount = l1 * MaxOneLine + l
If lIconCount < IconMax Then
PopupMenu Form2.m_Main
End If
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If FreeLibrary(IconMoudle) Then
End If
End
End Sub

Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim l As Long
Dim l1 As Long

If Button = vbKeyRButton Then
l = (X \ Screen.TwipsPerPixelX) \ 32
l1 = (Y \ Screen.TwipsPerPixelY) \ 32
lIconCount = l1 * MaxOneLine + l
If lIconCount < IconMax Then
PopupMenu Form2.m_Main
End If
End If
End Sub

Private Sub Picture2_Paint()
Command1_Click
End Sub

Private Sub VScroll1_Change()
Picture2.Top = 0 - (VScroll1.Value * 32 * Screen.TwipsPerPixelY)
VScroll1.Top = 0 + VScroll1.Value * 32 * Screen.TwipsPerPixelY
Command1_Click
End Sub
-----------
Private Sub m_Save_Click()
'Debug.Print IconCounter(lIconCount)
If ExtIconFromMoudle(IconMoudle, IconCounter(lIconCount)) Then
Form1.Left = Form1.Left
End If
End Sub
-------------
Type myType
astr(755) As Byte
End Type

Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type

Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Any, phiconSmall As Any, ByVal nIcons As Long) As Long

作者: 61.142.212.* 2005-10-28 21:15 　回复此发言

--------------------------------------------------------------------------------

22 图标提取器(可提取DLL和EXE文件里的ICON)。

Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Declare Function GetLastError Lib "kernel32" () As Long

Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long

Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long

Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As Any, ByVal cbCopy As Long)

Declare Function EnumResourceNames Lib "kernel32" Alias "EnumResourceNamesA" (ByVal hModule As Long, ByVal lpType As Any, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function FindResource Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As Any, ByVal lpType As Any) As Long
Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Declare Function FreeResource Lib "kernel32" (ByVal hResData As Long) As Long
Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Any) As Long
Declare Function CreateIconFromResource Lib "user32" _
(presbits As Byte, ByVal dwResSize As _
Long, ByVal fIcon As Long, ByVal dwVer _

作者: 61.142.212.* 2005-10-28 21:15 　回复此发言

--------------------------------------------------------------------------------

23 图标提取器(可提取DLL和EXE文件里的ICON)。
As Long) As Long
Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long

Declare Function CoLoadLibrary Lib "ole32.dll" _
(lpszLibName As String, ByVal bAutoFree _
As Long) As Long
Declare Sub CoFreeLibrary Lib "ole32.dll" (ByVal hInst As Long)
Declare Function OleGetIconOfFile Lib "ole32.dll" _
(lpszPath As String, ByVal fUseFileAsLabel As Long) _
As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As _
Long) As Long

Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_ZEROINIT = &H40

Public Const GENERIC_READ = &H80000000
Public Const GENERIC_WRITE = &H40000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const CREATE_ALWAYS = 2
Public Const CREATE_NEW = 1
Public Const SRCCOPY = &HCC0020
Public Const OPEN_EXISTING = 3
Public Const OPEN_ALWAYS = 4
Public Const WM_SETICON = &H80

Public Const RT_ICON = 3&

Global lNum As Long
Global lCount As Long
Global astr As String
Global X1 As Long
Global IconPosX As Long
Global IconPosY As Long
Global m_Memory As Long

Global IconCounter(200) As Integer
Global IconMax As Integer
Global IconMoudle As Long
Global MaxOneLine As Long
Global lIconCount As Long
Function ExtIconFromMoudle(ByVal hMoudle As Long, ByVal lName As Long) As Boolean
Dim lRes As Long
Dim lGlobal As Long
Dim LG1 As Long
Dim xt As myType
Dim lTemp As Long
Dim lSize As Long
Dim apIcon As ICONINFO
Dim astr As String
Dim lFile As Long
Dim ab As Byte

lRes = FindResource(hMoudle, lName, 3&)
lSize = SizeofResource(hMoudle, lRes)
lGlobal = LoadResource(hMoudle, lRes)
LG1 = LockResource(lGlobal)
Call CopyMemory(xt.astr(0), LG1, Len(xt))
lTemp = CreateIconFromResource(xt.astr(0), lSize, 1, &H30000)
If GetIconInfo(lTemp, apIcon) Then
lTemp = CreateIconIndirect(apIcon)
End If
Form1.Picture1.Cls
If DrawIcon(Form1.Picture1.hdc, 0&, 0&, lTemp) Then
Form1.CommonDialog2.ShowSave
If Form1.CommonDialog2.FileName = "" Then
Exit Function
End If
astr = Form1.CommonDialog2.FileName
lFile = FreeFile
Open astr For Binary As lFile
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 1
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 1
Put lFile, , ab
ab = 0
Put lFile, , ab
If lSize >= 744 Then
ab = 32
Put lFile, , ab
Put lFile, , ab
Else
ab = 16
Put lFile, , ab
Put lFile, , ab
End If
ab = 16
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = lSize And 255
Put lFile, , ab
ab = lSize \ 256
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 22
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
ab = 0
Put lFile, , ab
For i = 0 To lSize - 1
Put lFile, , xt.astr(i)
Next i
Close lFile
End If
End Function

Function EnumResProc(ByVal hMoudle As Long, _
ByVal lpszType As Long, ByVal lpszName _
As Long, ByVal lParam As Long) As Long
Dim lRes As Long
Dim lGlobal As Long
Dim LG1 As Long
Dim xt As myType
Dim lTemp As Long
Dim lSize As Long
Dim apIcon As ICONINFO

IconCounter(IconMax) = lpszName
IconMax = IconMax + 1
lRes = FindResource(hMoudle, lpszName, lpszType)

lSize = SizeofResource(hMoudle, lRes)
lGlobal = LoadResource(hMoudle, lRes)
LG1 = LockResource(lGlobal)
If FreeResource(lGlobal) Then
End If
Call CopyMemory(xt.astr(0), LG1, Len(xt))

lTemp = CreateIconFromResource(xt.astr(0), lSize, 1, &H30000)

If GetIconInfo(lTemp, apIcon) Then
lTemp = CreateIconIndirect(apIcon)
End If
If DrawIcon(Form1.Picture2.hdc, IconPosX, IconPosY, lTemp) Then
If (IconPosX + 96) * Screen.TwipsPerPixelX > Form1.Picture2.ScaleWidth Then
IconPosX = 0
IconPosY = IconPosY + 32
If IconPosY > Form1.Picture2.ScaleHeight \ Screen.TwipsPerPixelY Then
Form1.Picture2.Height = Form1.Picture2.Height + (32 * Screen.TwipsPerPixelY)
Form1.VScroll1.Max = Form1.VScroll1 + 1
End If
If MaxOneLine = 0 Then
MaxOneLine = IconMax
End If
Else
IconPosX = IconPosX + 32
End If
End If
EnumResProc = True
End Function

作者: 61.142.212.* 2005-10-28 21:15 　回复此发言

--------------------------------------------------------------------------------

24 使用调用外部程序函数实现API函数高级功能。
Private Sub Command1_Click()
Shell "rundll.exe user.exe,exitwindows", vbHide '关闭
End Sub

Private Sub Command2_Click()
Shell "rundll.exe user.exe,exitwindowsexec", vbHide '重新启动
End Sub

Private Sub Command3_Click()
Dim FiletoOpen$
FiletoOpen = "system.ini"
Shell "Start.exe " & FiletoOpen, vbHide

End Sub

Private Sub Command4_Click()
Dim PathtoOpen$
PathtoOpen = "c:\my documents"
Shell "explorer.exe " & PathtoOpen, vbNormalFocus
End Sub

Private Sub Command5_Click()

If Dir$("c:\mydos", vbDirectory) = "" Then MkDir "c:\mydos"
Shell "xcopy.exe c:\windows\command\*.* c:\mydos/s/e", vbHide
Shell "explorer.exe " & "c:\mydos", vbNormalFocus

End Sub

Private Sub Command6_Click()

Open "c:\test.bat" For Output As #1 '建立批处理文件
Print #1, "copy/?>c:\copyhelp.txt"
Print #1, "@exit"
'auto exit when finished :batch file
Close #1
Shell "c:\test.bat", vbHide
Shell "start.exe c:\copyhelp.txt", vbHide
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label7.ForeColor = vbBlack
Label8.ForeColor = vbBlack
End Sub

Private Sub Label7_Click()
Shell "start.exe mailto:nwdonkey@371.net", vbHide
End Sub

Private Sub Label7_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label7.ForeColor = vbRed
End Sub

Private Sub Label8_Click()
Shell "start.exe http://nwdonkey.uhome.net", vbHide
End Sub

Private Sub Label8_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label8.ForeColor = vbRed
End Sub

作者: 61.142.212.* 2005-10-28 21:16 　回复此发言

--------------------------------------------------------------------------------

25 拖动没有标题栏的窗体。
Option Explicit

Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Sub Form_Load()
MsgBox "拖动没有标题栏的窗体"
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Dim ReturnVal As Long
X = ReleaseCapture()
ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub

作者: 61.142.212.* 2005-10-28 21:17 　回复此发言

--------------------------------------------------------------------------------

26 自动完成字符串填写功能(像IE的地址栏自动完成地址输入)。
Option Explicit

'Windows declarations
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const CB_FINDSTRING = &H14C
Private Const CB_ERR = (-1)

'Declarations for alternate code (see comments below)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_SETCURSEL = &H14E

'Private flag
Private m_bEditFromCode As Boolean

Private Sub Form_Load()
Dim sSysDir As String, sFile As String

'Get files from system directory for test list
Screen.MousePointer = vbHourglass
sSysDir = Space$(256)
GetSystemDirectory sSysDir, Len(sSysDir)
sSysDir = Left$(sSysDir, InStr(sSysDir, Chr$(0)) - 1)
If Right$(sSysDir, 1) <> "\" Then
sSysDir = sSysDir & "\"
End If
sFile = Dir$(sSysDir & "*.*")
Do While Len(sFile)
Combo1.AddItem sFile
sFile = Dir$
Loop
Screen.MousePointer = vbDefault
End Sub

'Certain keystrokes must be handled differently by the Change
'event, so set m_bEditFromCode flag if such a key is detected
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyDelete
m_bEditFromCode = True
Case vbKeyBack
m_bEditFromCode = True
End Select
End Sub

Private Sub Combo1_Change()
Dim i As Long, j As Long
Dim strPartial As String, strTotal As String

'Prevent processing as a result of changes from code
If m_bEditFromCode Then
m_bEditFromCode = False
Exit Sub
End If
With Combo1
'Lookup list item matching text so far
strPartial = .Text
i = SendMessage(.hwnd, CB_FINDSTRING, -1, ByVal strPartial)
'If match found, append unmatched characters
If i <> CB_ERR Then
'Get full text of matching list item
strTotal = .List(i)
'Compute number of unmatched characters
j = Len(strTotal) - Len(strPartial)
'
If j <> 0 Then
'Append unmatched characters to string
m_bEditFromCode = True
.SelText = Right$(strTotal, j)
'Select unmatched characters
.SelStart = Len(strPartial)
.SelLength = j
Else

'*** Text box string exactly matches list item ***

'Note: The ListIndex is still -1. If you want to
'force the ListIndex to the matching item in the
'list, uncomment the following line. Note that
'PostMessage is required because Windows sets the
'ListIndex back to -1 once the Change event returns.
'Also note that the following line causes Windows to
'select the entire text, which interferes if the
'user wants to type additional characters.
' PostMessage Combo1.hwnd, CB_SETCURSEL, i, 0
End If
End If
End With
End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

作者: 61.142.212.* 2005-10-28 21:18 　回复此发言

--------------------------------------------------------------------------------

27 在任务条Tray右边出现动画图标。
Option Explicit

Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
ucallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Dim t As NOTIFYICONDATA

Private Sub Form_Load()
t.cbSize = Len(t)
t.hWnd = Picture1(0).hWnd
t.uId = 1&
t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
t.ucallbackMessage = WM_MOUSEMOVE
t.hIcon = Picture1(0).Picture
t.szTip = "Shell_NotifyIcon ..." & Chr$(0)
Shell_NotifyIcon NIM_ADD, t
Timer1.Enabled = True
Me.Hide
App.TaskVisible = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Timer1.Enabled = False
t.cbSize = Len(t)
t.hWnd = Picture1(0).hWnd
t.uId = 1&
Shell_NotifyIcon NIM_DELETE, t
End Sub

Private Sub Menu_Click(Index As Integer)
Unload Me
End Sub

Private Sub picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Hex(X) = "1E3C" Then
Me.PopupMenu xx
End If
End Sub

Private Sub timer1_Timer()
Static i As Long, img As Long
t.cbSize = Len(t)
t.hWnd = Picture1(0).hWnd
t.uId = 1&
t.uFlags = NIF_ICON
t.hIcon = Picture1(i).Picture
Shell_NotifyIcon NIM_MODIFY, t
Timer1.Enabled = True
i = i + 1
If i = 2 Then i = 0
End Sub

作者: 61.142.212.* 2005-10-28 21:20 　回复此发言

--------------------------------------------------------------------------------

28 支持从文件浏览器里拖入文件。
Private Sub Command1_Click()

' You can turn the form's / controls ability
' to accept the files by passing the hWnd as
' the first parameter and Ture/False as the
' Second

If Command1.Caption = "&Accept Files" Then
' allow the application to accept files
DragAcceptFiles Form1.hWnd, True
Command1.Caption = "&Do Not Accept"
Else
DragAcceptFiles Form1.hWnd, False
Command1.Caption = "&Accept Files"
End If
End Sub

Private Sub Command2_Click()
' Clears the contents of the list box
List1.Clear
End Sub

Private Sub Command3_Click()
' End the program
End
End Sub

Private Sub Form_Load()
DragAcceptFiles Form1.hWnd, True
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

--------------
' Written, Tested and Debugged by :
'
' Joseph J Guadagno
' 7 East Court
' Bethpage, NY USA 11714-2210

' Phone :516-681-7809
' Fax :516-681-7809

' Email :TheJammer@msn.com
' Cserve :75122,2307
' AOL :JoeJams
' Prodigy :KJFG12A

' Types Required ----------------------------------
Type POINTAPI
x As Long
y As Long
End Type

Type MSG
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
' End Types Required-------------------------------

' Declares

Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hWnd As Long, ByVal fAccept As Long)
Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long

' Constants
Public Const PM_NOREMOVE = &H0
Public Const PM_NOYIELD = &H2
Public Const PM_REMOVE = &H1
Public Const WM_DROPFILES = &H233

Sub Main()
' In order for this to function properly you should place of of your program
' execution code in the Sub Main(), Make sure you change the project startup
' to sub Main

Form1.Show

' This must be the last line! Nothing gets called after this
WatchForFiles

End Sub

Public Sub WatchForFiles()
' This subrountine watchs for all of your WM_DROPFILES messages

' Dim Variables
Dim FileDropMessage As MSG ' Msg Type
Dim fileDropped As Boolean ' True if Files where dropped
Dim hDrop As Long ' Pointer to the dropped file structure
Dim filename As String * 128 ' the dropped filename
Dim numOfDroppedFiles As Long ' the amount of dropped files
Dim curFile As Long ' the current file number

' loop to keep checking for files
' NOTE : Do any code you want to execute before this set

Do
' check for Dropped file messages
fileDropped = PeekMessage(FileDropMessage, 0, WM_DROPFILES, WM_DROPFILES, PM_REMOVE Or PM_NOYIELD)

If fileDropped Then

' Get the pointer to the dropped file structure
hDrop = FileDropMessage.wParam

' Get the toal number of files
numOfDroppedFiles = DragQueryFile(hDrop, True, filename, 127)
For curFile = 1 To numOfDroppedFiles
' Get the file name
ret% = DragQueryFile(hDrop, curFile - 1, filename, 127)

' at this pointer you can do what you want with the filename
' the filename will be a full qalified path

Form1.lblNumDropped = LTrim$(Str$(numOfDroppedFiles))
Form1.List1.AddItem filename

Next curFile

' We are now done with the structure, tell windows to discard it

DragFinish (hDrop)
End If

' Be nice and DoEvents
DoEvents
Loop

End Sub

作者: 61.142.212.* 2005-10-28 21:21 　回复此发言

--------------------------------------------------------------------------------

29 欢迎Splash窗体。
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Sub Form_Load()
Me.WindowState = 0
'
'显示在桌面最顶层
'
Call Fun_AlwaysOnTop(frmSplash, True)

frmSplash.Show
frmSplash.Refresh

frmWelcome.Show

frmWelcome.Refresh
'******************
'函数:延时2秒运行
Fun_SleepTest 2
'******************

frmSplash.Hide: Unload frmSplash

End Sub

'-------------------------------------
'函数:显示在桌面最顶层(True是/False否)
'-------------------------------------
Private Function Fun_AlwaysOnTop(frmForm As Form, fOnTop As Boolean)
Dim lState As Long
Const Hwnd_TopMost = -1
Const Hwnd_NoTopMost = -2

If fOnTop = True Then
lState = Hwnd_TopMost
Else
lState = Hwnd_NoTopMost
End If

'声明变量
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer

With frmForm
iLeft = .Left / Screen.TwipsPerPixelX
iTop = .Top / Screen.TwipsPerPixelY
iWidth = .Width / Screen.TwipsPerPixelX
iHeight = .Height / Screen.TwipsPerPixelY
End With

Call SetWindowPos(frmForm.hwnd, lState, iLeft, iTop, iWidth, iHeight, 1)
End Function

'----------------
'函数:延时运行
'----------------
Public Function Fun_SleepTest(X As Integer)
Dim StarTime As Single
StarTime = Timer
Do Until (Timer - StarTime) > X
' DoEvents$ '转让控制权,以便让操作系统
Loop
End Function

-------------
Private Sub Command1_Click()
MsgBox "Welcome to VB编程乐园"
End Sub

作者: 61.142.212.* 2005-10-28 21:22 　回复此发言

--------------------------------------------------------------------------------

30 针式石英钟例子。
Option Explicit

DefDbl A-Z

Private Sub Form_Load()
Timer1.Interval = 100
Width = 4000
Height = 4000
Left = Screen.Width \ 2 - 2000
Top = (Screen.Height - Height) \ 2
End Sub

Private Sub Form_Resize()
Dim I, Angle
Static flag As Boolean

If flag = False Then
flag = True
For I = 0 To 14
If I > 0 Then Load Line1(I)
Line1(I).Visible = True
Line1(I).BorderWidth = 5
Line1(I).BorderColor = RGB(200, 100, 60)
Next I
End If
For I = 0 To 14
Scale (-1, 1)-(1, -1)
Angle = I * 2 * Atn(1) / 3
Line1(I).X1 = 0.9 * Cos(Angle)
Line1(I).Y1 = 0.9 * Sin(Angle)
Line1(I).X2 = Cos(Angle)
Line1(I).Y2 = Sin(Angle)
Next I

End Sub

Private Sub Timer1_Timer()
Const HH = 0
Const MH = 13
Const SH = 14
Dim Angle
Static LS
If Second(Now) = LS Then Exit Sub
LS = Second(Now)
Angle = 0.5236 * (15 - (Hour(Now) + Minute(Now) / 60))
Line1(HH).X1 = 0
Line1(HH).Y1 = 0
Line1(HH).X2 = 0.3 * Cos(Angle)
Line1(HH).Y2 = 0.3 * Sin(Angle)
Angle = 0.1047 * (75 - (Minute(Now) + Second(Now) / 60))
Line1(MH).X1 = 0
Line1(MH).Y1 = 0
Line1(MH).X2 = 0.7 * Cos(Angle)
Line1(MH).Y2 = 0.7 * Sin(Angle)
Angle = 0.5236 * (75 - Second(Now) / 5)
Line1(SH).X1 = 0
Line1(SH).Y1 = 0
Line1(SH).X2 = 0.8 * Cos(Angle)
Line1(SH).Y2 = 0.8 * Sin(Angle)
Form1.Caption = Str(Now())

End Sub

作者: 61.142.212.* 2005-10-28 21:23 　回复此发言

--------------------------------------------------------------------------------

31 看惯了微软那种老气横秋的按纽,这里教你如何改变按纽的前景色。
Option Explicit

Private Sub Form_Load()

'Initialize each button color.
SetButton Command1.hWnd, vbRed
SetButton Command2.hWnd, &H8000& 'Darker green
'Assign this one a DT_BOTTOM alignment because
'it has a picture.
SetButton Command3.hWnd, vbBlue, DT_BOTTOM
SetButton Command4.hWnd, &H800000 'Darker brownish-yellow

End Sub

Private Sub Form_Unload(Cancel As Integer)

'Unhook CommandButtons manually -
'Note that this is not really necessary,
'but you can do this to remove the
'text coloring effect at any time.
RemoveButton Command1.hWnd
RemoveButton Command2.hWnd
RemoveButton Command3.hWnd
RemoveButton Command4.hWnd

End Sub

----------
Option Explicit

'==================================================================
' modExtButton.bas
' From Visual Basic Thunder, www.vbthunder.com
'
' This module provides an easy way to change the text color
' of a VB CommandButton control. To use the code with a
' CommandButton, you should:
'
' - Set the button's Style property to "Graphical" at
' design time.
'
' - Optionally set its BackColor and Picture properties.
'
' - Call SetButton in the Form_Load event:
' SetButton Command1.hWnd, vbBlue
' (You can do this multiple times during your program's
' execution, even without calling RemoveButton.)
'
' - Call RemoveButton in the Form_Unload event:
' RemoveButton Command1.hWnd
'
'==================================================================

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function GetParent Lib "user32" _
(ByVal hWnd 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 Const GWL_WNDPROC = (-4)

Private Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hWnd As Long, ByVal lpString As String, _
ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias _
"RemovePropA" (ByVal hWnd As Long, _
ByVal lpString As String) As Long

Private Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

'Owner draw constants
Private Const ODT_BUTTON = 4
Private Const ODS_SELECTED = &H1
'Window messages we're using
Private Const WM_DESTROY = &H2
Private Const WM_DRAWITEM = &H2B

Private Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hDC As Long

作者: 61.142.212.* 2005-10-28 21:24 　回复此发言

--------------------------------------------------------------------------------

32 看惯了微软那种老气横秋的按纽,这里教你如何改变按纽的前景色。
rcItem As RECT
itemData As Long
End Type

Private Declare Function GetWindowText Lib "user32" Alias _
"GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long
'Various GDI painting-related functions
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _
ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, _
ByVal nBkMode As Long) As Long
Private Const TRANSPARENT = 1

Private Const DT_CENTER = &H1
Public Enum TextVAligns
DT_VCENTER = &H4
DT_BOTTOM = &H8
End Enum
Private Const DT_SINGLELINE = &H20

Private Sub DrawButton(ByVal hWnd As Long, ByVal hDC As Long, _
rct As RECT, ByVal nState As Long)

Dim s As String
Dim va As TextVAligns

va = GetProp(hWnd, "VBTVAlign")

'Prepare DC for drawing
SetBkMode hDC, TRANSPARENT
SetTextColor hDC, GetProp(hWnd, "VBTForeColor")

'Prepare a text buffer
s = String$(255, 0)
'What should we print on the button?
GetWindowText hWnd, s, 255
'Trim off nulls
s = Left$(s, InStr(s, Chr$(0)) - 1)

If va = DT_BOTTOM Then
'Adjust specially for VB's CommandButton control
rct.Bottom = rct.Bottom - 4
End If

If (nState And ODS_SELECTED) = ODS_SELECTED Then
'Button is in down state - offset
'the text
rct.Left = rct.Left + 1
rct.Right = rct.Right + 1
rct.Bottom = rct.Bottom + 1
rct.Top = rct.Top + 1
End If

DrawText hDC, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE _
Or va

End Sub

Public Function ExtButtonProc(ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Dim lOldProc As Long
Dim di As DRAWITEMSTRUCT

lOldProc = GetProp(hWnd, "ExtBtnProc")

ExtButtonProc = CallWindowProc(lOldProc, hWnd, wMsg, wParam, lParam)

If wMsg = WM_DRAWITEM Then
CopyMemory di, ByVal lParam, Len(di)
If di.CtlType = ODT_BUTTON Then
If GetProp(di.hwndItem, "VBTCustom") = 1 Then
DrawButton di.hwndItem, di.hDC, di.rcItem, _
di.itemState

End If

ElseIf wMsg = WM_DESTROY Then
ExtButtonUnSubclass hWnd

End If

End Function

Public Sub ExtButtonSubclass(hWndForm As Long)

Dim l As Long

l = GetProp(hWndForm, "ExtBtnProc")
If l <> 0 Then
'Already subclassed
Exit Sub
End If

SetProp hWndForm, "ExtBtnProc", _
GetWindowLong(hWndForm, GWL_WNDPROC)
SetWindowLong hWndForm, GWL_WNDPROC, AddressOf ExtButtonProc

End Sub

Public Sub ExtButtonUnSubclass(hWndForm As Long)

Dim l As Long

l = GetProp(hWndForm, "ExtBtnProc")
If l = 0 Then
'Isn't subclassed
Exit Sub
End If

SetWindowLong hWndForm, GWL_WNDPROC, l
RemoveProp hWndForm, "ExtBtnProc"

End Sub

Public Sub SetButton(ByVal hWnd As Long, _
ByVal lForeColor As Long, _
Optional ByVal VAlign As TextVAligns = DT_VCENTER)

Dim hWndParent As Long

hWndParent = GetParent(hWnd)
If GetProp(hWndParent, "ExtBtnProc") = 0 Then
ExtButtonSubclass hWndParent
End If

SetProp hWnd, "VBTCustom", 1
SetProp hWnd, "VBTForeColor", lForeColor
SetProp hWnd, "VBTVAlign", VAlign

End Sub

Public Sub RemoveButton(ByVal hWnd As Long)

RemoveProp hWnd, "VBTCustom"
RemoveProp hWnd, "VBTForeColor"
RemoveProp hWnd, "VBTVAlign"

End Sub

作者: 61.142.212.* 2005-10-28 21:24 　回复此发言

--------------------------------------------------------------------------------

33 调色板应用例子(会把你设定的颜色放到格子里)
Option Explicit
Const DEFAULT_PALETTE As Integer = 15
Const BLACK_BRUSH As Integer = 4
Const PC_RESERVED As Integer = &H1&

Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type

Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(256) As PALETTEENTRY
End Type

Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function SetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function AnimatePalette Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteColors As PALETTEENTRY) As Long

Dim hSystemPalette As Long
Dim hCurrentPalette As Long
Dim Block As Long
Dim ColorSelected As Integer
Dim SelectingColor As Boolean

Private Sub ColorChange(index As Integer)
'修改颜色设置
Dim Dummy As Long
Dim NewPaletteEntry As PALETTEENTRY

If ColorSelected > -1 Then
NewPaletteEntry.peRed = Colour(0).Value
NewPaletteEntry.peGreen = Colour(1).Value
NewPaletteEntry.peBlue = Colour(2).Value
NewPaletteEntry.peFlags = PC_RESERVED

Dummy = AnimatePalette(hCurrentPalette, ColorSelected, 1, NewPaletteEntry)

'修改Pic2中的颜色
Pic2_Paint
End If
End Sub

Private Sub Colour_GotFocus(index As Integer)
SelectingColor = False
End Sub

Private Sub Colour_Scroll(index As Integer)
'颜色滚动条滚动
If Not SelectingColor Then
Call ColorChange(index)
End If

Label2(index).Caption = Right(Str(Colour(index).Value), 3)
ChangeColor index
End Sub

Private Sub Colour_Change(index As Integer)
'颜色滚动条数值变化
If Not SelectingColor Then
Call ColorChange(index)

'修改Pic1中的颜色
Call PaintSubBlock
End If

Label2(index).Caption = Right(Str(Colour(index).Value), 3)
ChangeColor index
End Sub

Private Sub Form_Load()
Dim LogicalPalette As LOGPALETTE
Dim ColorIndex As Integer
Dim r As Integer, g As Integer, b As Integer
Dim i As Integer, j As Integer

Block = 16 '每行16块
ColorSelected = -1 '未选择颜色

作者: 61.142.212.* 2005-10-28 21:25 　回复此发言

--------------------------------------------------------------------------------

34 调色板应用例子(会把你设定的颜色放到格子里)

'设置自定义调色板值
LogicalPalette.palVersion = &H300
LogicalPalette.palNumEntries = 256
'设置调色板颜色值
For i = 0 To 15
For j = 0 To 15
LogicalPalette.palPalEntry(i * 16 + j).peRed = i * 17
LogicalPalette.palPalEntry(i * 16 + j).peGreen = j * 17
LogicalPalette.palPalEntry(i * 16 + j).peBlue = i * j / (i + j + 0.01) * 34
LogicalPalette.palPalEntry(i * 16 + j).peFlags = PC_RESERVED
Next j, i

'创建调色板
hCurrentPalette = CreatePalette(LogicalPalette)
Call Pic1_Paint '绘显示区
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim Dummy As Integer
Dim hSystemPalette As Long
Dim hDummyPalette As Long

hSystemPalette = GetStockObject(DEFAULT_PALETTE) '取得系统缺省调色板
hDummyPalette = SelectPalette(Pic1.hdc, hSystemPalette, 0) '恢复缺省调色板
hDummyPalette = SelectPalette(Pic2.hdc, hSystemPalette, 0)
Dummy = DeleteObject(hCurrentPalette) '删除自定义调色板
End Sub

Private Sub Pic1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim BoxHeight As Integer
Dim BoxWidth As Integer
Dim Row As Integer
Dim Column As Integer
Dim Dummy As Integer
Dim CurrentPaletteEntry As PALETTEENTRY

'设置选择颜色标志
SelectingColor = True

BoxHeight = Pic1.ScaleHeight \ Block
BoxWidth = Pic1.ScaleWidth \ Block

Row = Y \ BoxHeight
Column = X \ BoxWidth

If Row < Block And Column < Block Then
'选择了颜色块
ColorSelected = Row * Block + Column
Dummy = GetPaletteEntries(hCurrentPalette, ColorSelected, 1, _
CurrentPaletteEntry)
Colour(0).Value = CurrentPaletteEntry.peRed
Colour(1).Value = CurrentPaletteEntry.peGreen
Colour(2).Value = CurrentPaletteEntry.peBlue

Pic1_Paint '重绘颜色显示
Pic2_Paint
End If
End Sub

Private Sub Pic1_Paint()
Dim Row As Integer
Dim Column As Integer
Dim BoxHeight As Integer
Dim BoxWidth As Integer
Dim Color As Long
Dim ColorIndex As Long
Dim hBrush As Long
Dim Dummy As Integer

'应用自定义调色板
hSystemPalette = SelectPalette(Pic1.hdc, hCurrentPalette, 0)
Dummy = RealizePalette(Pic1.hdc) '确认调色板

'计算各颜色块大小
BoxWidth = Pic1.ScaleWidth \ Block
BoxHeight = Pic1.ScaleHeight \ Block

'绘制各颜色块
For ColorIndex = 0 To Block * Block - 1
Row = ColorIndex \ Block + 1 '计算行位置(从1开始)
Column = ColorIndex Mod Block + 1 '计算列位置
hBrush = CreateSolidBrush(&H1000000 Or ColorIndex) '以指定调色板创建画刷
Dummy = SelectObject(Pic1.hdc, hBrush) '应用画刷
Dummy = Rectangle(Pic1.hdc, (Column - 1) * BoxWidth, (Row - 1) * BoxHeight, _
Column * BoxWidth, Row * BoxHeight) '绘制矩形
Dummy = SelectObject(Pic1.hdc, GetStockObject(BLACK_BRUSH)) '恢复缺省画刷
Dummy = DeleteObject(hBrush) '删除自创建画刷
Next ColorIndex

'绘制突出显示颜色块
PaintSubBlock
End Sub

Private Sub PaintSubBlock()
'该函数用于绘制突出显示颜色块
'各函数使用同 Pic1_Paint 中
Dim Row As Integer
Dim Column As Integer
Dim BoxHeight As Integer
Dim BoxWidth As Integer
Dim Color As Long
Dim ColorIndex As Long
Dim hBrush As Long
Dim Dummy As Integer

BoxWidth = Pic1.ScaleWidth \ Block
BoxHeight = Pic1.ScaleHeight \ Block

If ColorSelected > -1 Then
'选择了颜色块
Row = ColorSelected \ Block + 1
Column = ColorSelected Mod Block + 1
hBrush = CreateSolidBrush(&H1000000 Or ColorSelected)
Dummy = SelectObject(Pic1.hdc, hBrush)
Dummy = Rectangle(Pic1.hdc, MaxVal((Column - 1.5) * BoxWidth, 0), _
MaxVal((Row - 1.5) * BoxHeight, 0), MinVal((Column + 0.5), Block) * BoxWidth, _
MinVal((Row + 0.5), Block) * BoxHeight)
Dummy = SelectObject(Pic1.hdc, GetStockObject(BLACK_BRUSH))
Dummy = DeleteObject(hBrush)
End If
End Sub

Private Sub Pic2_Paint()
'该函数用于绘制颜色显示块(Pic2 控件)
Dim hBrush As Long
Dim Dummy As Long

hSystemPalette = SelectPalette(Pic2.hdc, hCurrentPalette, 0)
Dummy = RealizePalette(Pic2.hdc)
hBrush = CreateSolidBrush(&H1000000 Or ColorSelected)
Dummy = SelectObject(Pic2.hdc, hBrush)
Dummy = Rectangle(Pic2.hdc, 0, 0, Pic2.ScaleWidth, Pic2.ScaleHeight)
Dummy = SelectObject(Pic2.hdc, GetStockObject(BLACK_BRUSH))
Dummy = DeleteObject(hBrush)
End Sub

Private Function MaxVal(i1, i2) As Single
'计算最大值
If i1 > i2 Then
MaxVal = i1
Else
MaxVal = i2
End If
End Function

Private Function MinVal(i1, i2) As Single
'计算最小值
If i1 < i2 Then
MinVal = i1
Else
MinVal = i2
End If
End Function

Private Sub ChangeColor(index As Integer)
'修改标签颜色
Select Case index
Case 0
Label2(index).ForeColor = RGB(Colour(index).Value, 0, 0)
Case 1
Label2(index).ForeColor = RGB(0, Colour(index).Value, 0)
Case 2
Label2(index).ForeColor = RGB(0, 0, Colour(index).Value)
End Select
End Sub

作者: 61.142.212.* 2005-10-28 21:25 　回复此发言

--------------------------------------------------------------------------------

35 精彩万花筒(可以生成许多美丽的艺术图案)
Public duo As Boolean
Public icolor As Long
Private Sub cmddan_Click()
cdl1.ShowColor
icolor = cdl1.Color
duo = False
End Sub

Private Sub cmdduo_Click()
duo = True
End Sub

Private Sub cmdexit_Click()
MsgBox "欢迎再次使用本程序!" & Chr(13) & " 作者:风之影(USTC)", vbInformation + vbOKOnly, "关于"
End
End Sub

Private Sub cmdpaint_Click()
Const pi = 3.1415926
Dim temp As Double
Dim per As Integer
picpaint.Cls
a = 95
ifunction = Int(4 * Rnd)
cx = 120: cy = 110
d = 2 * Rnd
per = Int(Rnd * 5) + 5
For bt = 0 To pi * (Rnd + 1) Step pi / per
bt1 = Cos(bt): bt2 = Sin(bt)
For g = 1 To 2
For l = -1 To 1 Step 2
For z = -90 To 90 Step 5
x = z: al = (z + 90) * 2 * pi / 180
Select Case ifuncion
Case 0
y = l * a * Sin(al) * Cos(d * al)
Case 1
y = l * a * Sin(al) * Sin(d * al)
Case 2
y = l * a * Cos(al) * Cos(d * al)
Case 3
y = l * a * Cos(al) * Sin(d * al)
End Select
If g = 2 Then
temp = x: x = y: y = temp
End If
X1 = x * bt1 - y * bt2
Y1 = x * bt2 + y * bt1
X2 = cx - X1: Y2 = cy + Y1
If z = -90 Then
bx = X2: By = Y2
picpaint.PSet (bx, By), QBColor(13)
ElseIf duo Then
Randomize
rr = Int(225 * Rnd): gg = Int(225 * Rnd): bb = Int(225 * Rnd)
picpaint.Line -(X2, Y2), RGB(rr, gg, bb)
Else
picpaint.Line -(X2, Y2), icolor
End If
Next z: Next l: Next g: Next bt

End Sub

Private Sub cmdsave_Click()
Dim filename As String
cdl1.DialogTitle = "保存"
cdl1.ShowSave

filename = cdl1.filename
If filename <> "" Then
SavePicture picpaint.Image, filename
End If

End Sub

Private Sub Form_Load()
cdl1.Flags = cdlOFNOverwritePrompt + cdlOFNFileMustExist + cdlOFNCreatePrompt + cdlOFNHideReadOnly
End Sub

作者: 61.142.212.* 2005-10-28 21:26 　回复此发言

--------------------------------------------------------------------------------

36 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private m_cN As cNeoCaption

Private Sub sub_Skin(fMain As Form, cN As cNeoCaption)
cN.ActiveCaptionColor = &HFFFFFF '活动窗体的标题前景色
cN.InActiveCaptionColor = &HC0FFC0 '非活动窗体的标题前景色
'cN.InActiveCaptionColor = &HC0C0C0
cN.ActiveMenuColor = &HC00000 '活动菜单前景色
'cN.ActiveMenuColor = &H0
cN.ActiveMenuColorOver = &HFF& '激活活动菜单前景色
'cN.ActiveMenuColorOver = &H0
cN.InActiveMenuColor = &H0 '非活动菜单前景色
cN.MenuBackgroundColor = &H8000000F '菜单背景颜色
'cN.MenuBackgroundColor = RGB(207, 203, 207)
cN.CaptionFont.Name = "宋体" '标题字体
cN.CaptionFont.Size = 9 '标题字号
cN.MenuFont.Name = "宋体" '菜单字体
cN.MenuFont.Size = 9 '菜单字号
cN.Attach fMain, fMain.PicCaption.Picture, fMain.PicBorder.Picture, 19, 20, 90, 140, 240, 400 '窗体外观参数
fMain.BackColor = &H8000000F '窗体背景
'fMain.BackColor = RGB(208, 207, 192)
'fMain.BackColor = RGB(207, 203, 207)
End Sub

Private Sub Form_Load()
Set m_cN = New cNeoCaption
Call sub_Skin(Me, m_cN) '更改窗体皮肤
End Sub

Private Sub Form_Unload(Cancel As Integer)
m_cN.Detach '取消窗体皮肤
End Sub
-----------
Option Explicit

Public Type POINTAPI
x As Long
y As Long
End Type
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Public Type Msg
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Type TPMPARAMS
cbSize As Long
rcExclude As RECT
End Type

Public Const TPM_CENTERALIGN = &H4&
Public Const TPM_LEFTALIGN = &H0&
Public Const TPM_LEFTBUTTON = &H0&
Public Const TPM_RIGHTALIGN = &H8&
Public Const TPM_RIGHTBUTTON = &H2&

Public Const TPM_NONOTIFY = &H80& '/* Don't send any notification msgs */
Public Const TPM_RETURNCMD = &H100
Public Const TPM_HORIZONTAL = &H0 '/* Horz alignment matters more */
Public Const TPM_VERTICAL = &H40 '/* Vert alignment matters more */

' Win98/2000 menu animation and menu within menu options:
Public Const TPM_RECURSE = &H1&
Public Const TPM_HORPOSANIMATION = &H400&
Public Const TPM_HORNEGANIMATION = &H800&
Public Const TPM_VERPOSANIMATION = &H1000&
Public Const TPM_VERNEGANIMATION = &H2000&
' Win2000 only:
Public Const TPM_NOANIMATION = &H4000&

Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Public Declare Function TrackPopupMenuByLong Lib "user32" Alias "TrackPopupMenu" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, ByVal lprc As Long) As Long
Public Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, lpTPMParams As TPMPARAMS) As Long

' Window MEssages
Public Const WM_DESTROY = &H2
Public Const WM_SIZE = &H5
Public Const WM_SETTEXT = &HC
Public Const WM_ACTIVATEAPP = &H1C
Public Const WM_CANCELMODE = &H1F
Public Const WM_SETCURSOR = &H20

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

37 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Public Const WM_MEASUREITEM = &H2C
Public Const WM_DRAWITEM = &H2B
Public Const WM_STYLECHANGING = &H7C
Public Const WM_STYLECHANGED = &H7D
Public Const WM_NCCALCSIZE = &H83
Public Const WM_NCHITTEST = &H84
Public Const WM_NCPAINT = &H85
Public Const WM_NCACTIVATE = &H86
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_NCLBUTTONUP = &HA2
Public Const WM_NCLBUTTONDBLCLK = &HA3
Public Const WM_KEYDOWN = &H100
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Const WM_INITMENUPOPUP = &H117
Public Const WM_MENUSELECT = &H11F
Public Const WM_MENUCHAR = &H120
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205
Public Const WM_MDIGETACTIVE = &H229
Public Const WM_ENTERMENULOOP = &H211
Public Const WM_EXITMENULOOP = &H212

Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpFn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_KEYBOARD As Long = 2
Private Const WH_MSGFILTER As Long = (-1)
Private Const MSGF_MENU = 2
Private Const HC_ACTION = 0

Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)

' Message filter hook:
Private m_hMsgHook As Long
Private m_lMsgHookPtr As Long

' Keyboard Hook:
Private m_hKeyHook As Long
Private m_lKeyHookPtr() As Long
Private m_lKeyHookCount As Long

Public Sub AttachKeyboardHook(cN As cNCCalcSize)

Dim lpFn As Long
Dim lPtr As Long
Dim i As Long
If m_hKeyHook = 0 Then

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

38 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
lpFn = HookAddress(AddressOf KeyboardFilter)
m_hKeyHook = SetWindowsHookEx(WH_KEYBOARD, lpFn, 0&, GetCurrentThreadId())
Debug.Assert (m_hKeyHook <> 0)
End If

lPtr = ObjPtr(cN)
If GetKeyHookPtrIndex(lPtr) = 0 Then
m_lKeyHookCount = m_lKeyHookCount + 1
ReDim Preserve m_lKeyHookPtr(1 To m_lKeyHookCount) As Long
m_lKeyHookPtr(m_lKeyHookCount) = lPtr
End If

End Sub
Private Function GetKeyHookPtrIndex(ByVal lPtr As Long) As Long
Dim i As Long
For i = 1 To m_lKeyHookCount
If m_lKeyHookPtr(i) = lPtr Then
GetKeyHookPtrIndex = i
Exit For
End If
Next i
End Function
Public Sub DetachKeyboardHook(cN As cNCCalcSize)
Dim lPtr As Long
Dim i As Long
Dim lIdx As Long

lPtr = ObjPtr(cN)
lIdx = GetKeyHookPtrIndex(lPtr)

If lIdx > 0 Then
If m_lKeyHookCount > 1 Then
For i = lIdx To m_lKeyHookCount - 1
m_lKeyHookPtr(i) = m_lKeyHookPtr(i + 1)
Next i
m_lKeyHookCount = m_lKeyHookCount - 1
ReDim Preserve m_lKeyHookPtr(1 To m_lKeyHookCount) As Long
Else
m_lKeyHookCount = 0
Erase m_lKeyHookPtr
End If
End If

If m_lKeyHookCount <= 0 Then
If (m_hKeyHook <> 0) Then
UnhookWindowsHookEx m_hKeyHook
m_hKeyHook = 0
End If
End If

End Sub
Private Function GetActiveConsumer(ByRef cM As cNCCalcSize) As Boolean
Dim i As Long
For i = 1 To m_lKeyHookCount
If Not m_lKeyHookPtr(i) = 0 Then
Set cM = ObjectFromPtr(m_lKeyHookPtr(i))
If cM.WindowActive Then
GetActiveConsumer = True
Exit Function
End If
End If
Next i
End Function
Private Function KeyboardFilter(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim bKeyUp As Boolean
Dim bAlt As Boolean, bCtrl As Boolean, bShift As Boolean
Dim bFKey As Boolean, bEscape As Boolean, bDelete As Boolean
Dim wMask As KeyCodeConstants
Dim i As Long
Dim lPtr As Long
Dim cM As cNCCalcSize

On Error GoTo ErrorHandler

If nCode = HC_ACTION And m_hKeyHook > 0 Then
' Key up or down:
bAlt = ((lParam And &H20000000) = &H20000000)
If bAlt And (wParam > 0) And (wParam <> vbKeyMenu) Then
bKeyUp = ((lParam And &H80000000) = &H80000000)
If Not bKeyUp Then
bShift = (GetAsyncKeyState(vbKeyShift) <> 0)
bCtrl = (GetAsyncKeyState(vbKeyControl) <> 0)
bFKey = ((wParam >= vbKeyF1) And (wParam <= vbKeyF12))
bEscape = (wParam = vbKeyEscape)
bDelete = (wParam = vbKeyDelete)
If Not (bCtrl Or bFKey Or bEscape Or bDelete) Then
If GetActiveConsumer(cM) Then
If cM.AltKeyAccelerator(wParam) Then
' Don't pass accelerator on...
KeyboardFilter = 1
Exit Function
End If
End If
End If
End If
End If
End If
KeyboardFilter = CallNextHookEx(m_hKeyHook, nCode, wParam, lParam)

Exit Function

ErrorHandler:
Debug.Print "Keyboard Hook Error!"
Exit Function
Resume 0
End Function

Public Sub AttachMsgHook(cThis As cToolbarMenu)
Dim lpFn As Long
DetachMsgHook
m_lMsgHookPtr = ObjPtr(cThis)
lpFn = HookAddress(AddressOf MenuInputFilter)
m_hMsgHook = SetWindowsHookEx(WH_MSGFILTER, lpFn, 0&, GetCurrentThreadId())
Debug.Assert (m_hMsgHook <> 0)
End Sub
Public Sub DetachMsgHook()

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

39 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
If (m_hMsgHook <> 0) Then
UnhookWindowsHookEx m_hMsgHook
m_hMsgHook = 0
End If
End Sub

'////////////////
'// Menu filter hook just passes to virtual CMenuBar function
'//
Private Function MenuInputFilter(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim cM As cToolbarMenu
Dim lpMsg As Msg
If nCode = MSGF_MENU Then
If Not m_lMsgHookPtr = 0 Then
Set cM = ObjectFromPtr(m_lMsgHookPtr)
CopyMemory lpMsg, ByVal lParam, Len(lpMsg)
If (cM.MenuInput(lpMsg)) Then
MenuInputFilter = 1
Exit Function
End If
End If
End If
MenuInputFilter = CallNextHookEx(m_hMsgHook, nCode, wParam, lParam)
End Function

Private Function HookAddress(ByVal lPtr As Long) As Long
HookAddress = lPtr
End Function

Public Property Get ObjectFromPtr(ByVal lPtr As Long) As Object
Dim objT As Object
If Not (lPtr = 0) Then
' Turn the pointer into an illegal, uncounted interface
CopyMemory objT, lPtr, 4
' Do NOT hit the End button here! You will crash!
' Assign to legal reference
Set ObjectFromPtr = objT
' Still do NOT hit the End button here! You will still crash!
' Destroy the illegal reference
CopyMemory objT, 0&, 4
End If
End Property

--------------
Option Explicit

' declares:
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Const GWL_WNDPROC = (-4)

' SubTimer is independent of VBCore, so it hard codes error handling

Public Enum EErrorWindowProc
eeBaseWindowProc = 13080 ' WindowProc
eeCantSubclass ' Can't subclass window
eeAlreadyAttached ' Message already handled by another class
eeInvalidWindow ' Invalid window
eeNoExternalWindow ' Can't modify external window
End Enum

Private m_iCurrentMessage As Long
Private m_iProcOld As Long

Public Property Get CurrentMessage() As Long
CurrentMessage = m_iCurrentMessage
End Property

Private Sub ErrRaise(e As Long)

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

40 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.EXEName & ".WindowProc"
Select Case e
Case eeCantSubclass
sText = "Can't subclass window"
Case eeAlreadyAttached
sText = "Message already handled by another class"
Case eeInvalidWindow
sText = "Invalid window"
Case eeNoExternalWindow
sText = "Can't modify external window"
End Select
Err.Raise e Or vbObjectError, sSource, sText
Else
' Raise standard Visual Basic error
Err.Raise e, sSource
End If
End Sub

Sub AttachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
Dim procOld As Long, f As Long, c As Long
Dim iC As Long, bFail As Boolean

' Validate window
If IsWindow(hwnd) = False Then ErrRaise eeInvalidWindow
If IsWindowLocal(hwnd) = False Then ErrRaise eeNoExternalWindow

' Get the message count
c = GetProp(hwnd, "C" & hwnd)
If c = 0 Then
' Subclass window by installing window procecure
procOld = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
If procOld = 0 Then ErrRaise eeCantSubclass
' Associate old procedure with handle
f = SetProp(hwnd, hwnd, procOld)
Debug.Assert f <> 0
' Count this message
c = 1
f = SetProp(hwnd, "C" & hwnd, c)
Else
' Count this message
c = c + 1
f = SetProp(hwnd, "C" & hwnd, c)
End If
Debug.Assert f <> 0

' SPM - in this version I am allowing more than one class to
' make a subclass to the same hWnd and Msg. Why am I doing
' this? Well say the class in question is a control, and it
' wants to subclass its container. In this case, we want
' all instances of the control on the form to receive the
' form notification message.
c = GetProp(hwnd, hwnd & "#" & iMsg & "C")
If (c > 0) Then
For iC = 1 To c
If (GetProp(hwnd, hwnd & "#" & iMsg & "#" & iC) = ObjPtr(iwp)) Then
ErrRaise eeAlreadyAttached
bFail = True
Exit For
End If
Next iC
End If

If Not (bFail) Then
c = c + 1
' Increase count for hWnd/Msg:
f = SetProp(hwnd, hwnd & "#" & iMsg & "C", c)
Debug.Assert f <> 0

' Associate object with message at the count:
f = SetProp(hwnd, hwnd & "#" & iMsg & "#" & c, ObjPtr(iwp))
Debug.Assert f <> 0
End If
End Sub

Sub DetachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
Dim procOld As Long, f As Long, c As Long
Dim iC As Long, iP As Long, lPtr As Long

' Get the message count
c = GetProp(hwnd, "C" & hwnd)
If c = 1 Then
' This is the last message, so unsubclass
procOld = GetProp(hwnd, hwnd)
Debug.Assert procOld <> 0
' Unsubclass by reassigning old window procedure
Call SetWindowLong(hwnd, GWL_WNDPROC, procOld)
' Remove unneeded handle (oldProc)
RemoveProp hwnd, hwnd
' Remove unneeded count
RemoveProp hwnd, "C" & hwnd
Else
' Uncount this message
c = GetProp(hwnd, "C" & hwnd)
c = c - 1
f = SetProp(hwnd, "C" & hwnd, c)
End If

' SPM - in this version I am allowing more than one class to
' make a subclass to the same hWnd and Msg. Why am I doing
' this? Well say the class in question is a control, and it

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

41 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' wants to subclass its container. In this case, we want
' all instances of the control on the form to receive the
' form notification message.

' How many instances attached to this hwnd/msg?
c = GetProp(hwnd, hwnd & "#" & iMsg & "C")
If (c > 0) Then
' Find this iwp object amongst the items:
For iC = 1 To c
If (GetProp(hwnd, hwnd & "#" & iMsg & "#" & iC) = ObjPtr(iwp)) Then
iP = iC
Exit For
End If
Next iC

If (iP <> 0) Then
' Remove this item:
For iC = iP + 1 To c
lPtr = GetProp(hwnd, hwnd & "#" & iMsg & "#" & iC)
SetProp hwnd, hwnd & "#" & iMsg & "#" & (iC - 1), lPtr
Next iC
End If
' Decrement the count
RemoveProp hwnd, hwnd & "#" & iMsg & "#" & c
c = c - 1
SetProp hwnd, hwnd & "#" & iMsg & "C", c

End If
End Sub

Private Function WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) _
As Long
Dim procOld As Long, pSubclass As Long, f As Long
Dim iwp As ISubclass, iwpT As ISubclass
Dim iPC As Long, iP As Long, bNoProcess As Long
Dim bCalled As Boolean

' Get the old procedure from the window
procOld = GetProp(hwnd, hwnd)
Debug.Assert procOld <> 0

' SPM - in this version I am allowing more than one class to
' make a subclass to the same hWnd and Msg. Why am I doing
' this? Well say the class in question is a control, and it
' wants to subclass its container. In this case, we want
' all instances of the control on the form to receive the
' form notification message.

' Get the number of instances for this msg/hwnd:
bCalled = False
iPC = GetProp(hwnd, hwnd & "#" & iMsg & "C")
If (iPC > 0) Then
' For each instance attached to this msg/hwnd, call the subclass:
For iP = 1 To iPC
bNoProcess = False
' Get the object pointer from the message
pSubclass = GetProp(hwnd, hwnd & "#" & iMsg & "#" & iP)
If pSubclass = 0 Then
' This message not handled, so pass on to old procedure
WindowProc = CallWindowProc(procOld, hwnd, iMsg, _
wParam, ByVal lParam)
bNoProcess = True
End If

If Not (bNoProcess) Then
' Turn the pointer into an illegal, uncounted interface
CopyMemory iwpT, pSubclass, 4
' Do NOT hit the End button here! You will crash!
' Assign to legal reference
Set iwp = iwpT
' Still do NOT hit the End button here! You will still crash!
' Destroy the illegal reference
CopyMemory iwpT, 0&, 4
' OK, hit the End button if you must--you'll probably still crash,
' but it will be because of the subclass, not the uncounted reference

' Store the current message, so the client can check it:
m_iCurrentMessage = iMsg
m_iProcOld = procOld

' Use the interface to call back to the class
With iwp
' Preprocess (only check this the first time around):
If (iP = 1) Then
If .MsgResponse = emrPreprocess Then
If Not (bCalled) Then
WindowProc = CallWindowProc(procOld, hwnd, iMsg, _
wParam, ByVal lParam)
bCalled = True
End If
End If
End If
' Consume (this message is always passed to all control
' instances regardless of whether any single one of them

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

42 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' requests to consume it):
WindowProc = .WindowProc(hwnd, iMsg, wParam, ByVal lParam)
' PostProcess (only check this the last time around):
If (iP = iPC) Then
If .MsgResponse = emrPostProcess Then
If Not (bCalled) Then
WindowProc = CallWindowProc(procOld, hwnd, iMsg, _
wParam, ByVal lParam)
bCalled = True
End If
End If
End If
End With
End If
Next iP
Else
' This message not handled, so pass on to old procedure
WindowProc = CallWindowProc(procOld, hwnd, iMsg, _
wParam, ByVal lParam)
End If
End Function
Public Function CallOldWindowProc( _
ByVal hwnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
CallOldWindowProc = CallWindowProc(m_iProcOld, hwnd, iMsg, wParam, lParam)

End Function

' Cheat! Cut and paste from MWinTool rather than reusing
' file because reusing file would cause many unneeded dependencies
Function IsWindowLocal(ByVal hwnd As Long) As Boolean
Dim idWnd As Long
Call GetWindowThreadProcessId(hwnd, idWnd)
IsWindowLocal = (idWnd = GetCurrentProcessId())
End Function
'

--------------
Option Explicit

' declares:
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Const cTimerMax = 100

' Array of timers
Public aTimers(1 To cTimerMax) As CTimer
' Added SPM to prevent excessive searching through aTimers array:
Private m_cTimerCount As Integer

Function TimerCreate(timer As CTimer) As Boolean
' Create the timer
timer.TimerID = SetTimer(0&, 0&, timer.Interval, AddressOf TimerProc)
If timer.TimerID Then
TimerCreate = True
Dim i As Integer
For i = 1 To cTimerMax
If aTimers(i) Is Nothing Then
Set aTimers(i) = timer
If (i > m_cTimerCount) Then
m_cTimerCount = i
End If
TimerCreate = True
Exit Function
End If
Next
timer.ErrRaise eeTooManyTimers
Else
' TimerCreate = False
timer.TimerID = 0
timer.Interval = 0
End If
End Function

Public Function TimerDestroy(timer As CTimer) As Long
' TimerDestroy = False
' Find and remove this timer
Dim i As Integer, f As Boolean
' SPM - no need to count past the last timer set up in the
' aTimer array:
For i = 1 To m_cTimerCount
' Find timer in array
If Not aTimers(i) Is Nothing Then
If timer.TimerID = aTimers(i).TimerID Then
f = KillTimer(0, timer.TimerID)
' Remove timer and set reference to nothing
Set aTimers(i) = Nothing
TimerDestroy = True
Exit Function
End If
' SPM: aTimers(1) could well be nothing before
' aTimers(2) is. This original [else] would leave
' timer 2 still running when the class terminates -
' not very nice! Causes serious GPF in IE and VB design
' mode...
'Else
' TimerDestroy = True
' Exit Function
End If
Next
End Function

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long)
Dim i As Integer

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

43 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' Find the timer with this ID
For i = 1 To m_cTimerCount
' SPM: Add a check to ensure aTimers(i) is not nothing!
' This would occur if we had two timers declared from
' the same thread and we terminated the first one before
' the second! Causes serious GPF if we don't do this...
If Not (aTimers(i) Is Nothing) Then
If idEvent = aTimers(i).TimerID Then
' Generate the event
aTimers(i).PulseTimer
Exit Sub
End If
End If
Next
End Sub

Private Function StoreTimer(timer As CTimer)
Dim i As Integer
For i = 1 To m_cTimerCount
If aTimers(i) Is Nothing Then
Set aTimers(i) = timer
StoreTimer = True
Exit Function
End If
Next
End Function

-------------
Option Explicit

' ======================================================================================
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Type BITMAP '24 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private m_hDC As Long
Private m_hBmpOld As Long
Private m_hBmp As Long
Private m_lWidth As Long
Private m_lheight As Long

Public Sub CreateFromPicture(sPic As IPicture)
Dim tB As BITMAP
Dim lhDCC As Long, lhDC As Long
Dim lhBmpOld As Long
GetObjectAPI sPic.Handle, Len(tB), tB
Width = tB.bmWidth
Height = tB.bmHeight
lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
lhDC = CreateCompatibleDC(lhDCC)
lhBmpOld = SelectObject(lhDC, sPic.Handle)
BitBlt hdc, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
SelectObject lhDC, lhBmpOld
DeleteDC lhDC
DeleteDC lhDCC
End Sub

Public Property Get hdc() As Long
hdc = m_hDC
End Property
Public Property Let Width(ByVal lW As Long)
If lW > m_lWidth Then
pCreate lW, m_lheight
End If
End Property
Public Property Get Width() As Long
Width = m_lWidth
End Property
Public Property Let Height(ByVal lH As Long)
If lH > m_lheight Then
pCreate m_lWidth, lH

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

44 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
End If
End Property
Public Property Get Height() As Long
Height = m_lheight
End Property
Private Sub pCreate(ByVal lW As Long, ByVal lH As Long)
Dim lhDC As Long
pDestroy
lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
m_hDC = CreateCompatibleDC(lhDC)
m_hBmp = CreateCompatibleBitmap(lhDC, lW, lH)
m_hBmpOld = SelectObject(m_hDC, m_hBmp)
If m_hBmpOld = 0 Then
pDestroy
Else
m_lWidth = lW
m_lheight = lH
End If
DeleteDC lhDC
End Sub
Private Sub pDestroy()
If Not m_hBmpOld = 0 Then
SelectObject m_hDC, m_hBmpOld
m_hBmpOld = 0
End If
If Not m_hBmp = 0 Then
DeleteObject m_hBmp
m_hBmp = 0
End If
m_lWidth = 0
m_lheight = 0
If Not m_hDC = 0 Then
DeleteDC m_hDC
m_hDC = 0
End If
End Sub

Private Sub Class_Terminate()
pDestroy
End Sub

---------------
Option Explicit

' =======================================================================
' MENU private declares:
' =======================================================================

' Menu flag constants:
Private Const MF_APPEND = &H100&
Private Const MF_BITMAP = &H4&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_CALLBACKS = &H8000000
Private Const MF_CHANGE = &H80&
Private Const MF_CHECKED = &H8&
Private Const MF_CONV = &H40000000
Private Const MF_DELETE = &H200&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED = &H0&
Private Const MF_END = &H80
Private Const MF_ERRORS = &H10000000
Private Const MF_GRAYED = &H1&
Private Const MF_HELP = &H4000&
Private Const MF_HILITE = &H80&
Private Const MF_HSZ_INFO = &H1000000
Private Const MF_INSERT = &H0&
Private Const MF_LINKS = &H20000000
Private Const MF_MASK = &HFF000000
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_MOUSESELECT = &H8000&
Private Const MF_OWNERDRAW = &H100&
Private Const MF_POPUP = &H10&
Private Const MF_POSTMSGS = &H4000000
Private Const MF_REMOVE = &H1000&
Private Const MF_SENDMSGS = &H2000000
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const MF_SYSMENU = &H2000&
Private Const MF_UNCHECKED = &H0&
Private Const MF_UNHILITE = &H0&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_DEFAULT = &H1000&

Private Const MFT_STRING = MF_STRING
Private Const MFT_BITMAP = MF_BITMAP
Private Const MFT_MENUBARBREAK = MF_MENUBARBREAK
Private Const MFT_MENUBREAK = MF_MENUBREAK
Private Const MFT_OWNERDRAW = MF_OWNERDRAW
Private Const MFT_RADIOCHECK = &H200&
Private Const MFT_SEPARATOR = MF_SEPARATOR
Private Const MFT_RIGHTORDER = &H2000&

' New versions of the names...
Private Const MFS_GRAYED = &H3&
Private Const MFS_DISABLED = MFS_GRAYED
Private Const MFS_CHECKED = MF_CHECKED
Private Const MFS_HILITE = MF_HILITE
Private Const MFS_ENABLED = MF_ENABLED
Private Const MFS_UNCHECKED = MF_UNCHECKED
Private Const MFS_UNHILITE = MF_UNHILITE
Private Const MFS_DEFAULT = MF_DEFAULT

' MenuItemInfo Mask constants
Private Const MIIM_STATE = &H1&
Private Const MIIM_ID = &H2&

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

45 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Const MIIM_SUBMENU = &H4&
Private Const MIIM_CHECKMARKS = &H8&
Private Const MIIM_TYPE = &H10&
Private Const MIIM_DATA = &H20&

Private Const SC_RESTORE = &HF120&
Private Const SC_MOVE = &HF010&
Private Const SC_SIZE = &HF000&
Private Const SC_MAXIMIZE = &HF030&
Private Const SC_MINIMIZE = &HF020&
Private Const SC_CLOSE = &HF060&

Private Const SC_ARRANGE = &HF110&
Private Const SC_HOTKEY = &HF150&
Private Const SC_HSCROLL = &HF080&
Private Const SC_KEYMENU = &HF100&
Private Const SC_MOUSEMENU = &HF090&
Private Const SC_NEXTWINDOW = &HF040&
Private Const SC_PREVWINDOW = &HF050&
Private Const SC_SCREENSAVE = &HF140&
Private Const SC_TASKLIST = &HF130&
Private Const SC_VSCROLL = &HF070&
Private Const SC_ZOOM = SC_MAXIMIZE
Private Const SC_ICON = SC_MINIMIZE

' Owner draw information:
Private Const ODS_CHECKED = &H8
Private Const ODS_DISABLED = &H4
Private Const ODS_FOCUS = &H10
Private Const ODS_GRAYED = &H2
Private Const ODS_SELECTED = &H1
Private Const ODT_BUTTON = 4
Private Const ODT_COMBOBOX = 3
Private Const ODT_LISTBOX = 2
Private Const ODT_MENU = 1

Private Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemWidth As Long
itemHeight As Long
ItemData As Long
End Type

Private Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
itemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
ItemData As Long
End Type

Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As Long
cch As Long
End Type
Private Type MENUITEMINFO_STRINGDATA
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type

Private Type MENUITEMTEMPLATE
mtOption As Integer
mtID As Integer
mtString As Byte
End Type
Private Type MENUITEMTEMPLATEHEADER
versionNumber As Integer
Offset As Integer
End Type

Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Private Declare Function GetMenuContextHelpId Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuDefaultItem Lib "user32" (ByVal hMenu As Long, ByVal fByPos As Long, ByVal gmdiFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

46 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Declare Function GetMenuItemInfoStr Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfoStr Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO_STRINGDATA) As Long
Private Declare Function GetMenuItemRect Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal uItem As Long, lprcItem As RECT) As Long
Private Declare Function GetMenuState Lib "user32" (ByVal hMenu As Long, ByVal wID As Long, ByVal wFlags As Long) As Long

Private Declare Function CreateMenu Lib "user32" () As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long

Private Declare Function AppendMenuBylong Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
Private Declare Function AppendMenuByString Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Private Declare Function ModifyMenuByLong Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function InsertMenuByLong Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Long) As Long
Private Declare Function InsertMenuByString Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
Private Declare Function CheckMenuRadioItem Lib "user32" (ByVal hMenu As Long, ByVal un1 As Long, ByVal un2 As Long, ByVal un3 As Long, ByVal un4 As Long) As Long
Private Declare Function EnableMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

47 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long

Private Declare Function MenuItemFromPoint Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal ptScreen As POINTAPI) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

' =======================================================================
' GDI private declares:
' =======================================================================

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_VCENTER = &H4
Private Const DT_TOP = &H0
Private Const DT_TABSTOP = &H80
Private Const DT_SINGLELINE = &H20
Private Const DT_RIGHT = &H2
Private Const DT_NOCLIP = &H100
Private Const DT_INTERNAL = &H1000
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_EXPANDTABS = &H40
Private Const DT_CHARSTREAM = 4
Private Const DT_NOPREFIX = &H800
Private Const DT_EDITCONTROL = &H2000&
Private Const DT_PATH_ELLIPSIS = &H4000&
Private Const DT_END_ELLIPSIS = &H8000&
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

' DrawEdge:
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const BDR_OUTER = &H3

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

48 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Const CLR_INVALID = -1

' =======================================================================
' General Win private declares:
' =======================================================================
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Const HWND_DESKTOP = 0

' =======================================================================
' IMPLEMENTATION
' =======================================================================

Private m_cMemDC As cMemDC
Private m_cToolbarMenu As cToolbarMenu
Private m_hMenu As Long
Private m_hWnd As Long

Private m_tR() As RECT
Private m_hSubMenu() As Long
Private m_iCount As Long
Private m_iDownOn As Long
Private m_iOver As Long

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR

Private m_oMenuBackgroundColor As OLE_COLOR

Private m_lCaptionHeight As Long

Private m_iRestore As Long
Private m_hMenuRestore() As Long
Private m_iMenuPosition() As Long
Private m_tMIIS() As MENUITEMINFO_STRINGDATA
Private m_sCaption() As String
Private m_sShortCut() As String
Private m_sAccelerator() As String
Private m_lMenuTextSize() As Long
Private m_lMenuShortCutSize() As Long

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_fnt As StdFont
Private m_fntSymbol As StdFont

Private m_lMenuItemHeight As Long

Private WithEvents m_cTmr As CTimer

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

49 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)

Implements ISubclass

Friend Property Let Font( _
fntThis As StdFont _
)
Set m_fnt = fntThis
End Property
Friend Property Set Font( _
fntThis As StdFont _
)
Set m_fnt = fntThis
m_fntSymbol.Name = "Marlett"
m_fntSymbol.Size = m_fnt.Size * 1.2
End Property
Friend Property Get Font() As StdFont
Set Font = m_fnt
End Property
Friend Sub SetColors( _
ByVal oActiveMenuColor As OLE_COLOR, _
ByVal oActiveMenuColorOver As OLE_COLOR, _
ByVal oInActiveMenuColor As OLE_COLOR, _
ByVal oMenuBackgroundColor As OLE_COLOR _
)
m_oActiveMenuColor = oActiveMenuColor
m_oActiveMenuColorOver = oActiveMenuColorOver
m_oInActiveMenuColor = oInActiveMenuColor
m_oMenuBackgroundColor = oMenuBackgroundColor
End Sub
Private Property Get hFont() As Long
Dim iFn As IFont
Set iFn = m_fnt
hFont = iFn.hFont
End Property
Private Property Get hFontSymbol() As Long
Dim iFn As IFont
Set iFn = m_fntSymbol
hFontSymbol = iFn.hFont
End Property

Public Property Let hMenu(ByVal hTheMenu As Long)
m_hMenu = hTheMenu
End Property
Public Property Get hMenu() As Long
hMenu = m_hMenu
End Property
Public Sub Attach(ByVal lhWnd As Long)
LockWindowUpdate lhWnd
Detach
m_hWnd = lhWnd
Set m_cToolbarMenu = New cToolbarMenu
m_cToolbarMenu.CoolMenuAttach m_hWnd, Me
AttachMessage Me, m_hWnd, WM_LBUTTONDOWN
AttachMessage Me, m_hWnd, WM_MOUSEMOVE
AttachMessage Me, m_hWnd, WM_DRAWITEM
AttachMessage Me, m_hWnd, WM_MEASUREITEM
AttachMessage Me, m_hWnd, WM_MENUCHAR
LockWindowUpdate 0
End Sub
Public Sub Detach()
If Not m_hWnd = 0 Then
DetachMessage Me, m_hWnd, WM_LBUTTONDOWN
DetachMessage Me, m_hWnd, WM_MOUSEMOVE
DetachMessage Me, m_hWnd, WM_DRAWITEM
DetachMessage Me, m_hWnd, WM_MEASUREITEM
DetachMessage Me, m_hWnd, WM_MENUCHAR
End If
If Not m_cToolbarMenu Is Nothing Then
m_cToolbarMenu.CoolMenuDetach
Set m_cToolbarMenu = Nothing
End If
End Sub
Public Property Let CaptionHeight(ByVal lHeight As Long)
m_lCaptionHeight = lHeight
End Property

Public Sub Render( _
ByVal hFnt As Long, _
ByVal lhDC As Long, _
ByVal lLeft As Long, _
ByVal lTop As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lYoffset As Long _
)
Dim iIdx As Long
Dim lC As Long
Dim lhDCC As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim sCap As String
Dim hFntOld As Long
Dim tTR As RECT, tBR As RECT
Dim lX As Long
Dim lR As Long
Dim bPress As Boolean
Dim lID As Long

If Not (m_hMenu = 0) Then
m_cMemDC.Width = lWidth
m_cMemDC.Height = lHeight
lhDCC = m_cMemDC.hdc

hFntOld = SelectObject(lhDCC, hFnt)
m_iCount = 0
Erase m_tR

lC = GetMenuItemCount(m_hMenu)
If lC > 0 Then
lX = 8
lTop = lTop + 2
BitBlt lhDCC, 0, 0, lWidth, lHeight, lhDC, lLeft, lTop, vbSrcCopy
SetBkMode lhDCC, TRANSPARENT
For iIdx = 0 To lC - 1
lID = GetMenuItemID(m_hMenu, iIdx)
If lID = -1 Then
tMII.fMask = MIIM_TYPE
tMII.cch = 127
tMII.dwTypeData = String$(128, 0)
tMII.cbSize = LenB(tMII)
lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
If (tMII.fType And MFT_STRING) = MFT_STRING Then

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

50 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
If tMII.cch > 0 Then
sCap = left$(tMII.dwTypeData, tMII.cch)
Else
sCap = ""
End If
tTR.top = 0
tTR.bottom = lHeight
tTR.left = 0: tTR.right = 0
DrawText lhDCC, sCap, -1, tTR, DT_CALCRECT
OffsetRect tTR, lX, 2
LSet tBR = tTR
InflateRect tBR, 2, 2
tBR.right = tBR.right + 7
m_iCount = m_iCount + 1
bPress = False
If m_iCount = m_iDownOn Then
' This is the item that was clicked:
If m_iDownOn = m_iOver Then
' Draw Pressed
'Debug.Print "DrawPressed"
bPress = True
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_SUNKENOUTER, BF_RECT
Else
' Draw Raised
'Debug.Print "DrawRaised"
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
End If
Else
' Not down on, may be over:
If m_iCount = m_iOver Then
' Draw Raised
'Debug.Print "DrawRaised"
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
Else
' Draw None
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColor)
End If
End If
If bPress Then
OffsetRect tTR, 1, 1
End If
DrawText lhDCC, sCap, -1, tTR, DT_LEFT Or DT_SINGLELINE
If bPress Then
OffsetRect tTR, -1, -1
End If
ReDim Preserve m_tR(1 To m_iCount) As RECT
ReDim Preserve m_hSubMenu(1 To m_iCount) As Long
OffsetRect tBR, lLeft, lYoffset
LSet m_tR(m_iCount) = tBR
m_hSubMenu(m_iCount) = GetSubMenu(m_hMenu, iIdx)
lX = lX + tTR.right - tTR.left + 1 + 10
End If
End If
Next iIdx

BitBlt lhDC, lLeft, lTop, lWidth, lHeight, lhDCC, 0, 0, vbSrcCopy

End If

SelectObject lhDCC, hFntOld
End If
End Sub
Friend Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Boolean
Dim lC As Long
Dim iIdx As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim lR As Long
Dim sCap As String
Dim iPos As Long
Dim sAccel As String

lC = GetMenuItemCount(m_hMenu)
If lC > 0 Then
For iIdx = 0 To lC - 1
tMII.fMask = MIIM_TYPE Or MIIM_DATA
tMII.cch = 127
tMII.dwTypeData = String$(128, 0)
tMII.cbSize = LenB(tMII)
lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
If tMII.cch > 0 Then
sCap = left$(tMII.dwTypeData, tMII.cch)
iPos = InStr(sCap, "&")
If iPos > 0 And iPos < Len(sCap) Then
sAccel = UCase$(Mid$(sCap, iPos + 1, 1))
If sAccel = Chr$(vKey) Then
PressButton iIdx + 1, True
If Not m_cTmr Is Nothing Then
m_cTmr.Interval = 0
End If
lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
pRestoreList
AltKeyAccelerator = True
End If
End If
End If
Next iIdx
End If
End Function
Private Function MenuHitTest() As Long

If m_iCount > 0 Then
Dim tP As POINTAPI
GetCursorPos tP
MenuHitTest = HitTest(tP)
End If

End Function
Friend Function HitTest(tP As POINTAPI) As Long

' Is tP within a top level menu button? tP
' is in screen coords
'
Dim iMenu As Long

ScreenToClient m_hWnd, tP
For iMenu = 1 To m_iCount
'Debug.Print m_tR(iMenu).left, m_tR(iMenu).top, m_tR(iMenu).right, m_tR(iMenu).bottom, tP.x, tP.y
If PtInRect(m_tR(iMenu), tP.x, tP.y) <> 0 Then

51 漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
HitTest = iMenu
Exit Function
End If
Next iMenu
End Function
Friend Property Get Count() As Long

' Number of top level menu items:?
'
Count = m_iCount

End Property
Friend Function GetMenuHandle(ByVal iNewPopup As Long) As Long

' Returns the popup menu handle for a given top level
' menu item (1 based index)
'
If iNewPopup > 0 And iNewPopup <= m_iCount Then
GetMenuHandle = m_hSubMenu(iNewPopup)
End If
End Function
Friend Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
'
If bState Then
m_iDownOn = iButton
Else
If m_iDownOn = iButton Then
m_iDownOn = -1
End If
End If
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0

End Sub
Friend Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
Dim tRW As RECT
If iButton > 0 And iButton <= m_iCount Then
LSet tR = m_tR(iButton)
GetWindowRect m_hWnd, tRW
OffsetRect tR, tRW.left, tRW.top + m_lCaptionHeight
End If
End Sub
Friend Property Get HotItem() As Long
'
HotItem = m_iDownOn
End Property
Friend Property Let HotItem(ByVal iHotItem As Long)
' Set the hotitem
m_iOver = iHotItem
' Repaint:
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End Property

Friend Sub OwnerDrawMenu(ByVal hMenu As Long)
Dim lC As Long
Dim tMIIS As MENUITEMINFO_STRINGDATA
Dim tMII As MENUITEMINFO
Dim iMenu As Long
Dim sCap As String
Dim sShortCut As String
Dim tR As RECT
Dim iPos As Long
Dim lID As Long
Dim bHaveSeen As Boolean
Dim hFntOld As Long
Dim lMenuTextSize As Long
Dim lMenuShortCutSize As Long
Dim i As Long

' Set OD flag on the fly...
bHaveSeen = pbHaveSeen(hMenu)

hFntOld = SelectObject(m_cMemDC.hdc, hFont)
lC = GetMenuItemCount(hMenu)
For iMenu = 0 To lC - 1

If Not bHaveSeen Then

tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
tMIIS.cch = 127
tMIIS.dwTypeData = String$(128, 0)
tMIIS.cbSize = LenB(tMIIS)
GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
'Debug.Print "New Item", tMIIS.dwTypeData

lID = plAddToRestoreList(hMenu, iMenu, tMIIS)

If Not (tMIIS.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW Then
' Setting this flag causes tMIIS.dwTypeData to be
' overwritten with our own app-defined value:
tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
tMII.dwItemData = lID
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_DATA
SetMenuItemInfo hMenu, iMenu, True, tMII
End If

Else

tMII.fMask = MIIM_TYPE Or MIIM_DATA
tMII.cbSize = Len(tMII)
GetMenuItemInfo hMenu, iMenu, True, tMII
lID = tMII.dwItemData

If Not ((tMII.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW) Then

lID = plReplaceIndex(hMenu, iMenu)

'Debug.Print "VB has done something to it!", lID
tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
tMIIS.cch = 127
tMIIS.dwTypeData = String$(128, 0)
tMIIS.cbSize = LenB(tMIIS)
GetMenuItemInfoStr hMenu, iMenu, True, tMIIS

pReplaceRestoreList lID, hMenu, iMenu, tMIIS

' Setting this flag causes tMIIS.dwTypeData to be
' overwritten with our own app-defined value:
tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
tMII.dwItemData = lID
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_DATA
SetMenuItemInfo hMenu, iMenu, True, tMII

End If

End If

If lID > 0 And lID <= m_iRestore Then
sCap = m_sCaption(lID)
sShortCut = m_sShortCut(lID)

'Debug.Print m_sCaption(lID), m_sShortCut(lID)

DrawText m_cMemDC.hdc, sCap, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
If tR.right - tR.left + 1 > lMenuTextSize Then
lMenuTextSize = tR.right - tR.left + 1
End If
If Len(sShortCut) > 0 Then
DrawText m_cMemDC.hdc, sShortCut, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
If tR.right - tR.left + 1 > lMenuShortCutSize Then
lMenuShortCutSize = tR.right - tR.left + 1
End If
End If
m_lMenuItemHeight = tR.bottom - tR.top + 1

Else
'Debug.Print "ERROR! ERROR! ERROR!"
End If

Next iMenu

For i = 1 To m_iRestore
If m_hMenuRestore(i) = hMenu Then
m_lMenuTextSize(i) = lMenuTextSize
m_lMenuShortCutSize(i) = lMenuShortCutSize
End If
Next i

SelectObject m_cMemDC.hdc, hFntOld

End Sub
Private Function pbHaveSeen(ByVal hMenu As Long) As Boolean

' When WM_INITMENUPOPUP fires, this may or not be
' a new menu. We use an array to store which menus
' we've already worked on:

Dim i As Long

For i = 1 To m_iHaveSeenCount
If hMenu = m_hMenuSeen(i) Then
pbHaveSeen = True
Exit Function
End If
Next i
m_iHaveSeenCount = m_iHaveSeenCount + 1
ReDim Preserve m_hMenuSeen(1 To m_iHaveSeenCount) As Long
m_hMenuSeen(m_iHaveSeenCount) = hMenu

End Function
Private Function plReplaceIndex(ByVal hMenu As Long, ByVal iMenu As Long)
Dim i As Long
For i = 1 To m_iRestore
If m_hMenuRestore(i) = hMenu Then
If m_iMenuPosition(i) = iMenu Then
p

作者: 61.142.212.* 2005-10-28 21:32 　回复此发言

--------------------------------------------------------------------------------

52 回复 50:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private m_cMemDC As cMemDC
Private m_cToolbarMenu As cToolbarMenu
Private m_hMenu As Long
Private m_hWnd As Long

Private m_tR() As RECT
Private m_hSubMenu() As Long
Private m_iCount As Long
Private m_iDownOn As Long
Private m_iOver As Long

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR

Private m_oMenuBackgroundColor As OLE_COLOR

Private m_lCaptionHeight As Long

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_fnt As StdFont
Private m_fntSymbol As StdFont

Private m_lMenuItemHeight As Long

Private WithEvents m_cTmr As CTimer

Implements ISubclass

Public Sub Render( _
ByVal hFnt As Long, _
ByVal lhDC As Long, _

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

53 回复 50:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
ByVal lLeft As Long, _
ByVal lTop As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lYoffset As Long _
)
Dim iIdx As Long
Dim lC As Long
Dim lhDCC As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim sCap As String
Dim hFntOld As Long
Dim tTR As RECT, tBR As RECT
Dim lX As Long
Dim lR As Long
Dim bPress As Boolean
Dim lID As Long

If Not (m_hMenu = 0) Then
m_cMemDC.Width = lWidth
m_cMemDC.Height = lHeight
lhDCC = m_cMemDC.hdc

hFntOld = SelectObject(lhDCC, hFnt)
m_iCount = 0
Erase m_tR

lC = GetMenuItemCount(m_hMenu)
If lC > 0 Then
lX = 8
lTop = lTop + 2
BitBlt lhDCC, 0, 0, lWidth, lHeight, lhDC, lLeft, lTop, vbSrcCopy
SetBkMode lhDCC, TRANSPARENT
For iIdx = 0 To lC - 1
lID = GetMenuItemID(m_hMenu, iIdx)
If lID = -1 Then
tMII.fMask = MIIM_TYPE
tMII.cch = 127
tMII.dwTypeData = String$(128, 0)
tMII.cbSize = LenB(tMII)
lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
If (tMII.fType And MFT_STRING) = MFT_STRING Then
If tMII.cch > 0 Then
sCap = left$(tMII.dwTypeData, tMII.cch)
Else
sCap = ""
End If
tTR.top = 0
tTR.bottom = lHeight
tTR.left = 0: tTR.right = 0
DrawText lhDCC, sCap, -1, tTR, DT_CALCRECT
OffsetRect tTR, lX, 2
LSet tBR = tTR
InflateRect tBR, 2, 2
tBR.right = tBR.right + 7
m_iCount = m_iCount + 1
bPress = False
If m_iCount = m_iDownOn Then
' This is the item that was clicked:
If m_iDownOn = m_iOver Then
' Draw Pressed
'Debug.Print "DrawPressed"
bPress = True
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_SUNKENOUTER, BF_RECT
Else
' Draw Raised
'Debug.Print "DrawRaised"
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
End If
Else
' Not down on, may be over:
If m_iCount = m_iOver Then
' Draw Raised
'Debug.Print "DrawRaised"
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColorOver)
DrawEdge lhDCC, tBR, BDR_RAISEDINNER, BF_RECT
Else
' Draw None
SetTextColor lhDCC, TranslateColor(m_oActiveMenuColor)
End If
End If
If bPress Then
OffsetRect tTR, 1, 1
End If
DrawText lhDCC, sCap, -1, tTR, DT_LEFT Or DT_SINGLELINE
If bPress Then
OffsetRect tTR, -1, -1
End If
ReDim Preserve m_tR(1 To m_iCount) As RECT
ReDim Preserve m_hSubMenu(1 To m_iCount) As Long
OffsetRect tBR, lLeft, lYoffset
LSet m_tR(m_iCount) = tBR
m_hSubMenu(m_iCount) = GetSubMenu(m_hMenu, iIdx)
lX = lX + tTR.right - tTR.left + 1 + 10
End If
End If
Next iIdx

BitBlt lhDC, lLeft, lTop, lWidth, lHeight, lhDCC, 0, 0, vbSrcCopy

lC = GetMenuItemCount(m_hMenu)
If lC > 0 Then
For iIdx = 0 To lC - 1
tMII.fMask = MIIM_TYPE Or MIIM_DATA
tMII.cch = 127
tMII.dwTypeData = String$(128, 0)
tMII.cbSize = LenB(tMII)

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

54 回复 50:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
lR = GetMenuItemInfoStr(m_hMenu, iIdx, True, tMII)
If tMII.cch > 0 Then
sCap = left$(tMII.dwTypeData, tMII.cch)
iPos = InStr(sCap, "&")
If iPos > 0 And iPos < Len(sCap) Then
sAccel = UCase$(Mid$(sCap, iPos + 1, 1))
If sAccel = Chr$(vKey) Then
PressButton iIdx + 1, True
If Not m_cTmr Is Nothing Then
m_cTmr.Interval = 0
End If
lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
pRestoreList
AltKeyAccelerator = True
End If
End If
End If
Next iIdx
End If
End Function
Private Function MenuHitTest() As Long

If m_iCount > 0 Then
Dim tP As POINTAPI
GetCursorPos tP
MenuHitTest = HitTest(tP)
End If

End Function
Friend Function HitTest(tP As POINTAPI) As Long

' Is tP within a top level menu button? tP
' is in screen coords
'
Dim iMenu As Long

ScreenToClient m_hWnd, tP
For iMenu = 1 To m_iCount
'Debug.Print m_tR(iMenu).left, m_tR(iMenu).top, m_tR(iMenu).right, m_tR(iMenu).bottom, tP.x, tP.y
If PtInRect(m_tR(iMenu), tP.x, tP.y) <> 0 Then
HitTest = iMenu
Exit Function
End If
Next iMenu
End Function
Friend Property Get Count() As Long

' Number of top level menu items:?
'
Count = m_iCount

End Property
Friend Function GetMenuHandle(ByVal iNewPopup As Long) As Long

' Returns the popup menu handle for a given top level
' menu item (1 based index)
'
If iNewPopup > 0 And iNewPopup <= m_iCount Then
GetMenuHandle = m_hSubMenu(iNewPopup)
End If
End Function
Friend Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
'
If bState Then
m_iDownOn = iButton
Else
If m_iDownOn = iButton Then
m_iDownOn = -1
End If
End If
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0

End Sub
Friend Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
Dim tRW As RECT
If iButton > 0 And iButton <= m_iCount Then
LSet tR = m_tR(iButton)
GetWindowRect m_hWnd, tRW
OffsetRect tR, tRW.left, tRW.top + m_lCaptionHeight
End If
End Sub
Friend Property Get HotItem() As Long
'
HotItem = m_iDownOn
End Property
Friend Property Let HotItem(ByVal iHotItem As Long)
' Set the hotitem
m_iOver = iHotItem
' Repaint:
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End Property

hFntOld = SelectObject(m_cMemDC.hdc, hFont)
lC = GetMenuItemCount(hMenu)
For iMenu = 0 To lC - 1

If Not bHaveSeen Then

tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
tMIIS.cch = 127
tMIIS.dwTypeData = String$(128, 0)
tMIIS.cbSize = LenB(tMIIS)
GetMenuItemInfoStr hMenu, iMenu, True, tMIIS
'Debug.Print "New Item", tMIIS.dwTypeData

lID = plAddToRestoreList(hMenu, iMenu, tMIIS)

If Not (tMIIS.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW Then

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

55 回复 50:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' Setting this flag causes tMIIS.dwTypeData to be
' overwritten with our own app-defined value:
tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
tMII.dwItemData = lID
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_DATA
SetMenuItemInfo hMenu, iMenu, True, tMII
End If

Else

tMII.fMask = MIIM_TYPE Or MIIM_DATA
tMII.cbSize = Len(tMII)
GetMenuItemInfo hMenu, iMenu, True, tMII
lID = tMII.dwItemData

If Not ((tMII.fType And MFT_OWNERDRAW) = MFT_OWNERDRAW) Then

lID = plReplaceIndex(hMenu, iMenu)

'Debug.Print "VB has done something to it!", lID
tMIIS.fMask = MIIM_TYPE Or MIIM_DATA Or MIIM_ID
tMIIS.cch = 127
tMIIS.dwTypeData = String$(128, 0)
tMIIS.cbSize = LenB(tMIIS)
GetMenuItemInfoStr hMenu, iMenu, True, tMIIS

pReplaceRestoreList lID, hMenu, iMenu, tMIIS

' Setting this flag causes tMIIS.dwTypeData to be
' overwritten with our own app-defined value:
tMII.fType = tMIIS.fType Or MFT_OWNERDRAW
tMII.dwItemData = lID
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_DATA
SetMenuItemInfo hMenu, iMenu, True, tMII

End If

End If

If lID > 0 And lID <= m_iRestore Then
sCap = m_sCaption(lID)
sShortCut = m_sShortCut(lID)

'Debug.Print m_sCaption(lID), m_sShortCut(lID)

DrawText m_cMemDC.hdc, sCap, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
If tR.right - tR.left + 1 > lMenuTextSize Then
lMenuTextSize = tR.right - tR.left + 1
End If
If Len(sShortCut) > 0 Then
DrawText m_cMemDC.hdc, sShortCut, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_CALCRECT
If tR.right - tR.left + 1 > lMenuShortCutSize Then
lMenuShortCutSize = tR.right - tR.left + 1
End If
End If
m_lMenuItemHeight = tR.bottom - tR.top + 1

Else
'Debug.Print "ERROR! ERROR! ERROR!"
End If

Next iMenu

For i = 1 To m_iRestore
If m_hMenuRestore(i) = hMenu Then
m_lMenuTextSize(i) = lMenuTextSize
m_lMenuShortCutSize(i) = lMenuShortCutSize
End If
Next i

SelectObject m_cMemDC.hdc, hFntOld

End Sub
Private Function pbHaveSeen(ByVal hMenu As Long) As Boolean

' When WM_INITMENUPOPUP fires, this may or not be
' a new menu. We use an array to store which menus
' we've already worked on:

End Function
Private Function plReplaceIndex(ByVal hMenu As Long, ByVal iMenu As Long)
Dim i As Long
For i = 1 To m_iRestore
If m_hMenuRestore(i) = hMenu Then
If m_iMenuPosition(i) = iMenu Then
plReplaceIndex = i
Exit Function
End If
End If
Next i
End Function
Private Function plAddToRestoreList(ByVal hMenu As Long, ByVal iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA) As Long

' Here we store information about a menu item. When the
' menus are closed again we can reset things back to the
' way they were using this struct.

m_iRestore = m_iRestore + 1

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

56 回复 50:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
ReDim Preserve m_hMenuRestore(1 To m_iRestore) As Long
ReDim Preserve m_iMenuPosition(1 To m_iRestore) As Long
ReDim Preserve m_tMIIS(1 To m_iRestore) As MENUITEMINFO_STRINGDATA
ReDim Preserve m_sCaption(1 To m_iRestore) As String
ReDim Preserve m_sShortCut(1 To m_iRestore) As String
ReDim Preserve m_sAccelerator(1 To m_iRestore) As String
ReDim Preserve m_lMenuTextSize(1 To m_iRestore) As Long
ReDim Preserve m_lMenuShortCutSize(1 To m_iRestore) As Long
pReplaceRestoreList m_iRestore, hMenu, iMenu, tMIIS
plAddToRestoreList = m_iRestore

End Function
Private Sub pReplaceRestoreList(ByVal lIdx As Long, hMenu As Long, iMenu As Long, tMIIS As MENUITEMINFO_STRINGDATA)
Dim sCap As String
Dim sShortCut As String
Dim iPos As Long

m_hMenuRestore(lIdx) = hMenu
m_iMenuPosition(lIdx) = iMenu
LSet m_tMIIS(lIdx) = tMIIS
If tMIIS.cch > 0 Then
sCap = left$(tMIIS.dwTypeData, tMIIS.cch)
Else
sCap = ""
End If
iPos = InStr(sCap, vbTab)
If iPos > 0 Then
m_sShortCut(lIdx) = Mid$(sCap, iPos + 1)
m_sCaption(lIdx) = left$(sCap, iPos - 1)
Else
m_sCaption(lIdx) = sCap
m_sShortCut(lIdx) = ""
End If
iPos = InStr(m_sCaption(lIdx), "&")
If iPos > 0 And iPos < Len(m_sCaption(lIdx)) Then
m_sAccelerator(lIdx) = UCase$(Mid$(m_sCaption(lIdx), iPos + 1, 1))
End If
End Sub
Private Function InternalIDForWindowsID(ByVal wID As Long) As Long
Dim i As Long
' linear search I'm afraid, but it is only called once
' per menu item shown (when WM_MEASUREITEM is fired)
For i = 1 To m_iRestore
If m_tMIIS(i).wID = wID Then
InternalIDForWindowsID = i
Exit Function
End If
Next i
End Function
Friend Sub pRestoreList()
Dim i As Long
'Debug.Print "RESTORELIST"
' erase the lot:
For i = 1 To m_iRestore
SetMenuItemInfoStr m_hMenuRestore(i), m_iMenuPosition(i), True, m_tMIIS(i)
Next i
m_iRestore = 0
Erase m_hMenuRestore
Erase m_iMenuPosition
Erase m_tMIIS
Erase m_sCaption()
Erase m_sShortCut()
Erase m_sAccelerator()
m_iHaveSeenCount = 0
Erase m_hMenuSeen()
End Sub

Private Sub Class_Initialize()
Set m_cMemDC = New cMemDC
Set m_fnt = New StdFont
m_fnt.Name = "MS Sans Serif"
Set m_fntSymbol = New StdFont
m_fntSymbol.Name = "Marlett"
m_fntSymbol.Size = m_fnt.Size * 1.2
End Sub

Private Sub Class_Terminate()
Set m_cMemDC = Nothing
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
'
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
ISubclass_MsgResponse = emrConsume
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim iMenu As Long
Dim iLastDownOn As Long
Dim iLastOver As Long
Dim lR As Long
Dim lFlag As Long
Dim hMenu As Long
Dim iChar As Long

Select Case iMsg
Case WM_LBUTTONDOWN
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
' If in range, then...
iMenu = MenuHitTest()
iLastDownOn = m_iDownOn
m_iDownOn = iMenu
If m_iDownOn <> iLastDownOn Then
' !Repaint!
'Debug.Print "Repaint"
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End If

If m_iDownOn > 0 Then
m_cTmr.Interval = 0
lR = m_cToolbarMenu.TrackPopup(m_iDownOn)
pRestoreList
End If

Case WM_MOUSEMOVE
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
pMouseMove

Case WM_MEASUREITEM
ISubclass_WindowProc = MeasureItem(wParam, lParam)

Case WM_DRAWITEM
DrawItem wParam, lParam

Case WM_MENUCHAR
' Check that this is my menu:
lFlag = wParam \ &H10000
If ((lFlag And MF_SYSMENU) <> MF_SYSMENU) Then
hMenu = lParam
iChar = (wParam And &HFFFF&)
' See if this corresponds to an accelerator on the menu:
lR = ParseMenuChar(hMenu, iChar)
If lR > 0 Then
ISubclass_WindowProc = lR
Exit Function
End If
End If
ISubclass_WindowProc = CallOldWindowProc(m_hWnd, WM_MENUCHAR, wParam, lParam)

End Select

End Function
'

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

57 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Function ParseMenuChar( _
ByVal hMenu As Long, _
ByVal iChar As Integer _
) As Long
Dim sChar As String
Dim l As Long
Dim lH() As Long
Dim sItems() As String

'Debug.Print "WM_MENUCHAR"
sChar = UCase$(Chr$(iChar))
For l = 1 To m_iRestore
If (m_hMenuRestore(l) = hMenu) Then
If (m_sAccelerator(l) = sChar) Then
ParseMenuChar = &H20000 Or m_iMenuPosition(l)
' Debug.Print "Found Menu Char"
Exit Function
End If
End If
Next l

End Function

Private Function MeasureItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMIS As MEASUREITEMSTRUCT
Dim lID As Long
CopyMemory tMIS, ByVal lParam, LenB(tMIS)
If tMIS.CtlType = ODT_MENU Then

' because we don't get the popup menu handle
' in the tMIS structure, we have to do an internal
' lookup to find info about this menu item.
' poor implementation of MEASUREITEMSTRUCT - it
' should have a .hWndItem field like DRAWITEMSTRUCT
' - spm
lID = InternalIDForWindowsID(tMIS.itemID)

' Width:
tMIS.itemWidth = 4 + 22 + m_lMenuTextSize(lID) + 4
If m_lMenuShortCutSize(lID) > 0 Then
tMIS.itemWidth = tMIS.itemWidth + 4 + m_lMenuShortCutSize(lID) + 4
End If

' Height:
If lID > 0 And lID <= m_iRestore Then
If (m_tMIIS(lID).fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
tMIS.itemHeight = 6
Else
' menu item height is always the same
tMIS.itemHeight = m_lMenuItemHeight + 8
End If
Else
' problem.
End If

CopyMemory ByVal lParam, tMIS, LenB(tMIS)

Else
MeasureItem = CallOldWindowProc(m_hWnd, WM_MEASUREITEM, wParam, lParam)
End If
End Function
Private Function DrawItem(ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tDIS As DRAWITEMSTRUCT
Dim hBr As Long
Dim tR As RECT, tTR As RECT, tWR As RECT
Dim lhDC As Long
Dim hFntOld As Long
Dim tMII As MENUITEMINFO
Dim bRadioCheck As Boolean, bDisabled As Boolean, bChecked As Boolean, bHighlighted As Boolean
Dim lID As Long
Dim hFntS As Long, hFntSOld As Long

CopyMemory tDIS, ByVal lParam, LenB(tDIS)
If tDIS.CtlType = ODT_MENU Then
' Todo
' tDIS.hWndItem is the menu containing the item, tDIS.itemID is the wID

m_cMemDC.Width = tDIS.rcItem.right - tDIS.rcItem.left + 1
m_cMemDC.Height = tDIS.rcItem.bottom - tDIS.rcItem.top + 1
lhDC = m_cMemDC.hdc
hFntOld = SelectObject(lhDC, hFont)

LSet tR = tDIS.rcItem
OffsetRect tR, -tR.left, -tR.top

' Fill background:
tTR.right = m_cMemDC.Width
tTR.bottom = m_cMemDC.Height
hBr = CreateSolidBrush(TranslateColor(m_oMenuBackgroundColor))
FillRect lhDC, tTR, hBr
DeleteObject hBr

SetBkMode lhDC, TRANSPARENT

' Draw the text:
tMII.cbSize = LenB(tMII)
tMII.fMask = MIIM_TYPE Or MIIM_STATE Or MIIM_DATA
GetMenuItemInfo tDIS.hwndItem, tDIS.itemID, False, tMII

If (tMII.fType And MFT_SEPARATOR) = MFT_SEPARATOR Then
' Separator:
LSet tWR = tR
tWR.top = (tWR.bottom - tWR.top - 2) \ 2 + tWR.top
tWR.bottom = tWR.top + 2
InflateRect tWR, -8, 0
DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_TOP Or BF_BOTTOM
Else
' Text item:
bRadioCheck = ((tMII.fType And MFT_RADIOCHECK) = MFT_RADIOCHECK)

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

58 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
bDisabled = ((tMII.fState And MFS_DISABLED) = MFS_DISABLED)
bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
If bHighlighted Then
SetTextColor lhDC, TranslateColor(m_oActiveMenuColorOver)
Else
SetTextColor lhDC, TranslateColor(m_oActiveMenuColor)
End If

' Check:
If bChecked Then
LSet tWR = tR
InflateRect tWR, -4, -4
tWR.left = tWR.left + 2
tWR.right = tWR.left + (tWR.bottom - tWR.top + 1)
DrawEdge lhDC, tWR, BDR_SUNKENOUTER, BF_RECT

SelectObject lhDC, hFntOld
hFntSOld = SelectObject(lhDC, hFontSymbol)
If bRadioCheck Then
pDrawItem lhDC, "h", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
Else
pDrawItem lhDC, "b", tWR, bDisabled, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
End If
SelectObject lhDC, hFntSOld
hFntOld = SelectObject(lhDC, hFont)

End If

' Draw text:
LSet tWR = tR
tWR.left = 20 + 4
lID = tMII.dwItemData
If lID > 0 And lID <= m_iRestore Then
pDrawItem lhDC, m_sCaption(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
If Len(m_sShortCut(lID)) > 0 Then
tWR.left = tWR.left + m_lMenuTextSize(lID) + 4 + 4
pDrawItem lhDC, m_sShortCut(lID), tWR, bDisabled, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER
End If
End If

' Highlighted:
If bHighlighted And Not (bDisabled) Then
LSet tWR = tR
InflateRect tWR, -2, 0
DrawEdge lhDC, tWR, BDR_RAISEDINNER, BF_RECT
End If

End If

SelectObject lhDC, hFntOld

BitBlt tDIS.hdc, tDIS.rcItem.left, tDIS.rcItem.top, tDIS.rcItem.right - tDIS.rcItem.left + 1, tDIS.rcItem.bottom - tDIS.rcItem.top + 1, lhDC, 0, 0, vbSrcCopy

Else
DrawItem = CallOldWindowProc(m_hWnd, WM_DRAWITEM, wParam, lParam)
End If
End Function
Private Sub pDrawItem( _
ByVal lhDC As Long, _
ByVal sText As String, _
ByRef tR As RECT, _
ByVal bDisabled As Boolean, _
ByVal dtFlags As Long _
)
Dim tWR As RECT
LSet tWR = tR
If bDisabled Then
SetTextColor lhDC, TranslateColor(vb3DHighlight)
OffsetRect tWR, 1, 1
DrawText lhDC, sText, -1, tWR, dtFlags
SetTextColor lhDC, TranslateColor(vbButtonShadow)
OffsetRect tWR, -1, -1
DrawText lhDC, sText, -1, tWR, dtFlags
Else
DrawText lhDC, sText, -1, tWR, dtFlags
End If
End Sub
Private Sub pMouseMove()
Dim iMenu As Long
Dim iLastOver As Long
iMenu = MenuHitTest()
iLastOver = m_iOver
m_iOver = iMenu
'Debug.Print "Over:", m_iOver, iLastOver
If m_iOver <> iLastOver Then
' !Repaint!
'Debug.Print "Repaint"
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End If
If m_cTmr Is Nothing Then
Set m_cTmr = New CTimer
End If
If m_iOver < 1 And m_iDownOn = 0 Then
m_cTmr.Interval = 0
Else
If m_iDownOn > 0 Then
If GetAsyncKeyState(vbLeftButton) = 0 Then
m_iDownOn = 0
SendMessageLong m_hWnd, WM_NCPAINT, 0, 0
End If
End If
m_cTmr.Interval = 50
End If
End Sub

Private Sub m_cTmr_ThatTime()
pMouseMove
End Sub
' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
Optional hPal As Long = 0) As Long

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

59 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
If OleTranslateColor(clr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function

-------------
Option Explicit

' =========================================================================
' cNCCalcSize
'
' Copyright ?2000 Steve McMahon (steve@vbaccelerator.com)
'
' Allows you to significantly modify the title and
' borders for a window.
'
' -------------------------------------------------------------------------
' Visit vbAccelerator at http://vbaccelerator.com
' =========================================================================

Private Type POINTS
x As Integer
y As Integer
End Type
Private Type WINDOWPOS
hwnd As Long
hWndInsertAfter As Long
x As Long
y As Long
cx As Long
cy As Long
flags As Long
End Type
Private Type NCCALCSIZE_PARAMS
rgrc(0 To 2) As RECT
lppos As Long 'WINDOWPOS
End Type

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, lpsz2 As Any) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Any) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

60 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long

Private Declare Function DrawFrameControl Lib "user32" (ByVal lhDC As Long, tR As RECT, ByVal eFlag As Long, ByVal eStyle As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function DrawCaptionAPI Lib "user32" Alias "DrawCaption" (ByVal hwnd As Long, ByVal hdc As Long, pcRect As RECT, ByVal un As Long) As Long

Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

' mouseevent
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ' middle button down
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ' middle button up
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ' right button down
Private Const MOUSEEVENTF_RIGHTUP = &H10 ' right button up

' SysMetrics
Private Const SM_CXBORDER = 5
Private Const SM_CXDLGFRAME = 7
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CXFRAME = 32
Private Const SM_CXHSCROLL = 21
Private Const SM_CXVSCROLL = 2
Private Const SM_CYCAPTION = 4

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

61 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Private Const SM_CYFRAME = 33
Private Const SM_CYHSCROLL = 3
Private Const SM_CYMENU = 15
Private Const SM_CYSMSIZE = 31
Private Const SM_CXSMSIZE = 30

' DrawFrameControl:
Private Const DFC_CAPTION = 1
Private Const DFC_MENU = 2
Private Const DFC_SCROLL = 3
Private Const DFC_BUTTON = 4
'#if(WINVER >= =&H0500)
Private Const DFC_POPUPMENU = 5
'#endif /* WINVER >= =&H0500 */

Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DFCS_CAPTIONMIN = &H1
Private Const DFCS_CAPTIONMAX = &H2
Private Const DFCS_CAPTIONRESTORE = &H3
Private Const DFCS_CAPTIONHELP = &H4

Private Const DFCS_INACTIVE = &H100
Private Const DFCS_PUSHED = &H200
Private Const DFCS_CHECKED = &H400

' DrawEdge:
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8

Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

' Map WIndow Points
Private Const HWND_DESKTOP = 0

' Redraw window:
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8

' Sys colours:
Private Const COLOR_WINDOWFRAME = 6
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_ACTIVEBORDER = 10
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_INACTIVEBORDER = 11

' Window MEssages
Private Const WM_DESTROY = &H2
Private Const WM_SETTEXT = &HC
Private Const WM_ACTIVATEAPP = &H1C
Private Const WM_SETCURSOR = &H20
Private Const WM_CHILDACTIVATE = &H22
Private Const WM_STYLECHANGING = &H7C
Private Const WM_STYLECHANGED = &H7D
Private Const WM_NCCALCSIZE = &H83
Private Const WM_NCPAINT = &H85
Private Const WM_NCHITTEST = &H84
Private Const WM_NCACTIVATE = &H86
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCLBUTTONUP = &HA2
Private Const WM_NCLBUTTONDBLCLK = &HA3
Private Const WM_SYSCOMMAND = &H112

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

62 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Const WM_INITMENU = &H116
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_MDIGETACTIVE = &H229

' flags for DrawCaption
Private Const DC_ACTIVE = &H1
Private Const DC_SMALLCAP = &H2
Private Const DC_ICON = &H4
Private Const DC_TEXT = &H8
Private Const DC_INBUTTON = &H10
Private Const DC_GRADIENT = &H20

' WM_NCCALCSIZE return values;
Private Const WVR_ALIGNBOTTOM = &H40
Private Const WVR_ALIGNLEFT = &H20
Private Const WVR_ALIGNRIGHT = &H80
Private Const WVR_ALIGNTOP = &H10
Private Const WVR_HREDRAW = &H100
Private Const WVR_VALIDRECTS = &H400
Private Const WVR_VREDRAW = &H200
Private Const WVR_REDRAW = (WVR_HREDRAW Or WVR_VREDRAW)

' Window Long:
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = -4
Private Const GWL_HWNDPARENT = (-8)

'Window Styles:
Private Const WS_THICKFRAME = &H40000
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_BORDER = &H800000
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const CW_USEDEFAULT = &H80000000

' SetWIndowPos
Private Const HWND_TOPMOST = -1
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOREDRAW = &H8
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const SWP_NOZORDER = &H4

Implements ISubclass

Public Enum ECNCSysCommandConstants
SC_ARRANGE = &HF110&
SC_CLOSE = &HF060&
SC_MAXIMIZE = &HF030&
SC_MINIMIZE = &HF020&
SC_MOVE = &HF010&
SC_NEXTWINDOW = &HF040&
SC_PREVWINDOW = &HF050&
SC_RESTORE = &HF120&
SC_SIZE = &HF000&
End Enum

Public Enum ECNCHitTestConstants
HTBORDER = 18
HTBOTTOM = 15
HTBOTTOMLEFT = 16
HTBOTTOMRIGHT = 17
HTCAPTION = 2
HTCLIENT = 1
HTGROWBOX = 4
HTHSCROLL = 6
HTLEFT = 10
HTMAXBUTTON = 9
HTMENU = 5
HTMINBUTTON = 8
HTNOWHERE = 0
HTRIGHT = 11
HTSYSMENU = 3
HTTOP = 12
HTTOPLEFT = 13
HTTOPRIGHT = 14
HTVSCROLL = 7
End Enum
n

作者: 61.142.212.* 2005-10-28 21:33 　回复此发言

--------------------------------------------------------------------------------

63 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' Window handles:
Private m_hWnd As Long
Private m_hWndMDIClient As Long
Private m_bIsMDIChild As Boolean

' Menu handle
Private m_hMenu As Long
' App activate & window activation state:
Private m_bActive As Boolean
Private m_bAppActive As Boolean
' Is our MDI Child zoomed in or not?
Private m_bZoomedMDIChild As Boolean
' MemDC for title bar drawing:
Private m_hDC As Long
Private m_hBmp As Long
Private m_hBmpOld As Long
' Maximized MDI Child?
Private m_bState As Boolean
' Borders:
Private m_lLeft As Long, m_lTop As Long
Private m_lRight As Long, m_lBottom As Long
' Last HitTest result
Private m_eLastHT As ECNCHitTestConstants

Public Sub Redraw(hwnd As Long)
RedrawWindow hwnd, ByVal 0&, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_INTERNALPAINT Or RDW_ALLCHILDREN
End Sub
Public Sub Display(f As Object)
'f.Show
On Error Resume Next
f.Refresh
SetWindowPos m_hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOOWNERZORDER Or SWP_FRAMECHANGED
End Sub
Public Property Get WindowActive() As Boolean
WindowActive = m_bActive
End Property
Public Property Get AppActive() As Boolean
AppActive = m_bAppActive
End Property

Public Sub TitleBarMouseDown()
Dim tPS As POINTS
Dim tP As POINTAPI
GetCursorPos tP
tPS.x = tP.x: tPS.y = tP.y
ReleaseCapture
SendMessage m_hWnd, WM_NCLBUTTONDOWN, HTCAPTION, tPS
End Sub
Public Sub SysCommand(ByVal eCmd As ECNCSysCommandConstants)
PostMessage m_hWnd, WM_SYSCOMMAND, eCmd, 0
End Sub

Public Sub Attach(ByVal iTo As INCAreaModifier)
Dim lhDC As Long

Detach

m_hWnd = iTo.hwnd
m_hMenu = GetMenu(m_hWnd)

m_bIsMDIChild = IsMDIChildForm(m_hWnd)

' Allows us to remove menu bar, caption etc:
AttachMessage Me, m_hWnd, WM_NCCALCSIZE
' Handle drawing borders, caption etc ourselves:
AttachMessage Me, m_hWnd, WM_NCPAINT
' Win redraws caption during NCACTIVATE:
AttachMessage Me, m_hWnd, WM_NCACTIVATE
' On NC Button Down, Win redraws the min/max/close buttons:
AttachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
' Check for button up so we can notify client:
AttachMessage Me, m_hWnd, WM_NCLBUTTONUP
' on NC double click, Win redraws the min/max/close buttons:
AttachMessage Me, m_hWnd, WM_NCLBUTTONDBLCLK
' Allows us to use the default implementations
' for hittest events:
AttachMessage Me, m_hWnd, WM_NCHITTEST
' Hack:
AttachMessage Me, m_hWnd, WM_SETCURSOR
' On SysMenu Show, Win redraws the min/max/close buttons:
AttachMessage Me, m_hWnd, WM_INITMENU
AttachMessage Me, m_hWnd, WM_INITMENUPOPUP
' On ChangeStyle, Win redraws the entire caption:
AttachMessage Me, m_hWnd, WM_STYLECHANGED
' On SetText, Win redraws the entire caption:
AttachMessage Me, m_hWnd, WM_SETTEXT
' Checking for activateapp:
AttachMessage Me, m_hWnd, WM_ACTIVATEAPP
' EnterMenuLoop
AttachMessage Me, m_hWnd, WM_ENTERMENULOOP
' ExitMenuLoop
AttachMessage Me, m_hWnd, WM_EXITMENULOOP

If m_bIsMDIChild Then
AttachMessage Me, m_hWnd, WM_SIZE
End If

' So we can automatically detach ourselves when the parent closes:

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

64 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
AttachMessage Me, m_hWnd, WM_DESTROY

lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
m_hDC = CreateCompatibleDC(lhDC)
m_hBmp = CreateCompatibleBitmap(lhDC, Screen.Width \ Screen.TwipsPerPixelX, GetSystemMetrics(SM_CYCAPTION) * 4)
DeleteDC lhDC
m_hBmpOld = SelectObject(m_hDC, m_hBmp)

m_hWndMDIClient = FindWindowEx(m_hWnd, 0, "MDIClient", ByVal 0&)

SetProp m_hWnd, "vbalCNCImplementation", ObjPtr(iTo)

AttachKeyboardHook Me
End Sub
Public Property Get hMenu() As Long
hMenu = m_hMenu
End Property
Public Sub Detach()
DetachKeyboardHook Me
If m_hWnd <> 0 Then
DetachMessage Me, m_hWnd, WM_NCCALCSIZE
DetachMessage Me, m_hWnd, WM_NCPAINT
DetachMessage Me, m_hWnd, WM_NCACTIVATE
DetachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
DetachMessage Me, m_hWnd, WM_NCLBUTTONUP
DetachMessage Me, m_hWnd, WM_NCLBUTTONDBLCLK
DetachMessage Me, m_hWnd, WM_NCHITTEST

DetachMessage Me, m_hWnd, WM_SETCURSOR

DetachMessage Me, m_hWnd, WM_INITMENU
DetachMessage Me, m_hWnd, WM_INITMENUPOPUP

DetachMessage Me, m_hWnd, WM_STYLECHANGED
DetachMessage Me, m_hWnd, WM_SETTEXT

DetachMessage Me, m_hWnd, WM_ACTIVATEAPP

DetachMessage Me, m_hWnd, WM_ENTERMENULOOP
DetachMessage Me, m_hWnd, WM_EXITMENULOOP

If m_bIsMDIChild Then
DetachMessage Me, m_hWnd, WM_SIZE
m_bIsMDIChild = False
End If

DetachMessage Me, m_hWnd, WM_DESTROY
End If
If m_hDC <> 0 Then
If m_hBmpOld <> 0 Then
SelectObject m_hDC, m_hBmp
m_hBmpOld = 0
End If
If m_hBmp <> 0 Then
DeleteObject m_hBmp
m_hBmp = 0
End If
If m_hDC <> 0 Then
DeleteDC m_hDC
m_hDC = 0
End If
End If
RemoveProp m_hWnd, "vbalCNCImplementation"
m_hWnd = 0
m_hWndMDIClient = 0
m_hMenu = 0
End Sub

Friend Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long
Dim Implementation As INCAreaModifier
If GetImplementation(Implementation) Then
AltKeyAccelerator = Implementation.AltKeyAccelerator(vKey)
End If
End Function

Private Sub pShowMDIButtons(ByVal hwnd As Long, ByVal bState As Boolean)
m_bState = bState
End Sub

Private Sub MyMoveWindow()
Dim tPInit As POINTAPI
Dim tPLast As POINTAPI
Dim tP As POINTAPI
Dim tR As RECT
Dim hWndParent As Long
Dim tWRInit As RECT
Dim dx As Long, dy As Long

GetWindowRect m_hWnd, tR
hWndParent = GetParent(m_hWnd)
If Not hWndParent = 0 Then
MapWindowPoints HWND_DESKTOP, hWndParent, tR, 2
End If
GetCursorPos tPInit
LSet tPLast = tPInit
Do While Not (GetAsyncKeyState(vbLeftButton) = 0) And m_bActive
GetCursorPos tP
If tP.x <> tPLast.x Or tP.y <> tPLast.y Then
' Moved:
dx = tP.x - tPLast.x
dy = tP.y - tPLast.y
SetWindowPos m_hWnd, 0, tR.left + dx, tR.top + dy, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOOWNERZORDER
LSet tPLast = tP
GetWindowRect m_hWnd, tR
If Not hWndParent = 0 Then
MapWindowPoints HWND_DESKTOP, hWndParent, tR, 2
End If
End If
DoEvents
Sleep 1
Loop

End Sub

Private Sub Class_Terminate()
Detach
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

65 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
'
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse

Select Case CurrentMessage
Case WM_NCPAINT, WM_NCLBUTTONDOWN, _
WM_NCLBUTTONDBLCLK, _
WM_INITMENUPOPUP, WM_INITMENU, _
WM_SETCURSOR, WM_CHILDACTIVATE, _
WM_STYLECHANGED, WM_SETTEXT, _
WM_NCHITTEST, WM_SIZE, _
WM_ENTERMENULOOP, WM_EXITMENULOOP
ISubclass_MsgResponse = emrConsume
Case Else
' ActiveApp, Destroy:
ISubclass_MsgResponse = emrPreprocess
End Select

End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tNCR As NCCALCSIZE_PARAMS
Dim tWP As WINDOWPOS
Dim tP As POINTAPI
Dim tR As RECT
Dim lhWnd As Long
Dim lpfMaximised As Long
Dim lPtr As Long
Dim hdc As Long
Dim lStyle As Long
Dim eHt As ECNCHitTestConstants
Static s_dx As Long
Static s_dy As Long
Dim bCanSize As Boolean
Dim Implementation As INCAreaModifier
Dim bHandled As Boolean
Static s_bNoStyleChangeProcessing As Boolean
Static s_bChildActivate As Boolean

Select Case iMsg

Case WM_DESTROY
' Goodbye!
Detach

Case WM_NCPAINT

' Due to processing elsewhere in this subclass, we
' might inadvertently be drawing when the window
' is being closed or invisible. Check before
' drawing:
If Not (IsWindowVisible(hwnd) = 0) Then
m_bZoomedMDIChild = (IsMDIChildForm(hwnd) And (IsZoomed(hwnd) <> 0))
If m_bZoomedMDIChild Then
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
Else
' Get the non-client DC to draw in:
hdc = GetWindowDC(m_hWnd)

GetWindowRect m_hWnd, tR
OffsetRect tR, -tR.left, -tR.top

If GetImplementation(Implementation) Then
Implementation.NCPaint hdc, tR.left, tR.top, tR.right, tR.bottom
Else
DefaultNCPaint hdc, tR.left, tR.top, tR.right, tR.bottom
End If

ReleaseDC m_hWnd, hdc
End If
End If

Case WM_NCHITTEST

If GetImplementation(Implementation) Then
eHt = pGetHitTestCode()
m_eLastHT = eHt
If eHt = HTMENU Then
' Cannot allow windows to have this; if you
' mouse down on menu or caption then windows
' redraws the caption on top...
ISubclass_WindowProc = HTCLIENT
Else
ISubclass_WindowProc = eHt
End If

Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

Case WM_NCLBUTTONDOWN
'
' a hack.
'
' Win suspends when we do a NC Button down. It also
' redraws the min/max/close buttons. We can force them
' to go away by moving the mouse
'
If s_dx = 0 Then s_dx = 1
If s_dy = 0 Then s_dy = 1
s_dx = -1 * s_dx: s_dy = -1 * s_dy
mouse_event MOUSEEVENTF_MOVE, s_dx, s_dy, 0, 0

' We cannot allow Windows to do the default HTCAPTION action,
' because it redraws the caption during the move. THerefore
' swallow HTCAPTION events and reimplement window moving
' ourselves:
wParam = pGetHitTestCode()
If GetImplementation(Implementation) Then
If m_bActive Then
If m_eLastHT = HTCAPTION Then
MyMoveWindow
Exit Function
End If
Else
If m_eLastHT = HTCAPTION Then
SetForegroundWindow m_hWnd

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

66 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
MyMoveWindow
Exit Function
End If
End If

GetCursorPos tP
GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
hdc = GetWindowDC(m_hWnd)
Implementation.NCMouseDown tP.x, tP.y, bHandled, hdc, tR.left, tR.top, tR.right, tR.bottom
ReleaseDC m_hWnd, hdc
If bHandled Then
Exit Function
End If

End If

ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_NCLBUTTONUP
If GetImplementation(Implementation) Then
GetCursorPos tP
GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
hdc = GetWindowDC(m_hWnd)
Implementation.NCMouseDown tP.x, tP.y, bHandled, hdc, tR.left, tR.top, tR.right, tR.bottom
ReleaseDC m_hWnd, hdc
Implementation.NCMouseUp tP.x, tP.y, hdc, tR.left, tR.top, tR.right, tR.bottom
End If

Case WM_SETCURSOR
'
' a Very Nasty Hack :)
' discovered by watching NeoPlanet and MSOffice
' in Spy++
'
' Without this, Win will redraw caption areas and
' min/max/close buttons whenever the mouse is released
' following a NC mouse down.
'
s_bNoStyleChangeProcessing = True
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
SetWindowLong m_hWnd, GWL_STYLE, lStyle And Not WS_VISIBLE
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
If GetMenu(m_hWnd) <> 0 Then
SetMenu m_hWnd, 0
End If
SetWindowLong m_hWnd, GWL_STYLE, lStyle
s_bNoStyleChangeProcessing = False

Case WM_INITMENU
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_CHILDACTIVATE
If Not s_bChildActivate Then
s_bChildActivate = True
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
s_bChildActivate = False
End If

Case WM_SIZE
'
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_INITMENUPOPUP
'
' During a WM_INITMENUPOPUP, the system redraws the
' min/max/close buttons.

' Check HiWord of lParam to see whether this is
' a SysMenu:
If Not (lParam And &HFFFF0000) = 0 Then
' Sys Menu:
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
Else
' App Menu:
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
If GetImplementation(Implementation) Then
Implementation.InitMenuPopup wParam, lParam
End If
End If

Case WM_ENTERMENULOOP, WM_EXITMENULOOP
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
If iMsg = WM_EXITMENULOOP Then
If GetImplementation(Implementation) Then
Implementation.ExitMenuLoop
End If
End If

Case WM_SETTEXT, WM_STYLECHANGED, WM_NCLBUTTONDBLCLK
'
' The whole title bar is repainted by the defwindowproc.

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

67 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' Therefore redraw once complete:
If Not s_bNoStyleChangeProcessing Then
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

Case WM_NCCALCSIZE
'
' No Hacks!
'
' This simply tells windows to modify the client
' area to the appropriate size:
'

' First set the zoomed MDI Child flag:
m_bZoomedMDIChild = (IsMDIChildForm(hwnd) And (IsZoomed(hwnd) <> 0))
If wParam <> 0 Then

' Get the structure pointed to by lParam:
CopyMemory tNCR, ByVal lParam, Len(tNCR)
CopyMemory tWP, ByVal tNCR.lppos, Len(tWP)

'pDebugCalcSize tNCR
With tNCR.rgrc(0)
' Set these
.left = tWP.x
.top = tWP.y
.right = tWP.x + tWP.cx
.bottom = tWP.y + tWP.cy

' Defaults
m_lLeft = GetSystemMetrics(SM_CXFRAME)
m_lRight = m_lLeft
m_lTop = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME)
m_lBottom = GetSystemMetrics(SM_CYFRAME)

' If the window in question is an MDI child, then we
' ant to ensure that the standard settings get sent
' back to windows: to prevent drawing additional borders,
' which aren't required:
If Not m_bZoomedMDIChild Then
' If the implementation is valid then request the
' physical size of the title bar and borders:
If GetImplementation(Implementation) Then
Implementation.GetLeftMarginWidth m_lLeft
Implementation.GetTopMarginHeight m_lTop
Implementation.GetRightMarginWidth m_lRight
Implementation.GetBottomMarginHeight m_lBottom
End If
End If

' Set our physical left/top/right/bottom values:
.left = .left + m_lLeft
.top = .top + m_lTop
.right = .right - m_lRight
.bottom = .bottom - m_lBottom
End With

' Return the new client area size to windows:
LSet tNCR.rgrc(1) = tNCR.rgrc(0)
CopyMemory ByVal lParam, tNCR, Len(tNCR)
ISubclass_WindowProc = WVR_VALIDRECTS

Else
' lParam points to a rectangle
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

' Check for the active window:
'lPtr = VarPtr(lpfMaximised)
'If Not m_hWndMDIClient = 0 Then
' lhWnd = SendMessageLong(m_hWndMDIClient, WM_MDIGETACTIVE, 0, lPtr)
' pShowMDIButtons lhWnd, (lpfMaximised <> 0)
'End If

Case WM_NCACTIVATE
'
' When we get a NC Activate The title bar is
' being redrawn to show active or inactive states.
'
' This processing ensures the title bar is updated
' correctly following state change:
'

' We must call the defwindowproc otherwise VB goes
' funny. This draws a full titlebar:
m_bActive = Not (wParam = 0)
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)

' Now fix it:
ISubclass_WindowProc m_hWnd, WM_NCPAINT, 0, 0

Case WM_ACTIVATEAPP
'
' This is for detecting which app is active
'
m_bAppActive = Not (wParam = 0)

End Select

End Function
Private Function IsMDIChildForm(ByVal hwnd As Long) As Boolean
Dim hWndP As Long
Dim sBuf As String
Dim iPos As Long
hWndP = GetParent(hwnd)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

68 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
sBuf = String$(260, 0)
GetClassName hWndP, sBuf, 259
iPos = InStr(sBuf, vbNullChar)
If iPos > 1 Then
If left$(sBuf, iPos - 1) = "MDIClient" Then
IsMDIChildForm = True
End If
End If
End Function
Private Function pGetHitTestCode() As ECNCHitTestConstants
Dim lStyle As Long
Dim bCanSize As Boolean
Dim Implementation As INCAreaModifier
Dim eHt As ECNCHitTestConstants
Dim tP As POINTAPI
Dim tR As RECT

If GetImplementation(Implementation) Then
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
bCanSize = ((lStyle And WS_SIZEBOX) = WS_SIZEBOX)
eHt = HTCLIENT
GetCursorPos tP

GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
eHt = HTCLIENT
If Not (PtInRect(tR, tP.x, tP.y) = 0) Then
' Left
If tP.x <= m_lLeft Then
If tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOPLEFT
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOMLEFT
End If
Else
If bCanSize Then
eHt = HTLEFT
End If
End If
' Right
ElseIf tP.x >= tR.right - m_lRight Then
If tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOPRIGHT
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOMRIGHT
End If
Else
If bCanSize Then
eHt = HTRIGHT
End If
End If
' Top/Bottom?
ElseIf tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOP
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOM
End If
' Caption/Menu
ElseIf tP.y <= m_lTop Then
' We assume for default that the caption
' is the same as the system caption etc:
If tP.y <= m_lBottom + GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTCAPTION
If tP.x <= GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTSYSMENU
Else
' todo min/max/close btns
End If
ElseIf tP.y > m_lBottom + GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTCLIENT
End If
End If
End If
Implementation.HitTest tP.x, tP.y, eHt
End If
pGetHitTestCode = eHt

End Function
Public Sub DefaultNCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim tR As RECT, tTR As RECT, tSR As RECT, tBR As RECT
Dim lFlag As Long
Dim hBr As Long, hBrButton As Long

tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom
LSet tBR = tR

If m_bActive Then
lFlag = DC_ACTIVE
hBrButton = GetSysColorBrush(COLOR_ACTIVECAPTION)
hBr = GetSysColorBrush(COLOR_ACTIVEBORDER)
Else
hBrButton = GetSysColorBrush(COLOR_INACTIVECAPTION)
hBr = GetSysColorBrush(COLOR_INACTIVEBORDER)
End If

' Titlebar area:
' Draw the part between the edge & the client:
LSet tTR = tR
' left edge
tTR.top = GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.bottom - GetSystemMetrics(SM_CYFRAME)
tTR.right = GetSystemMetrics(SM_CXFRAME)
FillRect hdc, tTR, hBr
' top
LSet tTR = tR
tTR.bottom = GetSystemMetrics(SM_CYFRAME)
FillRect hdc, tTR, hBr
' right
LSet tTR = tR
tTR.top = GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.bottom - GetSystemMetrics(SM_CYFRAME)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

69 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
tTR.left = tTR.right - GetSystemMetrics(SM_CXFRAME)
FillRect hdc, tTR, hBr
' bottom
LSet tTR = tR
tTR.top = tTR.bottom - GetSystemMetrics(SM_CYFRAME)
FillRect hdc, tTR, hBr

' Draw the caption into the caption area:

' top bit under titlebar:
LSet tTR = tR
tTR.top = GetSystemMetrics(SM_CXFRAME) + GetSystemMetrics(SM_CYCAPTION) - 1
tTR.bottom = tTR.top + 1
FillRect hdc, tTR, hBr
DeleteObject hBr

' Draw the titlebar into a work DC to prevent flicker:
lFlag = lFlag Or DC_ICON Or DC_TEXT
LSet tTR = tR
tTR.left = tTR.left + GetSystemMetrics(SM_CXFRAME)
tTR.right = tTR.right - GetSystemMetrics(SM_CXFRAME)
tTR.top = tTR.top + GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.top + GetSystemMetrics(SM_CYCAPTION) - 1
LSet tR = tTR
OffsetRect tR, -tR.left, -tR.top
LSet tSR = tR
tSR.right = tSR.right - (tR.bottom - tR.top) * 3 - 2
DrawCaptionAPI m_hWnd, m_hDC, tSR, lFlag

' Draw the titlebar buttons:
tSR.left = tSR.right
tSR.right = tR.right
FillRect m_hDC, tSR, hBrButton
DeleteObject hBrButton

InflateRect tR, 0, -2
tR.right = tR.right - 2
tR.left = tR.right - (tR.bottom - tR.top) - 2
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONCLOSE
OffsetRect tR, -(tR.right - tR.left + 2), 0
If IsZoomed(m_hWnd) Then
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONRESTORE
Else
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONMAX
End If
OffsetRect tR, -(tR.right - tR.left), 0
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONMIN

' Finished drawing the NC area:
BitBlt hdc, tTR.left, tTR.top, tTR.right - tTR.left, tTR.bottom - tTR.top, m_hDC, 0, 0, vbSrcCopy

' Edge 3d
DrawEdge hdc, tBR, EDGE_RAISED, BF_RECT

End Sub

Public Function GetImplementation(iTo As INCAreaModifier) As Boolean
Dim lPtr As Long
lPtr = GetProp(m_hWnd, "vbalCNCImplementation")
If Not lPtr = 0 Then
Dim iToTemp As INCAreaModifier
CopyMemory iToTemp, lPtr, 4
Set iTo = iToTemp
CopyMemory iToTemp, 0&, 4
GetImplementation = True
End If
End Function

#If 0 = 1 Then
Private Sub pDebugCalcSize(ByRef tNCR As NCCALCSIZE_PARAMS)
Dim i As Long
Dim tWP As WINDOWPOS
' Use to show what is happening:
With tNCR
For i = 1 To 3
With .rgrc(i - 1)
Debug.Print .left, .top, .right, .bottom
End With
Next i
CopyMemory tWP, ByVal .lppos, Len(tWP)
With tWP
Debug.Print .x, .y, .x + .cx, .y + .cy
End With

End With
End Sub
#End If

--------------
Option Explicit

' APIs
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

70 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const CLR_INVALID = -1

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

' Font:
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

71 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Private Const LOGPIXELSY = 90

Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_SYSCOMMAND = &H112

' Implementation
Implements INCAreaModifier

Private Enum ECNCButtonStates
up
Down
End Enum

Private m_cNCS As cNCCalcSize
Private m_hWnd As Long

' MemDCs for storing GFX
Private m_cBorder As cMemDC
Private m_cCaption As cMemDC

' MemDC for building caption:
Private m_cFF As cMemDC
' and l/r borders
Private m_cFFB As cMemDC
' Menu bar:
Private m_cMenu As cMenuBar

Private m_oActiveCaptionColor As OLE_COLOR
Private m_oInActiveCaptionColor As OLE_COLOR
Private m_fnt As IFont

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR
Private m_oMenuBackgroundColor As OLE_COLOR
Private m_fntMenu As IFont

Private m_lButtonWidth As Long
Private m_lButtonHeight As Long
Private m_lActiveLeftEnd As Long
Private m_lActiveRightStart As Long
Private m_lActiveRightEnd As Long
Private m_lInactiveOffset As Long

Private m_tBtn(0 To 2) As RECT
Private m_bMaximise As Boolean
Private m_bMinimise As Boolean
Private m_bClose As Boolean
Private m_bMouseDownMinimise As Boolean
Private m_bMouseDownMaximise As Boolean
Private m_bMouseDownClose As Boolean

Public Sub Detach()
Dim lMenu As Long
If Not m_cNCS Is Nothing Then
m_cNCS.Detach
End If
If Not m_cMenu Is Nothing Then
lMenu = m_cMenu.hMenu
m_cMenu.Detach
End If
If Not (lMenu = 0) Then
SetMenu m_hWnd, lMenu
End If

End Sub

Public Sub Attach( _
f As Object, _
PicCaption As StdPicture, _
PicBorder As StdPicture, _
lButtonWidth As Long, _
lButtonHeight As Long, _
lActiveLeftEnd As Long, _
lActiveRightStart As Long, _
lActiveRightEnd As Long, _
lInactiveOffset As Long _
)
LockWindowUpdate f.hwnd
Detach

' Store the pictures:
Set m_cCaption = New cMemDC

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

72 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
m_cCaption.CreateFromPicture PicCaption
Set m_cBorder = New cMemDC
m_cBorder.CreateFromPicture PicBorder

' FF drawing
Set m_cFF = New cMemDC
Set m_cFFB = New cMemDC

' Store passed in vars:
m_lButtonWidth = lButtonWidth
m_lButtonHeight = lButtonHeight

m_lActiveLeftEnd = lActiveLeftEnd
m_lActiveRightStart = lActiveRightStart
m_lActiveRightEnd = lActiveRightEnd
m_lInactiveOffset = lInactiveOffset

' Store hWNd:
m_hWnd = f.hwnd

' Menu:
Set m_cMenu = New cMenuBar
m_cMenu.Attach m_hWnd
m_cMenu.Font = m_fntMenu
m_cMenu.SetColors m_oActiveMenuColor, m_oActiveMenuColorOver, m_oInActiveMenuColor, m_oMenuBackgroundColor
m_cMenu.CaptionHeight = m_cCaption.Height

' Start non-client modification:
Set m_cNCS = New cNCCalcSize
m_cNCS.Attach Me
m_cNCS.Display f

If IsWindowVisible(m_hWnd) <> 0 Then
SetForegroundWindow m_hWnd
SetFocusAPI m_hWnd
SendMessageLong m_hWnd, WM_NCACTIVATE, 1, 0
End If

LockWindowUpdate 0

End Sub
Public Property Get MenuBackgroundColor() As OLE_COLOR
MenuBackgroundColor = m_oMenuBackgroundColor
End Property
Public Property Let MenuBackgroundColor(ByVal oColor As OLE_COLOR)
m_oMenuBackgroundColor = oColor
End Property
Public Property Get ActiveCaptionColor() As OLE_COLOR
ActiveCaptionColor = m_oActiveCaptionColor
End Property
Public Property Let ActiveCaptionColor(ByVal oColor As OLE_COLOR)
m_oActiveCaptionColor = oColor
End Property
Public Property Get InActiveCaptionColor() As OLE_COLOR
InActiveCaptionColor = m_oInActiveCaptionColor
End Property
Public Property Let InActiveCaptionColor(ByVal oColor As OLE_COLOR)
m_oInActiveCaptionColor = oColor
End Property
Public Property Get CaptionFont() As IFont
Set CaptionFont = m_fnt
End Property
Public Property Let CaptionFont(iFnt As IFont)
Set m_fnt = iFnt
End Property
Public Property Get MenuFont() As IFont
Set MenuFont = m_fntMenu
End Property
Public Property Let MenuFont(iFnt As IFont)
Set m_fntMenu = iFnt
End Property
Public Property Get ActiveMenuColor() As OLE_COLOR
ActiveMenuColor = m_oActiveMenuColor
End Property
Public Property Get ActiveMenuColorOver() As OLE_COLOR
ActiveMenuColorOver = m_oActiveMenuColorOver
End Property
Public Property Get InActiveMenuColor() As OLE_COLOR
InActiveMenuColor = m_oInActiveMenuColor
End Property
Public Property Let ActiveMenuColor(oColor As OLE_COLOR)
m_oActiveMenuColor = oColor
End Property
Public Property Let ActiveMenuColorOver(oColor As OLE_COLOR)
m_oActiveMenuColorOver = oColor
End Property
Public Property Let InActiveMenuColor(oColor As OLE_COLOR)
m_oInActiveMenuColor = oColor
End Property
Private Sub Class_Initialize()
m_oActiveCaptionColor = &HCCCCCC
m_oInActiveCaptionColor = &H999999
m_oActiveMenuColor = &H0&
m_oActiveMenuColorOver = &H0&
m_oInActiveMenuColor = &H808080
m_oMenuBackgroundColor = &HFFFFFF
Set m_fnt = New StdFont
m_fnt.Name = "MS Sans Serif"
Set m_fntMenu = New StdFont
m_fntMenu.Name = "MS Sans Serif"
End Sub

Private Sub Class_Terminate()

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

73 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
'
End Sub

Private Function INCAreaModifier_AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long
INCAreaModifier_AltKeyAccelerator = m_cMenu.AltKeyAccelerator(vKey)
End Function

Private Sub INCAreaModifier_ExitMenuLoop()
m_cMenu.pRestoreList
End Sub

Private Sub INCAreaModifier_HitTest(ByVal x As Long, ByVal y As Long, eHitTest As ECNCHitTestConstants)
Dim bMouseOverClose As Boolean
Dim bMouseOverMaximise As Boolean
Dim bMouseOverMinimise As Boolean
Dim bBtnMouseDown As Boolean
Dim hdc As Long

'
Dim tR As RECT
tR.left = 12: tR.top = 11: tR.right = 42: tR.bottom = 43
If PtInRect(tR, x, y) <> 0 Then
eHitTest = HTSYSMENU
Exit Sub
End If

' Code for working out whether in the buttons or not:
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverClose = True
Else
bMouseOverClose = False
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverMaximise = True
Else
bMouseOverMaximise = False
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverMinimise = True
Else
bMouseOverMinimise = False
End If
End If

hdc = GetWindowDC(m_hWnd)

bBtnMouseDown = GetAsyncKeyState(vbLeftButton)
If m_bClose Then
If Not (m_bMouseDownClose = bMouseOverClose) Then
If bMouseOverClose And bBtnMouseDown And m_bMouseDownClose Then
DrawButton hdc, 0, Down
Else
DrawButton hdc, 0, up
End If
End If
End If
If m_bMaximise Then
If Not (m_bMouseDownMaximise = bMouseOverMaximise) Then
If bMouseOverMaximise And bBtnMouseDown And m_bMouseDownMaximise Then
DrawButton hdc, 1, Down
Else
DrawButton hdc, 1, up
End If
End If
End If
If m_bMinimise Then
If Not (m_bMouseDownMinimise = bMouseOverMinimise) Then
If bMouseOverMinimise And bBtnMouseDown And m_bMouseDownMinimise Then
DrawButton hdc, 2, Down
Else
DrawButton hdc, 2, up
End If
End If
End If
ReleaseDC m_hWnd, hdc

End Sub

Private Property Get INCAreaModifier_hWnd() As Long
INCAreaModifier_hWnd = m_hWnd
End Property

Private Sub INCAreaModifier_InitMenuPopup(ByVal wParam As Long, ByVal lParam As Long)
' Set all the menu items to Owner-Draw:
' wParam = hMenu
m_cMenu.OwnerDrawMenu wParam
End Sub

Private Sub INCAreaModifier_NCMouseDown(ByVal x As Long, ByVal y As Long, bHandled As Boolean, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
' Redraw close button pressed:
DrawButton hdc, 0, Down
m_bMouseDownClose = True
bHandled = True
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
' Redraw maximise button pressed:
DrawButton hdc, 1, Down
m_bMouseDownMaximise = True
bHandled = True
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
' Redraw minimise button pressed:
DrawButton hdc, 2, Down
m_bMouseDownMinimise = True

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

74 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
bHandled = True
End If
End If

End Sub

Private Sub INCAreaModifier_NCMouseUp(ByVal x As Long, ByVal y As Long, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim lStyle As Long
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
If m_bMouseDownClose Then
m_cNCS.SysCommand SC_CLOSE
End If
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
If m_bMouseDownMaximise Then
' Redraw maximise button pressed:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
If ((lStyle And WS_MAXIMIZE) = WS_MAXIMIZE) Then
m_cNCS.SysCommand SC_RESTORE
Else
m_cNCS.SysCommand SC_MAXIMIZE
End If
End If
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
If m_bMouseDownMinimise Then
m_cNCS.SysCommand SC_MINIMIZE
End If
End If
End If
DrawButton hdc, 0, up
DrawButton hdc, 1, up
DrawButton hdc, 2, up

m_bMouseDownMinimise = False
m_bMouseDownMaximise = False
m_bMouseDownClose = False

End Sub
Private Sub DrawButton(ByVal hdc As Long, ByVal iIndex As Long, ByVal eState As ECNCButtonStates)
Dim lY As Long
Dim lStyle As Long
If eState = Down Then
lY = m_lButtonHeight
Else
lY = 0
End If
Select Case iIndex
Case 0
If m_bClose Then
BitBlt hdc, m_tBtn(0).left, m_tBtn(0).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 241, lY, vbSrcCopy
End If
Case 1
If m_bMaximise Then
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
If ((lStyle And WS_MAXIMIZE) = WS_MAXIMIZE) Then
BitBlt hdc, m_tBtn(1).left, m_tBtn(1).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth, lY, vbSrcCopy
Else
BitBlt hdc, m_tBtn(1).left, m_tBtn(1).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth * 2, lY, vbSrcCopy
End If
End If
Case 2
If m_bMinimise Then
BitBlt hdc, m_tBtn(2).left, m_tBtn(2).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth * 3, lY, vbSrcCopy
End If
End Select
End Sub

Private Sub INCAreaModifier_NCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim lX As Long, lXE As Long
Dim lY As Long
Dim lW As Long, lH As Long, lRW As Long
Dim lT As Long
Dim lSrcDC As Long, lSrcX As Long, lSrcY As Long
Dim lOrgX As Long
Dim bNoMiddle As Boolean
Dim tR As RECT
Dim sCaption As String
Dim lLen As Long
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lStyle As Long
Dim lhDC As Long, lhDCB As Long
Dim hFntMenu As Long

LockWindowUpdate hdc
' Here we do the work!
tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom

' Ensure mem DCs are big enough to draw into:
m_cFF.Width = tR.right - tR.left + 1
m_cFF.Height = m_cCaption.Height
lhDC = m_cFF.hdc

m_cFFB.Width = m_cBorder.Width * 2
m_cFFB.Height = tR.bottom - tR.top + 1
lhDCB = m_cFFB.hdc

pOLEFontToLogFont m_fnt, hdc, tLF
If m_cNCS.WindowActive Then
tLF.lfWeight = FW_BOLD
End If
hFnt = CreateFontIndirect(tLF)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

75 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
hFntOld = SelectObject(lhDC, hFnt)

If m_cNCS.WindowActive Then
lOrgX = 0
Else
lOrgX = m_lInactiveOffset
End If
' Draw the caption
BitBlt lhDC, lLeft, lTop, lLeft + m_lActiveLeftEnd, m_cCaption.Height, m_cCaption.hdc, lOrgX, 0, vbSrcCopy
lRW = (m_lActiveRightEnd - m_lActiveRightStart + 1)
lXE = lRight - lRW + 1
If lXE < lLeft + lRW Then
lXE = lLeft + lRW
bNoMiddle = True
End If
BitBlt lhDC, lXE, lTop, lRW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveRightStart, 0, vbSrcCopy

' Buttons:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
m_bMaximise = ((lStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX)
m_bMinimise = ((lStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX)
m_bClose = ((lStyle And WS_SYSMENU) = WS_SYSMENU)
m_tBtn(0).left = lXE + lRW - m_cBorder.Height + 4
If m_bClose Then
m_tBtn(0).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(0).top = lTop + 5
m_tBtn(0).right = m_tBtn(0).left + m_lButtonWidth + 1
m_tBtn(0).bottom = m_tBtn(0).top + m_lButtonHeight
DrawButton lhDC, 0, up
End If
If m_bMaximise Then
m_tBtn(1).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(1).top = lTop + 5
m_tBtn(1).right = m_tBtn(1).left + m_lButtonWidth + 1
m_tBtn(1).bottom = m_tBtn(1).top + m_lButtonHeight
DrawButton lhDC, 1, up
Else
m_tBtn(1).left = m_tBtn(0).left
End If
If m_bMinimise Then
m_tBtn(2).left = m_tBtn(1).left - (m_lButtonWidth + 1)
m_tBtn(2).top = lTop + 5
m_tBtn(2).right = m_tBtn(2).left + (m_lButtonWidth + 1)
m_tBtn(2).bottom = m_tBtn(2).top + m_lButtonHeight
DrawButton lhDC, 2, up
End If

' Fill in:
lX = lLeft + 90
Do
lW = 52
If lX + 52 > lXE Then
lW = lXE - lX
End If
BitBlt lhDC, lX, 0, lW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveLeftEnd + 1, 0, vbSrcCopy
lX = lX + 52
Loop While lX < lXE

If Not bNoMiddle Then

' Draw the caption:
SetBkMode lhDC, TRANSPARENT
If m_cNCS.WindowActive Then
SetTextColor lhDC, TranslateColor(m_oActiveCaptionColor)
Else
SetTextColor lhDC, TranslateColor(m_oInActiveCaptionColor)
End If
lLen = GetWindowTextLength(m_hWnd)
If lLen > 0 Then
tR.left = lLeft + 92
tR.right = lRight - 96
tR.top = m_cBorder.Height + 1
tR.bottom = tR.top + (m_cCaption.Height - m_cBorder.Height - 2) \ 2
sCaption = String$(lLen + 1, 0)
GetWindowText m_hWnd, sCaption, lLen + 1
DrawText lhDC, sCaption, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_NOPREFIX
End If

End If

' Menu:
m_cMenu.hMenu = m_cNCS.hMenu
lW = lXE - m_lActiveLeftEnd
tLF.lfWeight = FW_NORMAL
hFntMenu = CreateFontIndirect(tLF)
m_cMenu.Render hFntMenu, lhDC, m_lActiveLeftEnd, m_cCaption.Height \ 2, lW, m_cCaption.Height \ 2, -m_cCaption.Height \ 2 + 2
DeleteObject hFntMenu

BitBlt hdc, 0, 0, m_cFF.Width, m_cFF.Height, lhDC, 0, 0, vbSrcCopy

' Draw the border:
lY = m_cCaption.Height
lH = m_cBorder.Height
lW = lH
lSrcDC = m_cBorder.hdc
lSrcX = lW * 4
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
' Draw to lhs:
BitBlt lhDCB, 0, lY + lTop, lW, lH, lSrcDC, 0, lSrcY, vbSrcCopy

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

76 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
' Draw to right:
BitBlt lhDCB, lW, lY + lTop, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
'Exit Do
If lSrcY = 0 Then
lSrcDC = lhDCB
lSrcY = lY + lTop
lSrcX = lW
lY = lY + lH
Else
lY = lY + lH
lH = lH * 2
End If
Loop While lY < lBottom - lW
lT = m_cCaption.Height + lTop
lH = lBottom - lT
BitBlt hdc, lLeft, lT, lW, lH, lhDCB, 0, lT, vbSrcCopy
BitBlt hdc, lRight - lW, lT, lW, lH, lhDCB, lW, lT, vbSrcCopy

lT = lBottom - lW
If lT < m_cCaption.Height Then
lT = m_cCaption.Height
End If

' Bottom - we draw into the caption mem dc for flicker free
lX = lLeft + lW
lH = m_cBorder.Height
lSrcDC = m_cBorder.hdc
lSrcX = lW * 3
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
BitBlt lhDC, lX, 0, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
If lSrcY = 0 Then
lSrcDC = lhDC
lSrcX = lX
lX = lX + lW
Else
lX = lX + lW
lW = lW * 2
End If
Loop While lX < lRight - lH
' Bottom corners
BitBlt lhDC, lLeft, 0, lH, lH, m_cBorder.hdc, lH * 2, 0, vbSrcCopy
BitBlt lhDC, lRight - lH, 0, lH, lH, m_cBorder.hdc, lH * 6, 0, vbSrcCopy

' Swap out to display:
BitBlt hdc, lLeft, lT, m_cFF.Width, lH, lhDC, 0, 0, vbSrcCopy

SelectObject lhDC, hFntOld
DeleteObject hFnt
LockWindowUpdate 0
End Sub

Private Sub INCAreaModifier_GetBottomMarginHeight(cy As Long)
'
cy = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetLeftMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetRightMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetTopMarginHeight(cy As Long)
'
cy = m_cCaption.Height
End Sub

' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
If OleTranslateColor(clr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function

Private Sub pOLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer
Dim b() As Byte

' Convert an OLE StdFont to a LOGFONT structure:
With tLF
sFont = fntThis.Name
b = StrConv(sFont, vbFromUnicode)
For iChar = 1 To Len(sFont)
.lfFaceName(iChar - 1) = b(iChar - 1)
Next iChar
' Based on the Win32SDK documentation:
.lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
.lfCharSet = fntThis.Charset
End With

End Sub

--------------
Option Explicit
Private iInterval As Long
Private id As Long

' User can attach any Variant data they want to the timer
Public Item As Variant

Public Event ThatTime()

' SubTimer is independent of VBCore, so it hard codes error handling

Public Enum EErrorTimer
eeBaseTimer = 13650 ' CTimer
eeTooManyTimers ' No more than 10 timers allowed per class
eeCantCreateTimer ' Can't create system timer

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

77 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
End Enum

Friend Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.EXEName & ".WindowProc"
Select Case e
Case eeTooManyTimers
sText = "No more than 10 timers allowed per class"
Case eeCantCreateTimer
sText = "Can't create system timer"
End Select
Err.Raise e Or vbObjectError, sSource, sText
Else
' Raise standard Visual Basic error
Err.Raise e, sSource
End If
End Sub

Property Get Interval() As Long
Interval = iInterval
End Property

' Can't just change interval--you must kill timer and start a new one
Property Let Interval(iIntervalA As Long)
Dim f As Boolean
If iIntervalA > 0 Then
' Don't mess with it if interval is the same
If iInterval = iIntervalA Then Exit Property
' Must destroy any existing timer to change interval
If iInterval Then
f = TimerDestroy(Me)
Debug.Assert f ' Shouldn't fail
End If
' Create new timer with new interval
iInterval = iIntervalA
If TimerCreate(Me) = False Then ErrRaise eeCantCreateTimer
Else
If (iInterval > 0) Then
iInterval = 0
f = TimerDestroy(Me)
Debug.Assert f ' Shouldn't fail
End If
End If
End Property

' Must be public so that Timer object can't terminate while client's ThatTime
' event is being processed--Friend wouldn't prevent this disaster
Public Sub PulseTimer()
RaiseEvent ThatTime
End Sub

Friend Property Get TimerID() As Long
TimerID = id
End Property

Friend Property Let TimerID(idA As Long)
id = idA
End Property

Private Sub Class_Terminate()
Interval = 0
End Sub

----------------
Option Explicit

' =======================================================================
' FileName: cToolbarMenu
' Author: Steve McMahon
' Date: 8 Feb 2000
'
' Allows menus to pop up and cancel as the user hovers
' over toolbar buttons.
'
'
' Copyright ?2000 Steve McMahon
' =======================================================================

Private Enum TRACKINGSTATE '{ // menubar has three states:
TRACK_NONE = 0 ', // * normal, not tracking anything
TRACK_BUTTON ', // * tracking buttons (F10/Alt mode)
TRACK_POPUP '// * tracking popups
End Enum

' Track popup menu constants:

Private m_iTrackingState As TRACKINGSTATE
Private m_bProcessRightArrow As Boolean
Private m_bProcessLeftArrow As Boolean
Private m_hMenuTracking As Long
Private m_iPopupTracking As Long
Private m_bEscapeWasPressed As Boolean
Private m_tPMouse As POINTAPI
Private m_iNewPopup As Long
Private m_bIn As Boolean

Private m_hWnd As Long
Private m_lPtr As Long

Private m_iExit As Integer

Implements ISubclass

Friend Sub CoolMenuAttach(ByRef hWndA As Long, ByVal cBar As cMenuBar)
Dim lPtr As Long

m_iExit = 0
CoolMenuDetach
m_hWnd = hWndA
SendMessageLong m_hWnd, WM_ENTERMENULOOP, 0, 0
AttachMessage Me, m_hWnd, WM_MENUSELECT
m_lPtr = ObjPtr(cBar)

End Sub
Friend Sub CoolMenuDetach()
If (m_hWnd <> 0) Then
SendMessageLong m_hWnd, WM_EXITMENULOOP, 0, 0
DetachMessage Me, m_hWnd, WM_MENUSELECT
m_hWnd = 0
End If
m_hWnd = 0

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

78 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
m_lPtr = 0
End Sub

'/////////////////
'// When user selects a new menu item, note whether it has a submenu
'// and/or parent menu, so I know whether right/left arrow should
'// move to the next popup.
'//
Private Sub MenuSelect(ByVal hMenu As Long, ByVal iItem As Long)
If (m_iTrackingState > 0) Then
'// process right-arrow if item is NOT a submenu
m_bProcessRightArrow = (GetSubMenu(hMenu, iItem) = 0)
'// process left-arrow if curent menu is one I'm tracking
m_bProcessLeftArrow = (hMenu = m_hMenuTracking)
End If
End Sub

'//////////////////
'// Handle menu input event: Look for left/right to change popup menu,
'// mouse movement over over a different menu button for "hot" popup effect.
'// Returns TRUE if message handled (to eat it).
'//
Friend Function MenuInput(m As Msg) As Boolean
Dim iMsg As Long
Dim vKey As Long
Dim tP As POINTAPI
Dim iButton As Long

'ASSERT_VALID(this);
Debug.Assert m_iTrackingState = TRACK_POPUP '; // sanity check
iMsg = m.message

If (iMsg = WM_KEYDOWN) Then

'// handle left/right-arow.
vKey = m.wParam
If ((vKey = vbKeyLeft And m_bProcessLeftArrow) Or _
(vKey = vbKeyRight And m_bProcessRightArrow)) Then

'MBTRACE(_T("CMenuBar::OnMenuInput: handle VK_LEFT/RIGHT\n"));
CancelMenuAndTrackNewOne _
GetNextOrPrevButton(m_iPopupTracking, vKey = vbKeyLeft)
MenuInput = True ' // eat it

' // escape:
ElseIf (vKey = vbKeyEscape) Then
m_bEscapeWasPressed = True '; // (menu will abort itself)
End If

ElseIf (iMsg = WM_MOUSEMOVE Or iMsg = WM_LBUTTONDOWN) Then
'// handle mouse move or click
LSet tP = m.pt
'ScreenToClient m_hWndBand, tP

If (iMsg = WM_MOUSEMOVE) Then
'If (tP.X <> m_tPMouse.X) And (tP.Y <> m_tPMouse.Y) Then
iButton = HitTest(tP)
If IsValidButton(iButton) Then
If iButton <> m_iPopupTracking Then
'// user moved mouse over a different button: track its popup
CancelMenuAndTrackNewOne iButton
End If
End If
LSet m_tPMouse = tP
'End If
ElseIf iMsg = WM_LBUTTONDOWN Then
If (HitTest(tP) = m_iPopupTracking) Then
'// user clicked on same button I am tracking: cancel menu
'MBTRACE(_T("CMenuBar:OnMenuInput: handle mouse click to exit popup\n"));
CancelMenuAndTrackNewOne -1
MenuInput = True ' // eat it
End If
End If

ElseIf iMsg = WM_LBUTTONUP Or iMsg = WM_RBUTTONUP Then

End If

End Function

Private Function HitTest(pt As POINTAPI) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
HitTest = cBar.HitTest(pt)
End If

End Function
Private Property Get IsValidButton(ByVal iButton As Long) As Boolean
If (iButton > 0) Then
IsValidButton = True
End If
End Property

'//////////////////
'// Cancel the current popup menu by posting WM_CANCELMODE, and track a new
'// menu. iNewPopup is which new popup to track (-1 to quit).
'//
Private Sub CancelMenuAndTrackNewOne(ByVal iNewPopup As Long)
Dim cBar As cMenuBar
Dim hMenuPopup As Long
'MBTRACE(_T("CMenuBar::CancelMenuAndTrackNewOne: %d\n"), iNewPopup);
'ASSERT_VALID(this);
If iNewPopup > 0 Then
If (iNewPopup <> m_iPopupTracking) Then
If GetBar(cBar) Then
hMenuPopup = cBar.GetMenuHandle(iNewPopup)
If hMenuPopup <> 0 Then
'PostMessage m_hWndOwner, WM_CANCELMODE, 0, 0 ' // quit menu loop
PostMessage m_hWnd, WM_CANCELMODE, 0, 0
m_iNewPopup = iNewPopup '// go to this popup (-1 = quit)
End If
End If
End If
End If
End Sub

'//////////////////
'// Track the popup submenu associated with the i'th button in the menu bar.
'// This fn actually goes into a loop, tracking different menus until the user
'// selects a command or exits the menu.
'//
Friend Function TrackPopup(ByVal iButton As Long) As Long
Dim nMenuItems As Long
Dim tPM As TPMPARAMS
Dim rcButton As RECT
Dim pt As POINTAPI
Dim hMenuPopup As Long
Dim lR As Long
Dim hwnd As Long
Dim lRtnID As Long
Dim cBar As cMenuBar

LockWindowUpdate hdc
' Here we do the work!
tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom

' Ensure mem DCs are big enough to draw into:
m_cFF.Width = tR.right - tR.left + 1
m_cFF.Height = m_cCaption.Height
lhDC = m_cFF.hdc

m_cFFB.Width = m_cBorder.Width * 2
m_cFFB.Height = tR.bottom - tR.top + 1
lhDCB = m_cFFB.hdc

pOLEFontToLogFont m_fnt, hdc, tLF
If m_cNCS.WindowActive Then
tLF.lfWeight = FW_BOLD
End If
hFnt = CreateFontIndirect(tLF)
hFntOld = SelectObject(lhDC, hFnt)

If m_cNCS.WindowActive Then
lOrgX = 0
Else
lOrgX = m_lInactiveOffset
End If
' Draw the caption
BitBlt lhDC, lLeft, lTop, lLeft + m_lActiveLeftEnd, m_cCaption.Height, m_cCaption.hdc, lOrgX, 0, vbSrcCopy
lRW = (m_lActiveRightEnd - m_lActiveRightStart + 1)
lXE = lRight - lRW + 1
If lXE < lLeft + lRW Then
lXE = lLeft + lRW
bNoMiddle = True
End If
BitBlt lhDC, lXE, lTop, lRW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveRightStart, 0, vbSrcCopy

' Buttons:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
m_bMaximise = ((lStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX)
m_bMinimise = ((lStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX)
m_bClose = ((lStyle And WS_SYSMENU) = WS_SYSMENU)
m_tBtn(0).left = lXE + lRW - m_cBorder.Height + 4
If m_bClose Then
m_tBtn(0).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(0).top = lTop + 5
m_tBtn(0).right = m_tBtn(0).left + m_lButtonWidth + 1
m_tBtn(0).bottom = m_tBtn(0).top + m_lButtonHeight
DrawButton lhDC, 0, up
End If
If m_bMaximise Then
m_tBtn(1).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(1).top = lTop + 5
m_tBtn(1).right = m_tBtn(1).left + m_lButtonWidth + 1
m_tBtn(1).bottom = m_tBtn(1).top + m_lButtonHeight
DrawButton lhDC, 1, up
Else
m_tBtn(1).left = m_tBtn(0).left
End If
If m_bMinimise Then
m_tBtn(2).left = m_tBtn(1).left - (m_lButtonWidth + 1)
m_tBtn(2).top = lTop + 5
m_tBtn(2).right = m_tBtn(2).left + (m_lButtonWidth + 1)
m_tBtn(2).bottom = m_tBtn(2).top + m_lButtonHeight
DrawButton lhDC, 2, up
End If

' Fill in:
lX = lLeft + 90
Do
lW = 52
If lX + 52 > lXE Then
lW = lXE - lX
End If
BitBlt lhDC, lX, 0, lW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveLeftEnd + 1, 0, vbSrcCopy
lX = lX + 52
Loop While lX < lXE

If Not bNoMiddle Then

' Draw the caption:
SetBkMode lhDC, TRANSPARENT
If m_cNCS.WindowActive Then
SetTextColor lhDC, TranslateColor(m_oActiveCaptionColor)
Else
SetTextColor lhDC, TranslateColor(m_oInActiveCaptionColor)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

80 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
End If
lLen = GetWindowTextLength(m_hWnd)
If lLen > 0 Then
tR.left = lLeft + 92
tR.right = lRight - 96
tR.top = m_cBorder.Height + 1
tR.bottom = tR.top + (m_cCaption.Height - m_cBorder.Height - 2) \ 2
sCaption = String$(lLen + 1, 0)
GetWindowText m_hWnd, sCaption, lLen + 1
DrawText lhDC, sCaption, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_NOPREFIX
End If

End If

' Menu:
m_cMenu.hMenu = m_cNCS.hMenu
lW = lXE - m_lActiveLeftEnd
tLF.lfWeight = FW_NORMAL
hFntMenu = CreateFontIndirect(tLF)
m_cMenu.Render hFntMenu, lhDC, m_lActiveLeftEnd, m_cCaption.Height \ 2, lW, m_cCaption.Height \ 2, -m_cCaption.Height \ 2 + 2
DeleteObject hFntMenu

BitBlt hdc, 0, 0, m_cFF.Width, m_cFF.Height, lhDC, 0, 0, vbSrcCopy

' Draw the border:
lY = m_cCaption.Height
lH = m_cBorder.Height
lW = lH
lSrcDC = m_cBorder.hdc
lSrcX = lW * 4
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
' Draw to lhs:
BitBlt lhDCB, 0, lY + lTop, lW, lH, lSrcDC, 0, lSrcY, vbSrcCopy
' Draw to right:
BitBlt lhDCB, lW, lY + lTop, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
'Exit Do
If lSrcY = 0 Then
lSrcDC = lhDCB
lSrcY = lY + lTop
lSrcX = lW
lY = lY + lH
Else
lY = lY + lH
lH = lH * 2
End If
Loop While lY < lBottom - lW
lT = m_cCaption.Height + lTop
lH = lBottom - lT
BitBlt hdc, lLeft, lT, lW, lH, lhDCB, 0, lT, vbSrcCopy
BitBlt hdc, lRight - lW, lT, lW, lH, lhDCB, lW, lT, vbSrcCopy

lT = lBottom - lW
If lT < m_cCaption.Height Then
lT = m_cCaption.Height
End If

' Bottom - we draw into the caption mem dc for flicker free
lX = lLeft + lW
lH = m_cBorder.Height
lSrcDC = m_cBorder.hdc
lSrcX = lW * 3
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
BitBlt lhDC, lX, 0, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
If lSrcY = 0 Then
lSrcDC = lhDC
lSrcX = lX
lX = lX + lW
Else
lX = lX + lW
lW = lW * 2
End If
Loop While lX < lRight - lH
' Bottom corners
BitBlt lhDC, lLeft, 0, lH, lH, m_cBorder.hdc, lH * 2, 0, vbSrcCopy
BitBlt lhDC, lRight - lH, 0, lH, lH, m_cBorder.hdc, lH * 6, 0, vbSrcCopy

' Swap out to display:
BitBlt hdc, lLeft, lT, m_cFF.Width, lH, lhDC, 0, 0, vbSrcCopy

SelectObject lhDC, hFntOld
DeleteObject hFnt
LockWindowUpdate 0
End Sub

Private Sub INCAreaModifier_GetBottomMarginHeight(cy As Long)
'
cy = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetLeftMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetRightMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetTopMarginHeight(cy As Long)
'
cy = m_cCaption.Height
End Sub

Private Sub pOLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

81 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
Dim sFont As String
Dim iChar As Integer
Dim b() As Byte

End Sub

--------------
Option Explicit
Private iInterval As Long
Private id As Long

' User can attach any Variant data they want to the timer
Public Item As Variant

Public Event ThatTime()

' SubTimer is independent of VBCore, so it hard codes error handling

Public Enum EErrorTimer
eeBaseTimer = 13650 ' CTimer
eeTooManyTimers ' No more than 10 timers allowed per class
eeCantCreateTimer ' Can't create system timer
End Enum

Property Get Interval() As Long
Interval = iInterval
End Property

' Must be public so that Timer object can't terminate while client's ThatTime
' event is being processed--Friend wouldn't prevent this disaster
Public Sub PulseTimer()
RaiseEvent ThatTime
End Sub

Friend Property Get TimerID() As Long
TimerID = id
End Property

Friend Property Let TimerID(idA As Long)
id = idA
End Property

Private Sub Class_Terminate()
Interval = 0
End Sub

----------------
Option Explicit

Private Enum TRACKINGSTATE '{ // menubar has three states:

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

82 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
TRACK_NONE = 0 ', // * normal, not tracking anything
TRACK_BUTTON ', // * tracking buttons (F10/Alt mode)
TRACK_POPUP '// * tracking popups
End Enum

' Track popup menu constants:

Private m_hWnd As Long
Private m_lPtr As Long

Private m_iExit As Integer

Implements ISubclass

Friend Sub CoolMenuAttach(ByRef hWndA As Long, ByVal cBar As cMenuBar)
Dim lPtr As Long

'ASSERT_VALID(this);
Debug.Assert m_iTrackingState = TRACK_POPUP '; // sanity check
iMsg = m.message

If (iMsg = WM_KEYDOWN) Then

'// handle left/right-arow.
vKey = m.wParam
If ((vKey = vbKeyLeft And m_bProcessLeftArrow) Or _
(vKey = vbKeyRight And m_bProcessRightArrow)) Then

If (iMsg = WM_MOUSEMOVE) Then
'If (tP.X <> m_tPMouse.X) And (tP.Y <> m_tPMouse.Y) Then
iButton = HitTest(tP)
If IsValidButton(iButton) Then
If iButton <> m_iPopupTracking Then
'// user moved mouse over a different button: track its popup
CancelMenuAndTrackNewOne iButton
End If
End If
LSet m_tPMouse = tP
'End If
ElseIf iMsg = WM_LBUTTONDOWN Then

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

83 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
If (HitTest(tP) = m_iPopupTracking) Then
'// user clicked on same button I am tracking: cancel menu
'MBTRACE(_T("CMenuBar:OnMenuInput: handle mouse click to exit popup\n"));
CancelMenuAndTrackNewOne -1
MenuInput = True ' // eat it
End If
End If

ElseIf iMsg = WM_LBUTTONUP Or iMsg = WM_RBUTTONUP Then

End If

End Function

Private Function HitTest(pt As POINTAPI) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
HitTest = cBar.HitTest(pt)
End If

End Function
Private Property Get IsValidButton(ByVal iButton As Long) As Boolean
If (iButton > 0) Then
IsValidButton = True
End If
End Property

If Not m_bIn Then
m_bIn = True
m_iNewPopup = iButton
'Debug.Assert m_hMenu <> 0
If GetBar(cBar) Then

nMenuItems = cBar.Count 'GetMenuItemCount(m_hMenu)

Do While (m_iNewPopup > -1) '// while user selects another menu

lRtnID = 0

m_iNewPopup = -1 '// assume quit after this
PressButton iButton, True '// press the button
'UpdateWindow ToolbarhWnd(m_hWnd) '// and force repaint now

SetTrackingState TRACK_POPUP, iButton '// enter tracking state

'// Need to install a hook to trap menu input in order to make
'// left/right-arrow keys and "hot" mouse tracking work.
'//
AttachMsgHook Me

'// get submenu and display it beneath button
GetRect iButton, rcButton
'ClientRectToScreen m_hWndBand, rcButton
tPM.cbSize = Len(tPM)
ComputeMenuTrackPoint rcButton, tPM, pt

'hMenuPopup = GetSubMenu(m_hMenu, iButton)
hMenuPopup = cBar.GetMenuHandle(iButton)

If hMenuPopup <> 0 Then
' Show the menu:
m_hMenuTracking = hMenuPopup
lR = TrackPopupMenuEx(hMenuPopup, _
TPM_LEFTALIGN Or TPM_LEFTBUTTON Or TPM_VERTICAL, _
pt.x, pt.y, m_hWnd, tPM)
'lR is the ID of the menu
lRtnID = lR
End If

'// uninstall hook.
DetachMsgHook

PressButton iButton, False '; // un-press button

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

84 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
'UpdateWindow ToolbarhWNd(m_hWnd) '// and force repaint now

'// If the user exited the menu loop by pressing Escape,
'// return to track-button state; otherwise normal non-tracking state.
If (m_bEscapeWasPressed) Then
SetTrackingState TRACK_NONE, iButton
Else
SetTrackingState TRACK_NONE, iButton
End If

'// If the user moved mouse to a new top-level popup (eg from File to
'// Edit button), I will have posted a WM_CANCELMODE to quit
'// the first popup, and set m_iNewPopup to the new menu to show.
'// Otherwise, m_iNewPopup will be -1 as set above.
'// So just set iButton to the next popup menu and keep looping...
iButton = m_iNewPopup

Loop

' Set hot button if mouse is over, otherwise not:

' The ID of the selected menu
TrackPopup = lRtnID
End If
m_bIn = False
End If
End Function
Private Sub ComputeMenuTrackPoint(ByRef rc As RECT, tPM As TPMPARAMS, tP As POINTAPI)
tP.x = rc.left
tP.y = rc.bottom
LSet tPM.rcExclude = rc
End Sub

Private Function GetBar(ByRef cBar As cMenuBar) As Boolean
If Not m_lPtr = 0 Then
Set cBar = ObjectFromPtr(m_lPtr)
'Debug.Print "GetBar:OK"
GetBar = True
End If
End Function

Private Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
Dim fState As Long
Dim cBar As cMenuBar

If GetBar(cBar) Then
If iButton > 0 And iButton <= cBar.Count Then
cBar.PressButton iButton, bState
End If
End If

End Sub

Private Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
Dim cBar As cMenuBar
tR.left = 0: tR.top = 0: tR.bottom = 0: tR.right = 0
If GetBar(cBar) Then
If iButton > 0 And iButton <= cBar.Count Then
cBar.GetRect iButton, tR
End If
End If
End Sub
Private Function GetHotItem() As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
GetHotItem = cBar.HotItem
End If
End Function
Private Function SetHotItem(ByVal iButton As Long) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
'Debug.Print "Setting hot item: " & iButton
cBar.HotItem = iButton
End If
End Function
Private Function GetButtonVisible(ByVal iButton As Long) As Boolean
GetButtonVisible = True
End Function
Private Function GetButtonCount() As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
GetButtonCount = cBar.Count
End If
End Function

Private Sub SetTrackingState(ByVal iState As TRACKINGSTATE, ByVal iButton As Long)
If (iState <> m_iTrackingState) Then
If (iState = TRACK_NONE) Then
iButton = -1
End If
'#ifdef _DEBUG
' static LPCTSTR StateName[] = { _T("NONE"), _T("BUTTON"), _T("POPUP") };
' MBTRACE(_T("CMenuBar::SetTrackingState to %s, button=%d\n"),
' StateName[iState], iButton);
'#End If

SetHotItem iButton '// could be none (-1)

If (iState = TRACK_POPUP) Then
'// set related state stuff
m_bEscapeWasPressed = False 'FALSE; // assume Esc key not pressed
m_bProcessRightArrow = True '// assume left/right arrow..
m_bProcessLeftArrow = True '; // ..will move to prev/next popup
m_iPopupTracking = iButton '// which popup I'm tracking
End If
m_iTrackingState = iState

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

85 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐)
End If
End Sub

Private Function GetNextOrPrevButton(ByVal iButton As Long, ByVal bPrev As Boolean) As Long
Dim iSB As Long
Dim bfound As Boolean

If (bPrev) Then
iSB = iButton
Do While Not bfound

iButton = iButton - 1
If iButton < 1 Then
iButton = GetButtonCount()
End If

If Not (GetButtonVisible(iButton)) Then
If iButton = iSB Then
iButton = -1
Exit Do
End If
Else
bfound = True
End If

Loop

Else
iSB = iButton
Do While Not bfound
iButton = iButton + 1
If (iButton > GetButtonCount()) Then
iButton = 1
End If

If Not GetButtonVisible(iButton) Then
If iButton = iSB Then
iButton = -1
Exit Do
End If
Else
bfound = True
End If

Loop

End If
GetNextOrPrevButton = iButton
End Function
'//////////////////
'// Toggle state from home state to button-tracking and back
'//
Private Sub ToggleTrackButtonMode()
If (m_iTrackingState = TRACK_NONE Or m_iTrackingState = TRACK_BUTTON) Then
If m_iTrackingState = TRACK_NONE Then
SetTrackingState TRACK_BUTTON, 1
Else
SetTrackingState TRACK_NONE, 1
End If
End If
End Sub

Private Property Get ISubclass_MsgResponse() As EMsgResponse
If CurrentMessage = WM_MENUSELECT Then
ISubclass_MsgResponse = emrPreprocess
End If
End Property

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
'
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_MENUSELECT
MenuSelect lParam, (wParam And &HFFFF&)
End Select
End Function

--------------
Option Explicit

Sub AttachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
MSubclass.AttachMessage iwp, hwnd, iMsg
End Sub

Sub DetachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
MSubclass.DetachMessage iwp, hwnd, iMsg
End Sub

Public Property Get CurrentMessage() As Long
CurrentMessage = MSubclass.CurrentMessage
End Property
Public Function CallOldWindowProc( _
ByVal hwnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
CallOldWindowProc = MSubclass.CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End Function

--------------
Option Explicit

Public Property Get hwnd() As Long

End Property
Public Sub GetTopMarginHeight(cy As Long)

End Sub
Public Sub GetLeftMarginWidth(cx As Long)

End Sub
Public Sub GetRightMarginWidth(cx As Long)

End Sub
Public Sub GetBottomMarginHeight(cy As Long)

End Sub
Public Sub NCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub HitTest(ByVal x As Long, ByVal y As Long, ByRef eHitTest As ECNCHitTestConstants)

End Sub
Public Sub NCMouseDown(ByVal x As Long, ByVal y As Long, ByRef bHandled As Boolean, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub NCMouseUp(ByVal x As Long, ByVal y As Long, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub InitMenuPopup(ByVal wParam As Long, ByVal lParam As Long)

End Sub
Public Sub ExitMenuLoop()

End Sub
Public Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long

End Function

----------------
Option Explicit

Public Enum EMsgResponse
emrConsume ' Process instead of original WindowProc
emrPostProcess ' Process after original WindowProc
emrPreprocess ' Process before original WindowProc
End Enum

Public MsgResponse As EMsgResponse

Function WindowProc(ByVal hwnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
End Functio

作者: 61.142.212.* 2005-10-28 21:34 　回复此发言

--------------------------------------------------------------------------------

86 调用 API 实现 Ani 窗体。
Option Explicit

Private Sub Form_Load()
Load frmAnim
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload frmAnim
End Sub

Private Sub cmdSlide_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_HOR_POSITIVE + AW_VER_POSITIVE + AW_SLIDE + AW_ACTIVATE

End Sub

Private Sub cmdExpand_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_CENTER + AW_SLIDE + AW_ACTIVATE

End Sub

Private Sub cmdFade_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_BLEND + AW_ACTIVATE

End Sub

----------
Option Explicit

Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
lpRect As RECT, ByVal hBrush As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Friend Sub PrintClient(ByVal hDC As Long, ByVal lParam As Long)

Dim rct As RECT
Dim hBr As Long

'Fill in the hDC with the form's
'background color. Otherwise the form
'may appear strangely.
rct.Left = 0
rct.Top = 0
rct.Right = ScaleX(ScaleWidth, ScaleMode, vbPixels)
rct.Bottom = ScaleY(ScaleHeight, ScaleMode, vbPixels)
hBr = CreateSolidBrush(TranslateColor(Me.BackColor))
FillRect hDC, rct, hBr
DeleteObject hBr

End Sub

Private Sub Form_Load()
SubclassAnim Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
UnSubclassAnim Me
End Sub

-----------------
Option Explicit

Public Const AW_HOR_POSITIVE = &H1
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_VER_NEGATIVE = &H8
Public Const AW_CENTER = &H10
Public Const AW_HIDE = &H10000
Public Const AW_ACTIVATE = &H20000
Public Const AW_SLIDE = &H40000
Public Const AW_BLEND = &H80000
Public Declare Function AnimateWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal dwTime As Long, ByVal dwFlags As Long) As Long

Public Const WM_PRINTCLIENT = &H318

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)

Public Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hWnd As Long, ByVal lpString As String, _
ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long

Public Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Public Declare Function OleTranslateColor _
Lib "oleaut32.dll" _
(ByVal lOleColor As Long, _
ByVal lHPalette As Long, _
lColorRef As Long) As Long

Public Function TranslateColor(inCol As Long) As Long

Dim retCol As Long
OleTranslateColor inCol, 0&, retCol
TranslateColor = retCol
End Function

Public Function AnimWndProc(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Dim lProc As Long
Dim lPtr As Long
Dim frm As frmAnim

lProc = GetProp(hWnd, "ExAnimWndProc")
lPtr = GetProp(hWnd, "ExAnimWndPtr")

'Catch the WM_PRINTCLIENT message so the form
'won't look like garbage when it appears.
If wMsg = WM_PRINTCLIENT Then
CopyMemory frm, lPtr, 4
frm.PrintClient wParam, lParam
CopyMemory frm, 0&, 4
End If

AnimWndProc = CallWindowProc(lProc, hWnd, wMsg, wParam, lParam)

End Function

Public Sub SubclassAnim(frm As frmAnim)

Dim l As Long

If GetProp(frm.hWnd, "ExAnimWndProc") <> 0 Then
'Already subclassed
Exit Sub
End If

l = GetWindowLong(frm.hWnd, GWL_WNDPROC)
SetProp frm.hWnd, "ExAnimWndProc", l
SetProp frm.hWnd, "ExAnimWndPtr", ObjPtr(frm)

SetWindowLong frm.hWnd, GWL_WNDPROC, AddressOf AnimWndProc

End Sub

Public Sub UnSubclassAnim(frm As frmAnim)

Dim l As Long

l = GetProp(frm.hWnd, "ExAnimWndProc")
If l = 0 Then
'Isn't subclassed anyway
Exit Sub
End If

SetWindowLong frm.hWnd, GWL_WNDPROC, l
RemoveProp frm.hWnd, "ExAnimWndProc"
RemoveProp frm.hWnd, "ExAnimWndPtr"

End Sub

作者: 61.142.212.* 2005-10-28 21:35 　回复此发言

--------------------------------------------------------------------------------

87 API的“浏览”对话框。
Option Explicit

Dim nFolder& ' system folder to begin browse in
Dim CurOptIdx% ' currently selected option button

Private Sub Form_Load()

Dim idx&, item&
Dim rtn&, path$
Dim idl As ITEMIDLIST

For idx& = 1 To 17

' see BrowsDlg.bas for the system folder flag values
' The Desktop
If idx& = 1 Then
item& = 0

' Programs Folder -> Start Menu Folder
ElseIf idx& > 1 And idx& < 12 Then
item& = idx&

' Desktop Folder -> ShellNew Folder
ElseIf idx& >= 12 Then
item& = idx& + 4&
End If

' fill the idl structure with the specified folder item
rtn& = SHGetSpecialFolderLocation(Me.hWnd, item&, idl)
If rtn& = NOERROR Then

' if the structure is filled, initialize the var & get the path from the id list
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal idl.mkid.cb, ByVal path$)

' if a path was found in the structure, display it in the respective text box
If rtn& Then Text1(idx&) = path$
End If
Next

End Sub

Private Sub Option1_Click(Index As Integer)

' see the "bi.lpszTitle=..." line in Command1_Click

' save the current option btn for dialog banner display
CurOptIdx% = Index

' save the value of the system folder to begin dialog display from
If Index = 1 Then
nFolder& = 0
ElseIf Index < 12 Then
nFolder& = Index
Else
nFolder& = Index + 4
End If

End Sub

Private Sub Command1_Click()

Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, path$, pos%

' the calling app
bi.hOwner = Me.hWnd

' set the folder to limit the browse to in the dialog
' if CurOptIdx% = 0 (Default Browse), bi.pidlRoot would then be Null
If CurOptIdx% Then
rtn& = SHGetSpecialFolderLocation(ByVal Me.hWnd, ByVal nFolder&, idl)
bi.pidlRoot = idl.mkid.cb
End If

' set the banner text
bi.lpszTitle = "Browsing is limited to: " & Option1(CurOptIdx%).Caption

' set the type of folder to return
' play with these option constants to see what can be returned
bi.ulFlags = BIF_RETURNONLYFSDIRS 'BIF_RETURNFSANCESTORS 'BIF_BROWSEFORPRINTER + BIF_DONTGOBELOWDOMAIN

' show the browse folder dialog
pidl& = SHBrowseForFolder(bi)

' if displaying the return value, get the selected folder
If Check1 Then
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
If rtn& Then

' parce & display the folder selection
pos% = InStr(path$, Chr$(0))
MsgBox "Folder selection was:" & Chr$(10) & Chr$(10) & Left(path$, pos - 1), vbInformation
Else
MsgBox "Dialog was cancelled", vbInformation
End If
End If

End Sub

Private Sub Command2_Click()

Dim msg$, lf$
lf$ = Chr$(10)

msg$ = "If an item has no folder location displayed, then it has no Registry entry under:" & lf$ & lf$
msg$ = msg$ & "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders" & lf$ ' & lf$
'msg$ = msg$ & "If one of these items is selected from the Browse dialog, it will return 0 (cancelled) to the calling proc."
MsgBox msg$

End Sub

Private Sub Command3_Click()

Unload Me

作者: 61.142.212.* 2005-10-28 21:36 　回复此发言

--------------------------------------------------------------------------------

88 API的“浏览”对话框。

End Sub

Private Sub Form_Unload(Cancel As Integer)

Set Form1 = Nothing

End Sub

--------------
Option Explicit

' This code module & it's accompanying form module, BrowsDlg.frm,
' demonstrate how to display the "Browse for Folder" dialog box and
' return a user selected folder. The Win32 API structures, functions &
' constants used below are not documented for use with VB 4.0 (32 bit)
' in any conventional sense. The structures & functions were translated
' from the information available in the MSDN/VB Starter Kit. The constant
' values were extracted from the VC++ 4.0 Shlobg.h header file.
'
' For more information, in the MSDN/VB Starter Kit see the following:
' Product Documentation
' SDKs
' Win32 SDK
' Guides
' Programmer's Guide to Windows 95
' Extending the Windows 95 Shell

' Hope it comes in handy,
' Brad Martiez

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' A little info...
' Objects in the shell抯 namespace are assigned item identifiers and item
' identifier lists. An item identifier uniquely identifies an item within its parent
' folder. An item identifier list uniquely identifies an item within the shell抯
' namespace by tracing a path to the item from the desktop.

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' An item identifier is defined by the variable-length SHITEMID structure.
' The first two bytes of this structure specify its size, and the format of
' the remaining bytes depends on the parent folder, or more precisely
' on the software that implements the parent folder抯 IShellFolder interface.
' Except for the first two bytes, item identifiers are not strictly defined, and
' applications should make no assumptions about their format.
Type SHITEMID 'mkid
cb As Long 'Size of the ID (including cb itself)
abID As Byte 'The item ID (variable length)
End Type

' The ITEMIDLIST structure defines an element in an item identifier list
' (the only member of this structure is an SHITEMID structure). An item
' identifier list consists of one or more consecutive ITEMIDLIST structures
' packed on byte boundaries, followed by a 16-bit zero value. An application
' can walk a list of item identifiers by examining the size specified in each
' SHITEMID structure and stopping when it finds a size of zero. A pointer
' to an item identifier list, is sometimes called a PIDL (pronounced piddle)
Type ITEMIDLIST 'idl
mkid As SHITEMID
End Type

' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs ?for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

作者: 61.142.212.* 2005-10-28 21:36 　回复此发言

--------------------------------------------------------------------------------

89 API的“浏览”对话框。

Public Const NOERROR = 0

' SHGetSpecialFolderLocation "nFolder" param:
' Value specifying the folder to retrieve the location of. This parameter
' can be one of the following values: Most folder locations are stored in:
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders

' Windows desktop ?virtual folder at the root of the name space.
Public Const CSIDL_DESKTOP = &H0

' File system directory that contains the user's program groups
' (which are also file system directories).
Public Const CSIDL_PROGRAMS = &H2

' Control Panel ?virtual folder containing icons for the control panel applications.
Public Const CSIDL_CONTROLS = &H3

' Printers folder ?virtual folder containing installed printers.
Public Const CSIDL_PRINTERS = &H4

' File system directory that serves as a common respository for documents.
Public Const CSIDL_PERSONAL = &H5 ' (Documents folder)

' File system directory that contains the user's favorite Internet Explorer URLs.
Public Const CSIDL_FAVORITES = &H6

' File system directory that corresponds to the user's Startup program group.
Public Const CSIDL_STARTUP = &H7

' File system directory that contains the user's most recently used documents.
Public Const CSIDL_RECENT = &H8 ' (Recent folder)

' File system directory that contains Send To menu items.
Public Const CSIDL_SENDTO = &H9

' Recycle bin ?file system directory containing file objects in the user's recycle bin.
' The location of this directory is not in the registry; it is marked with the hidden and
' system attributes to prevent the user from moving or deleting it.
Public Const CSIDL_BITBUCKET = &HA

' File system directory containing Start menu items.
Public Const CSIDL_STARTMENU = &HB

' File system directory used to physically store file objects on the desktop
' (not to be confused with the desktop folder itself).
Public Const CSIDL_DESKTOPDIRECTORY = &H10

' My Computer ?virtual folder containing everything on the local computer: storage
' devices, printers, and Control Panel. The folder may also contain mapped network drives.
Public Const CSIDL_DRIVES = &H11

' Network Neighborhood ?virtual folder representing the top level of the network hierarchy.
Public Const CSIDL_NETWORK = &H12

' File system directory containing objects that appear in the network neighborhood.
Public Const CSIDL_NETHOOD = &H13

' Virtual folder containing fonts.
Public Const CSIDL_FONTS = &H14

' File system directory that serves as a common repository for document templates.
Public Const CSIDL_TEMPLATES = &H15 ' (ShellNew folder)

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' Displays a dialog box that enables the user to select a shell folder.
' Returns a pointer to an item identifier list that specifies the location
' of the selected folder relative to the root of the name space. If the user
' chooses the Cancel button in the dialog box, the return value is NULL.
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST

作者: 61.142.212.* 2005-10-28 21:36 　回复此发言

--------------------------------------------------------------------------------

90 API的“浏览”对话框。

' Contains parameters for the the SHBrowseForFolder function and receives
' information about the folder selected by the user.
Public Type BROWSEINFO 'bi

' Handle of the owner window for the dialog box.
hOwner As Long

' Pointer to an item identifier list (an ITEMIDLIST structure) specifying the location
' of the "root" folder to browse from. Only the specified folder and its subfolders
' appear in the dialog box. This member can be NULL, and in that case, the
' name space root (the desktop folder) is used.
pidlRoot As Long

' Pointer to a buffer that receives the display name of the folder selected by the
' user. The size of this buffer is assumed to be MAX_PATH bytes.
pszDisplayName As String

' Pointer to a null-terminated string that is displayed above the tree view control
' in the dialog box. This string can be used to specify instructions to the user.
lpszTitle As String

' Value specifying the types of folders to be listed in the dialog box as well as
' other options. This member can include zero or more of the following values below.
ulFlags As Long

' Address an application-defined function that the dialog box calls when events
' occur. For more information, see the description of the BrowseCallbackProc
' function. This member can be NULL.
lpfn As Long

' Application-defined value that the dialog box passes to the callback function
' (if one is specified).
lParam As Long

' Variable that receives the image associated with the selected folder. The image
' is specified as an index to the system image list.
iImage As Long

End Type

' BROWSEINFO.ulFlags values:
' Value specifying the types of folders to be listed in the dialog box as well as
' other options. This member can include zero or more of the following values:

' Only returns file system directories. If the user selects folders
' that are not part of the file system, the OK button is grayed.
Public Const BIF_RETURNONLYFSDIRS = &H1

' Does not include network folders below the domain level in the tree view control.
' For starting the Find Computer
Public Const BIF_DONTGOBELOWDOMAIN = &H2

' Includes a status area in the dialog box. The callback function can set
' the status text by sending messages to the dialog box.
Public Const BIF_STATUSTEXT = &H4

' Only returns file system ancestors. If the user selects anything other
' than a file system ancestor, the OK button is grayed.
Public Const BIF_RETURNFSANCESTORS = &H8

' Only returns computers. If the user selects anything other
' than a computer, the OK button is grayed.
Public Const BIF_BROWSEFORCOMPUTER = &H1000

' Only returns (network) printers. If the user selects anything other
' than a printer, the OK button is grayed.
Public Const BIF_BROWSEFORPRINTER = &H2000

作者: 61.142.212.* 2005-10-28 21:36 　回复此发言

--------------------------------------------------------------------------------

91 把外部程序作为MDI窗口打开。
Option Explicit

Private Const GW_HWNDNEXT = 2

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private old_parent As Long
Private child_hwnd As Long

' Return the window handle for an instance handle.
Private Function InstanceToWnd(ByVal target_pid As Long) As Long
Dim test_hwnd As Long
Dim test_pid As Long
Dim test_thread_id As Long

' Get the first window handle.
test_hwnd = FindWindow(ByVal 0&, ByVal 0&)

' Loop until we find the target or we run out
' of windows.
Do While test_hwnd <> 0
' See if this window has a parent. If not,
' it is a top-level window.
If GetParent(test_hwnd) = 0 Then
' This is a top-level window. See if
' it has the target instance handle.
test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)

If test_pid = target_pid Then
' This is the target.
InstanceToWnd = test_hwnd
Exit Do
End If
End If

' Examine the next window.
test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
Loop
End Function

Private Sub cmdFree_Click()
SetParent child_hwnd, old_parent

cmdRun.Enabled = True
cmdFree.Enabled = False
End Sub

Private Sub cmdRun_Click()
Dim pid As Long
Dim buf As String
Dim buf_len As Long
Dim styles As Long

' Start the program.
pid = Shell(txtProgram.Text, vbNormalFocus)
If pid = 0 Then
MsgBox "Error starting program"
Exit Sub
End If

' Get the window handle.
child_hwnd = InstanceToWnd(pid)

' Reparent the program so it lies inside
' the PictureBox.
old_parent = SetParent(child_hwnd, MDIForm1.hwnd)

cmdRun.Enabled = False
cmdFree.Enabled = True
End Sub
---------
Option Explicit

作者: 61.142.212.* 2005-10-28 21:38 　回复此发言

--------------------------------------------------------------------------------

92 API的“浏览”对话框。
Private Sub cmdBrowse_Click()
Dim strResFolder As String

strResFolder = BrowseForFolder(hWnd, "Please select a folder.")

If strResFolder = "" Then
Call MsgBox("The Cancel button was pressed.", vbExclamation)
Else
Call MsgBox("The folder " & strResFolder & " was selected.", vbExclamation)
End If

End Sub
-----------
'This module contains all the declarations to use the
'Windows 95 Shell API to use the browse for folders
'dialog box. To use the browse for folders dialog box,
'please call the BrowseForFolders function using the
'syntax: stringFolderPath=BrowseForFolders(Hwnd,TitleOfDialog)
'
'For more demo projects, please visit out web site at
'http://www.btinternet.com/~jelsoft/
'
'To contact us, please send an email to jelsoft@btinternet.com

Option Explicit

Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String

'declare variables to be used
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo

'initialise variables
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With

'Call the browse for folder API
lpIDList = SHBrowseForFolder(udtBI)

'get the resulting string path
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If

'If cancel was pressed, sPath = ""
BrowseForFolder = sPath

End Function

作者: 61.142.212.* 2005-10-28 21:39 　回复此发言

--------------------------------------------------------------------------------

93 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
'//
'// Common Dialogs Module
'//
'// Description:
'// Provides wrapper functions into the various Windows OS common dialog boxes
'//
'// ***************************************************************
'// * Go to Dragon's VB Code Corner for more useful sourcecode: *
'// * http://personal.inet.fi/cool/dragon/vb/ *
'// ***************************************************************
'//
'// Author of this module: Unknown
'//

Option Explicit

'//
'// Structures
'//

Private Type OPENFILENAME
lStructSize As Long
hWnd As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Type COLORSTRUC
lStructSize As Long
hWnd As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Const LF_FACESIZE = 32

Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type FONTSTRUC
lStructSize As Long
hWnd As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
Flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type

Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFreq As Long
End Type

Private Type PRINTDLGSTRUC
lStructSize As Long
hWnd As Long
hDevMode As Long
hDevNames As Long
hDC As Long
Flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

94 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
End Type

Public Type PRINTPROPS
Cancel As Boolean
Device As String
Copies As Integer
Collate As Boolean
File As Boolean
All As Boolean
Pages As Boolean
Selection As Boolean
FromPage As Integer
ToPage As Integer
DM As DEVMODE
End Type

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'//
'// Win32s (Private Functions for Wrappers Below)
'//

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGSTRUC) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As Long
Private Declare Function GlobalAlloc Lib "Kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "SHELL32.DLL" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST
Private Declare Function WriteProfileString Lib "Kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function GetProfileString Lib "Kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

'//
'// Win32s (Public)
'//

Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Any) As Long
Declare Function HTMLHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" (ByVal hWnd As Long, ByVal szFilename As String, ByVal dwCommand As Long, ByVal dwData As Any) As Long

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

95 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览

'//
'// Constants (Public for Print Dialog Box)
'//

Public Const PD_NOSELECTION = &H4
Public Const PD_DISABLEPRINTTOFILE = &H80000
Public Const PD_PRINTTOFILE = &H20
Public Const PD_RETURNDC = &H100
Public Const PD_RETURNDEFAULT = &H400
Public Const PD_RETURNIC = &H200
Public Const PD_SELECTION = &H1
Public Const PD_SHOWHELP = &H800
Public Const PD_NOPAGENUMS = &H8
Public Const PD_PAGENUMS = &H2
Public Const PD_ALLPAGES = &H0
Public Const PD_COLLATE = &H10
Public Const PD_HIDEPRINTTOFILE = &H100000

'//
'// Constants (Public for WinHelp)
'//

Public Const HELP_COMMAND = &H102&
Public Const HELP_CONTENTS = &H3&
Public Const HELP_CONTEXT = &H1
Public Const HELP_CONTEXTPOPUP = &H8&
Public Const HELP_FORCEFILE = &H9&
Public Const HELP_HELPONHELP = &H4
Public Const HELP_INDEX = &H3
Public Const HELP_KEY = &H101
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&
Public Const HELP_QUIT = &H2
Public Const HELP_SETCONTENTS = &H5&
Public Const HELP_SETINDEX = &H5
Public Const HELP_SETWINPOS = &H203&

'//
'// Constants (Public for HTMLHelp)
'//

Public Const HH_DISPLAY_TOPIC = &H0&
Public Const HH_HELP_FINDER = &H0&
Public Const HH_DISPLAY_TOC = &H1& '// Currently Not Implemented
Public Const HH_DISPLAY_INDEX = &H2& '// Currently Not Implemented
Public Const HH_DISPLAY_SEARCH = &H3& '// Currently Not Implemented
Public Const HH_SET_WIN_TYPE = &H4&
Public Const HH_GET_WIN_TYPE = &H5&
Public Const HH_GET_WIN_HANDLE = &H6&
Public Const HH_ENUM_INFO_TYPE = &H7&
Public Const HH_SET_INFO_TYPE = &H8&
Public Const HH_SYNC = &H9&
Public Const HH_ADD_NAV_UI = &H10& '// Currently Not Implemented
Public Const HH_ADD_BUTTON = &H11& '// Currently Not Implemented
Public Const HH_GETBROWSER_APP = &H12& '// Currently Not Implemented
Public Const HH_KEYWORD_LOOKUP = &H13&
Public Const HH_DISPLAY_TEXT_POPUP = &H14&
Public Const HH_HELP_CONTEXT = &H15&
Public Const HH_TP_HELP_CONTEXTMENU = &H16&
Public Const HH_TP_HELP_WM_HELP = &H17&
Public Const HH_CLOSE_ALL = &H18&
Public Const HH_ALINK_LOOKUP = &H19&
Public Const HH_GET_LAST_ERROR = &H20& '// Currently Not Implemented
Public Const HH_ENUM_CATEGORY = &H21&
Public Const HH_ENUM_CATEGORY_IT = &H22&
Public Const HH_RESET_IT_FILTER = &H23&
Public Const HH_SET_INCLUSIVE_FILTER = &H24&
Public Const HH_SET_EXCLUSIVE_FILTER = &H25&
Public Const HH_SET_GUID = &H26&
Public Const HH_INTERNAL = &H255&

'//
'// Constants (Private)
'//

Private Const FW_BOLD = 700
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

96 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10
Private Const PD_ENABLEPRINTHOOK = &H1000
Private Const PD_ENABLEPRINTTEMPLATE = &H4000
Private Const PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
Private Const PD_ENABLESETUPHOOK = &H2000
Private Const PD_ENABLESETUPTEMPLATE = &H8000
Private Const PD_ENABLESETUPTEMPLATEHANDLE = &H20000
Private Const PD_NONETWORKBUTTON = &H200000
Private Const PD_PRINTSETUP = &H40
Private Const PD_USEDEVMODECOPIES = &H40000
Private Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000
Private Const PD_NOWARNING = &H80
Private Const CF_ANSIONLY = &H400&
Private Const CF_APPLY = &H200&
Private Const CF_BITMAP = 2
Private Const CF_PRINTERFONTS = &H2
Private Const CF_PRIVATEFIRST = &H200
Private Const CF_PRIVATELAST = &H2FF
Private Const CF_RIFF = 11
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_DIB = 8
Private Const CF_DIF = 5
Private Const CF_DSPBITMAP = &H82
Private Const CF_DSPENHMETAFILE = &H8E
Private Const CF_DSPMETAFILEPICT = &H83
Private Const CF_DSPTEXT = &H81
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_ENHMETAFILE = 14
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_GDIOBJFIRST = &H300
Private Const CF_GDIOBJLAST = &H3FF
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_METAFILEPICT = 3
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_OEMTEXT = 7
Private Const CF_OWNERDISPLAY = &H80
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_SYLK = 4
Private Const CF_TEXT = 1
Private Const CF_TIFF = 6
Private Const CF_TTONLY = &H40000
Private Const CF_UNICODETEXT = 13
Private Const CF_USESTYLE = &H80&
Private Const CF_WAVE = 12
Private Const CF_WYSIWYG = &H8000
Private Const CFERR_CHOOSEFONTCODES = &H2000
Private Const CFERR_MAXLESSTHANMIN = &H2002
Private Const CFERR_NOFONTS = &H2001

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

97 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
Private Const CC_ANYCOLOR = &H100
Private Const CC_CHORD = 4
Private Const CC_CIRCLES = 1
Private Const CC_ELLIPSES = 8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_INTERIORS = 128
Private Const CC_NONE = 0
Private Const CC_PIE = 2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const CC_ROUNDRECT = 256 '
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_STYLED = 32
Private Const CC_WIDE = 16
Private Const CC_WIDESTYLED = 64
Private Const CCERR_CHOOSECOLORCODES = &H5000
Private Const LOGPIXELSY = 90
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SIMULATED_FONTTYPE = &H8000
Private Const PRINTER_FONTTYPE = &H4000
Private Const SCREEN_FONTTYPE = &H2000
Private Const BOLD_FONTTYPE = &H100
Private Const ITALIC_FONTTYPE = &H200
Private Const REGULAR_FONTTYPE = &H400
Private Const WM_CHOOSEFONT_GETLOGFONT = (&H400 + 1)
Private Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"
Private Const SHAREVISTRING = "commdlg_ShareViolation"
Private Const FILEOKSTRING = "commdlg_FileNameOK"
Private Const COLOROKSTRING = "commdlg_ColorOK"
Private Const SETRGBSTRING = "commdlg_SetRGBColor"
Private Const FINDMSGSTRING = "commdlg_FindReplace"
Private Const HELPMSGSTRING = "commdlg_help"
Private Const CD_LBSELNOITEMS = -1
Private Const CD_LBSELCHANGE = 0
Private Const CD_LBSELSUB = 1
Private Const CD_LBSELADD = 2
Private Const NOERROR = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_WININICHANGE = &H1A

'//
'// SetDefaultPrinter Function
'//
'// Description:
'// Sets the user's default printer to the printer represented by the passed printer object.
'//
'// Syntax:
'// BOOL = SetDefaultPrinter(object)
'//
'// Example:
'// Dim objNewPrinter As Printer
'// Set objNewPrinter = Printers(2)
'// SetDefaultPrinter objNewPrinter
'//

Public Function SetDefaultPrinter(objPrn As Printer) As Boolean

Dim x As Long, szTmp As String

szTmp = objPrn.DeviceName & "," & objPrn.DriverName & "," & objPrn.Port
x = WriteProfileString("windows", "device", szTmp)

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

98 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
x = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Function

'//
'// GetDefaultPrinter Function
'//
'// Description:
'// Retuns the device name of the default printer.
'//
'// Syntax:
'// StrVar = GetDefaultPrinter()
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter
'//

Public Function GetDefaultPrinter() As String

Dim x As Long, szTmp As String, dwBuf As Long

dwBuf = 1024
szTmp = Space(dwBuf + 1)
x = GetProfileString("windows", "device", "", szTmp, dwBuf)
GetDefaultPrinter = Trim(Left(szTmp, x))

End Function

'//
'// ResetDefaultPrinter Function
'//
'// Description:
'// Resets the default printer to the passed device name.
'//
'// Syntax:
'// BOOL = ResetDefaultPrinter(StrVar)
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter()
'// If Not ResetDefaultPrinter(szDefPrinter) Then
'// MsgBox "Could not reset default printer.", vbExclamation
'// End If
'//

Public Function ResetDefaultPrinter(szBuf As String) As Boolean

Dim x As Long

x = WriteProfileString("windows", "device", szBuf)
x = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Function

'//
'// BrowseFolder Function
'//
'// Description:
'// Allows the user to interactively browse and select a folder found in the file system.
'//
'// Syntax:
'// StrVar = BrowseFolder(hWnd, StrVar)
'//
'// Example:
'// szFilename = BrowseFolder(Me.hWnd, "Browse for application folder:")
'//

Public Function BrowseFolder(hWnd As Long, szDialogTitle As String) As String

Dim x As Long, BI As BROWSEINFO, dwIList As Long, szPath As String, wPos As Integer

BI.hOwner = hWnd
BI.lpszTitle = szDialogTitle
BI.ulFlags = BIF_RETURNONLYFSDIRS
dwIList = SHBrowseForFolder(BI)
szPath = Space$(512)
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = ""
End If

End Function

'//
'// DialogConnectToPrinter Function
'//
'// Description:
'// Allows users to interactively selection and connect to local and network printers.
'//
'// Syntax:
'// DialogConnectToPrinter
'//
'// Example:
'// DialogConnectToPrinter
'//

Public Function DialogConnectToPrinter() As Boolean

Shell "rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus

End Function

'//
'// ByteToString Function
'//
'// Description:
'// Converts an array of bytes into a string
'//
'// Syntax:
'// StrVar = ByteToString(ARRAY)
'//
'// Example:
'// szBuf = BytesToString(aChars(10))
'//

Private Function ByteToString(aBytes() As Byte) As String

Dim dwBytePoint As Long, dwByteVal As Long, szOut As String

dwBytePoint = LBound(aBytes)

While dwBytePoint <= UBound(aBytes)

dwByteVal = aBytes(dwBytePoint)

If dwByteVal = 0 Then
ByteToString = szOut
Exit Function
Else
szOut = szOut & Chr$(dwByteVal)
End If

dwBytePoint = dwBytePoint + 1

Wend

ByteToString = szOut

End Function

'//
'// DialogColor Function

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

99 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
'//
'// Description:
'// Displays the Color common dialog box and sets a passed controls foreground color.
'//
'// Syntax:
'// BOOL = DialogColor(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogColor(Me.hWnd, txtEditor)
'//

Public Function DialogColor(hWnd As Long, c As Control) As Boolean

Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long

CS.lStructSize = Len(CS)
CS.hWnd = hWnd
CS.hInstance = App.hInstance
CS.Flags = CC_SOLIDCOLOR
CS.lpCustColors = String$(16 * 4, 0)
x = ChooseColor(CS)
If x = 0 Then
DialogColor = False
Else
DialogColor = True
c.ForeColor = CS.rgbResult
End If

End Function

'//
'// DialogFile Function
'//
'// Description:
'// Displays the File Open/Save As common dialog boxes.
'//
'// Syntax:
'// StrVar = DialogFile(hWnd, IntVar, StrVar, StrVar, StrVar, StrVar, StrVar)
'//
'// Example:
'// szFilename = DialogFile(Me.hWnd, 1, "Open", "MyFileName.doc", "Documents" & Chr(0) & "*.doc" & Chr(0) & "All files" & Chr(0) & "*.*", App.Path, "doc")
'//
'// Please note that the szFilter var works a bit differently
'// from the filter property associated with the common dialog
'// control. Instead of separating the differents parts of the
'// string with pipe chars, |, you should use null chars, Chr(0),
'// as separators.

Public Function DialogFile(hWnd As Long, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String) As String

Dim x As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String

OFN.lStructSize = Len(OFN)
OFN.hWnd = hWnd
OFN.lpstrTitle = szDialogTitle
OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
OFN.nMaxFile = 255
OFN.lpstrFileTitle = String$(255, 0)
OFN.nMaxFileTitle = 255
OFN.lpstrFilter = szFilter
OFN.nFilterIndex = 1
OFN.lpstrInitialDir = szDefDir
OFN.lpstrDefExt = szDefExt

If wMode = 1 Then
OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
x = GetOpenFileName(OFN)
Else
OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
x = GetSaveFileName(OFN)
End If

If x <> 0 Then

'// If InStr(OFN.lpstrFileTitle, Chr$(0)) > 0 Then
'// szFileTitle = Left$(OFN.lpstrFileTitle, InStr(OFN.lpstrFileTitle, Chr$(0)) - 1)
'// End If
If InStr(OFN.lpstrFile, Chr$(0)) > 0 Then
szFile = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr$(0)) - 1)
End If
'// OFN.nFileOffset is the number of characters from the beginning of the
'// full path to the start of the file name
'// OFN.nFileExtension is the number of characters from the beginning of the
'// full path to the file's extention, including the (.)
'// MsgBox "File Name is " & szFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & szFile, , "Open"

'// DialogFile = szFile & "|" & szFileTitle
DialogFile = szFile

Else

DialogFile = ""

End If

End Function

'//
'// DialogFont Function
'//
'// Description:
'// Displays the Font common dialog box and sets a passed controls font properties.

作者: 61.142.212.* 2005-10-28 21:40 　回复此发言

--------------------------------------------------------------------------------

100 Windows 公共对话框的源代码,包含文件、打印机、颜色、字体、游览
'//
'// Syntax:
'// BOOL = DialogFont(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogFont(Me.hWnd, txtEditor)
'//

Public Function DialogFont(hWnd As Long, c As Control) As Boolean

Dim LF As LOGFONT, FS As FONTSTRUC
Dim lLogFontAddress As Long, lMemHandle As Long

If c.Font.Bold Then LF.lfWeight = FW_BOLD
If c.Font.Italic = True Then LF.lfItalic = 1
If c.Font.Underline = True Then LF.lfUnderline = 1

FS.lStructSize = Len(FS)

lMemHandle = GlobalAlloc(GHND, Len(LF))
If lMemHandle = 0 Then
DialogFont = False
Exit Function
End If

lLogFontAddress = GlobalLock(lMemHandle)
If lLogFontAddress = 0 Then
DialogFont = False
Exit Function
End If

CopyMemory ByVal lLogFontAddress, LF, Len(LF)
FS.lpLogFont = lLogFontAddress
FS.iPointSize = c.Font.Size * 10
FS.Flags = CF_SCREENFONTS Or CF_EFFECTS

If ChooseFont(FS) = 1 Then

CopyMemory LF, ByVal lLogFontAddress, Len(LF)

If LF.lfWeight >= FW_BOLD Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If

If LF.lfItalic = 1 Then
c.Font.Italic = True
Else
c.Font.Italic = False
End If

If LF.lfUnderline = 1 Then
c.Font.Underline = True
Else
c.Font.Underline = False
End If

c.Font.Name = ByteToString(LF.lfFaceName())
c.Font.Size = CLng(FS.iPointSize / 10)

DialogFont = True

Else

DialogFont = False

End If

End Function

'//
'// DialogPrint Function
'//
'// Description:
'// Displays the Print common dialog box and returns a structure containing user entered
'// information from the common dialog box.
'//
'// Syntax:
'// PRINTPROPS = DialogPrint(hWnd, BOOL, DWORD)
'//
'// Example:
'// Dim PP As PRINTPROPS
'// PP = DialogPrint(Me.hWnd, True, PD_PAGENUMS or PD_SELECTION or PD_SHOWHELP)
'//

Public Function DialogPrint(hWnd As Long, bPages As Boolean, Flags As Long) As PRINTPROPS

Dim DM As DEVMODE, PD As PRINTDLGSTRUC
Dim lpDM As Long, wNull As Integer, szDevName As String

PD.lStructSize = Len(PD)
PD.hWnd = hWnd
PD.hDevMode = 0
PD.hDevNames = 0
PD.hDC = 0
PD.Flags = Flags
PD.nFromPage = 0
PD.nToPage = 0
PD.nMinPage = 0
If bPages Then PD.nMaxPage = bPages - 1
PD.nCopies = 0
DialogPrint.Cancel = True

If PrintDlg(PD) Then

lpDM = GlobalLock(PD.hDevMode)
CopyMemory DM, ByVal lpDM, Len(DM)
lpDM = GlobalUnlock(PD.hDevMode)

DialogPrint.Cancel = False
DialogPrint.Device = Left$(DM.dmDeviceName, InStr(DM.dmDeviceName, Chr(0)) - 1)
DialogPrint.FromPage = 0
DialogPrint.ToPage = 0
DialogPrint.All = True
If PD.Flags And PD_PRINTTOFILE Then DialogPrint.File = True Else DialogPrint.File = False
If PD.Flags And PD_COLLATE Then DialogPrint.Collate = True Else DialogPrint.Collate = False
If PD.Flags And PD_PAGENUMS Then
DialogPrint.Pages = True
DialogPrint.All = False
DialogPrint.FromPage = PD.nFromPage
DialogPrint.ToPage = PD.nToPage
Else
DialogPrint.Pages = False
End If
If PD.Flags And PD_SELECTION Then
DialogPrint.Selection = True
DialogPrint.All = False
Else
DialogPrint.Pages = False
End If

If PD.nCopies = 1 Then
DialogPrint.Copies = DM.dmCopies
End If

DialogPrint.DM = DM

End If

End Function

'//
'// DialogPrintSetup Function
'//
'// Description:
'// Displays the Print Setup common dialog box.
'//
'// Syntax:
'// BOOL = DialogPrintSetup(hWnd)
'//
'// Example:
'// If DialogPrintSetup(Me.hWnd) Then
'// End If
'//

Public Function DialogPrintSetup(hWnd As Long) As Boolean

Dim x As Long, PD As PRINTDLGSTRUC

PD.lStructSize = Len(PD)
PD.hWnd = hWnd
PD.Flags = PD_PRINTSETUP
x = PrintDlg(PD)

End Function

101 把焦点定位到任何已运行的窗口。
' *********************************************************************
' Copyright ?995-97 Karl E. Peterson, All Rights Reserved
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' *********************************************************************
Option Explicit

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Sub cmdActivate_Click()
Dim nRet As Long
Dim Title As String
'
' Search using method user chose.
'
nRet = AppActivatePartial(Trim(txtTitle.Text), _
Val(frmMethod.Tag), CBool(chkCase.Value))
If nRet Then
lblResults.Caption = "Found: &&H" & Hex$(nRet)
Title = Space$(256)
nRet = GetWindowText(nRet, Title, Len(Title))
If nRet Then
lblResults.Caption = lblResults.Caption & _
", """ & Left$(Title, nRet) & """"
End If
Else
lblResults.Caption = "Search Failed"
End If
End Sub

Private Sub Form_Load()
'
' Setup controls.
'
txtTitle.Text = ""
lblResults.Caption = ""
optMethod(0).Value = True
End Sub

Private Sub optMethod_Click(Index As Integer)
'
' Store selected Index, which just happens to
' coincide with method Enum, into frame's Tag.
'
frmMethod.Tag = Index
End Sub
---------------
' *********************************************************************
' Copyright ?995-98 Karl E. Peterson, All Rights Reserved
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' *********************************************************************
Option Explicit
'
' Required Win32 API Declarations
'
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
'
' Constants used with APIs
'
Private Const SW_RESTORE = 9
'
' Private variables needed to support enumeration
'
Private m_hWnd As Long
Private m_Method As FindWindowPartialTypes
Private m_CaseSens As Boolean
Private m_Visible As Boolean
Private m_AppTitle As String
'
' Constants used by FindWindowPartial

作者: 61.142.212.* 2005-10-28 21:41 　回复此发言

--------------------------------------------------------------------------------

102 把焦点定位到任何已运行的窗口。
'
Public Enum FindWindowPartialTypes
FwpStartsWith = 0
FwpContains = 1
FwpMatches = 2
End Enum

Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWindowPartialTypes = FwpStartsWith, Optional CaseSensitive As Boolean = False) As Long
Dim hWndApp As Long
'
' Retrieve window handle for first top-level window
' that starts with or contains the passed string.
'
hWndApp = FindWindowPartial(AppTitle, Method, CaseSensitive, True)
If hWndApp Then
'
' Switch to it, restoring if need be.
'
If IsIconic(hWndApp) Then
Call ShowWindow(hWndApp, SW_RESTORE)
End If
Call SetForegroundWindow(hWndApp)
AppActivatePartial = hWndApp
End If
End Function

Public Function FindWindowPartial(AppTitle As String, _
Optional Method As FindWindowPartialTypes = FwpStartsWith, _
Optional CaseSensitive As Boolean = False, _
Optional MustBeVisible As Boolean = False) As Long
'
' Reset all search parameters.
'
m_hWnd = 0
m_Method = Method
m_CaseSens = CaseSensitive
m_AppTitle = AppTitle
'
' Upper-case search string if case-insensitive.
'
If m_CaseSens = False Then
m_AppTitle = UCase$(m_AppTitle)
End If
'
' Fire off enumeration, and return m_hWnd when done.
'
Call EnumWindows(AddressOf EnumWindowsProc, MustBeVisible)
FindWindowPartial = m_hWnd
End Function

Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Static WindowText As String
Static nRet As Long
'
' Make sure we meet visibility requirements.
'
If lParam Then 'window must be visible
If IsWindowVisible(hWnd) = False Then
EnumWindowsProc = True
End If
End If
'
' Retrieve windowtext (caption)
'
WindowText = Space$(256)
nRet = GetWindowText(hWnd, WindowText, Len(WindowText))
If nRet Then
'
' Clean up window text and prepare for comparison.
'
WindowText = Left$(WindowText, nRet)
If m_CaseSens = False Then
WindowText = UCase$(WindowText)
End If
'
' Use appropriate method to determine if
' current window's caption either starts
' with, contains, or matches passed string.
'
Select Case m_Method
Case FwpStartsWith
If InStr(WindowText, m_AppTitle) = 1 Then
m_hWnd = hWnd
End If
Case FwpContains
If InStr(WindowText, m_AppTitle) <> 0 Then
m_hWnd = hWnd
End If
Case FwpMatches
If WindowText = m_AppTitle Then
m_hWnd = hWnd
End If
End Select
End If
'
' Return True to continue enumeration if we haven't
' found what we're looking for.
'
EnumWindowsProc = (m_hWnd = 0)
End Function

作者: 61.142.212.* 2005-10-28 21:41 　回复此发言

--------------------------------------------------------------------------------

103 另一个实现窗口背景的渐变。
Option Explicit
Dim fadeStyle As Integer
Private Sub FadeForm(frmIn As Form, fadeStyle As Integer)
'fadeStyle = 0 produces diagonal gradient
'fadeStyle = 1 produces vertical gradient
'fadeStyle = 2 produces horizontal gradient
'any other value produces solid medium-blue background
Static ColorBits As Long
Static RgnCnt As Integer
Dim NbrPlanes As Long
Dim BitsPerPixel As Long
Dim AreaHeight As Long
Dim AreaWidth As Long
Dim BlueLevel As Long
Dim prevScaleMode As Integer
Dim IntervalY As Long
Dim IntervalX As Long
Dim i As Integer
Dim r As Long
Dim ColorVal As Long
Dim FillArea As RECT
Dim hBrush As Long
'init code - performed only on the first pass through this routine.
If ColorBits = 0 Then
'determine number of color bits supported.
BitsPerPixel = GetDeviceCaps(frmIn.hDC, BITSPIXEL)
NbrPlanes = GetDeviceCaps(frmIn.hDC, PLANES)
ColorBits = (BitsPerPixel * NbrPlanes)
'Calculate the number of regions that the screen will be divided o.
'This is optimized for the current display's color depth. Why waste
'time rendering 256 shades if you can only discern 32 or 64 of them?
Select Case ColorBits
Case 32: RgnCnt = 256 '16M colors: 8 bits for blue
Case 24: RgnCnt = 256 '16M colors: 8 bits for blue
Case 16: RgnCnt = 256 '64K colors: 5 bits for blue
Case 15: RgnCnt = 32 '32K colors: 5 bits for blue
Case 8: RgnCnt = 64 '256 colors: 64 dithered blues
Case 4: RgnCnt = 64 '16 colors : 64 dithered blues
Case Else: ColorBits = 4
RgnCnt = 64 '16 colors assumed: 64 dithered blues
End Select
End If 'if solid then set and bail out

If fadeStyle = 3 Then
frmIn.BackColor = &H7F0000 ' med blue
Exit Sub
End If

prevScaleMode = frmIn.ScaleMode 'save the current scalemode
frmIn.ScaleMode = 3 'set to pixel
AreaHeight = frmIn.ScaleHeight 'calculate sizes
AreaWidth = frmIn.ScaleWidth
frmIn.ScaleMode = prevScaleMode 'reset to saved value
ColorVal = 256 / RgnCnt 'color diff between regions
IntervalY = AreaHeight / RgnCnt '# vert pixels per region
IntervalX = AreaWidth / RgnCnt '# horz pixels per region
'fill the client area from bottom/right
'to top/left except for top/left region
FillArea.Left = 0
FillArea.Top = 0
FillArea.Right = AreaWidth
FillArea.Bottom = AreaHeight
BlueLevel = 0
For i = 0 To RgnCnt - 1
'create a brush of the appropriate blue colour
hBrush = CreateSolidBrush(RGB(0, 0, BlueLevel))
If fadeStyle = 0 Then 'diagonal gradient
FillArea.Top = FillArea.Bottom - IntervalY
FillArea.Left = 0
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Top = 0
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
FillArea.Right = FillArea.Right - IntervalX
ElseIf fadeStyle = 1 Then 'horizontal gradient
FillArea.Top = FillArea.Bottom - IntervalY
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
Else
'vertical gradient
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Right = FillArea.Right - IntervalX
End If
'done with that brush, so delete
r = DeleteObject(hBrush)
'increment the value by the appropriate
'steps for the display colour depth
BlueLevel = BlueLevel + ColorVal
Next 'Fill any the remaining top/left holes of the client area with solid blue
FillArea.Top = 0
FillArea.Left = 0
hBrush = CreateSolidBrush(RGB(0, 0, 255))
r = FillRect(frmIn.hDC, FillArea, hBrush)
r = DeleteObject(hBrush)
Me.Refresh
End Sub
Private Sub Form_Load()
fadeStyle = 0
mnuStyle(fadeStyle).Checked = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then PopupMenu zmnuStyle
End Sub

Private Sub Form_Resize()
If WindowState <> 1 Then
FadeForm Me, fadeStyle
End If
End Sub

Private Sub mnuStyle_Click(Index As Integer)
'track the current selection
Static prevStyle As Integer
'uncheck the last selection
mnuStyle(prevStyle).Checked = False
'set the variable indicating the style
fadeStyle = Index
'draw the new style
FadeForm Me, fadeStyle
'update the current selection
mnuStyle(fadeStyle).Checked = True
prevStyle = fadeStyle
End Sub
--------------
Option Explicit
Public Const PLANES = 14 ' Number of planes
Public Const BITSPIXEL = 12 ' Number of bits per pixel
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Declare Function FillRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long

作者: 61.142.212.* 2005-10-28 21:42 　回复此发言

--------------------------------------------------------------------------------

104 检测当前按键状态(非常不错)
Option Explicit

Private Sub Command1_Click()
Picture1.Picture = Image1.Picture
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Command3_Click()
Picture1.Picture = LoadPicture("")
End Sub

Private Sub Command4_Click()
Dim dl As Long
Form2.Show
End Sub

Private Sub Form_Load()
Dim i As Integer

Move (Screen.Width - Form1.Width) \ 2, (Screen.Height - Form1.Height) \ 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub Timer1_Timer()
Dim i As Integer
Dim Key(0 To 255) As Byte
Dim dl As Long
Dim KeyCode As Long
Dim KeyName As String * 256
List1.Clear
dl& = GetKeyboardState(Key(0)) '获取当前按键状态
For i = 0 To 254
If Key(i) And &H80 Then
KeyCode& = MapVirtualKey(i, 0)
dl& = GetKeyNameText(KeyCode * &H10000, KeyName, 255)
List1.AddItem "[ " & Left(KeyName, dl&) & " ]键,虚拟键码为(十进制)∶" & CStr(i) & Chr(13) & Chr(10)
End If
Next
End Sub

Private Sub Timer2_Timer()
Dim Key As Integer
Dim NowKey As Long

NowKey = 0
If HotKey = 0 Then Exit Sub
Key% = GetKeyState(VK_SHIFT)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_SHIFT
Key% = GetKeyState(VK_CONTROL)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_CONTROL
Key% = GetKeyState(VK_MENU)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_ALT
Key% = GetKeyState(HotKey_Cild)
If Key And &H4000 And HotKey = NowKey Then
Command1_Click
End If
End Sub
-----------
Option Explicit
Private isALT As Byte
Private isCONTROL As Byte
Private isSHIFT As Byte
Private Sub Command1_Click(Index As Integer)
If Index = 0 Then
If Check2.Value = 1 Then
HotKey = 0
If Check1(0).Value = 1 Then HotKey = HotKey Or HOTKEYF_CONTROL
If Check1(1).Value = 1 Then HotKey = HotKey Or HOTKEYF_ALT
If Check1(2).Value = 1 Then HotKey = HotKey Or HOTKEYF_SHIFT
HotKey_Cild = Asc(Combo1.Text)
Else
HotKey = 0
End If
End If
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer
Move (Screen.Width - Form2.Width) \ 2, (Screen.Height - Form2.Height) \ 2

Combo1.Clear
For i = 48 To 57
Combo1.AddItem Chr(i)
Next
For i = 65 To 90
Combo1.AddItem Chr(i)
Next

If HotKey = 0 Then
Combo1.ListIndex = 0
Else
Check2.Value = 1
Combo1.Text = Chr(HotKey_Cild)
If HotKey And HOTKEYF_CONTROL Then Check1(0).Value = 1
If HotKey And HOTKEYF_ALT Then Check1(1).Value = 1
If HotKey And HOTKEYF_SHIFT Then Check1(2).Value = 1
End If

Call SetWindowWord(hwnd, GWL_HWNDPARENT, Form1.hwnd)
Form1.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)

Form1.Enabled = True
End Sub
--------------
Option Explicit

Public Declare Function GetKeyboardState& Lib "user32" (pbKeyState As Byte)
Public Declare Function GetKeyNameText& Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long)
Public Declare Function MapVirtualKey& Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long)
Public Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
Public Declare Function SetWindowWord& Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long)
Public Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)

Public Const GWL_HWNDPARENT& = (-8)

Public Const HOTKEYF_SHIFT = &H1
Public Const HOTKEYF_CONTROL = &H2
Public Const HOTKEYF_ALT = &H4

Public Const VK_CONTROL& = &H11
Public Const VK_SHIFT& = &H10
Public Const VK_MENU& = &H12

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public HotKey As Long
Public HotKey_Cild As Long

作者: 61.142.212.* 2005-10-28 21:44 　回复此发言

--------------------------------------------------------------------------------

105 利用Windows的未公开函数SHChangeNotifyRegister实现文件目录操作
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")

' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================

Private m_hSHNotify As Long ' the one and only shell change notification handle for the desktop folder
Private m_pidlDesktop As Long ' the desktop's pidl

' User defined notiication message sent to the specified window's window proc.
Public Const WM_SHNOTIFY = &H401

' ====================================================================

Public Type PIDLSTRUCT
' Fully qualified pidl (relative to the desktop folder) of the folder to monitor changes in.
' 0 can also be specifed for the desktop folder.
pidl As Long
' Value specifying whether changes in the folder's subfolders trigger a change notification
' event (it's actually a Boolean, but we'll go Long because of VB's DWORD struct alignment).
bWatchSubFolders As Long
End Type

Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long

' hWnd - Handle of the window to receive the window message specified in uMsg.

' uFlags - Flag that indicates the meaning of the dwItem1 and dwItem2 members of the
' SHNOTIFYSTRUCT (which is pointed to by the window procedure's wParam
' value when the specifed window message is received). This parameter can
' be one of the SHCN_ItemFlags enum values below.
' This interpretaion may be inaccurate as it appears pdils are almost alway returned
' in the SHNOTIFYSTRUCT. See James' site for more info...

' dwEventId - Combination of SHCN_EventIDs enum values that specifies what events the
' specified window will be notified of. See below.

' uMsg - Window message to be used to identify receipt of a shell change notification.
' The message should *not* be a value that lies within the specifed window's
' message range ( i.e. BM_ messages for a button window) or that window may
' not receive all (if not any) notifications sent by the shell!!!

' cItems - Count of PIDLSTRUCT structures in the array pointed to by the lpps param.

' lpps - Pointer to an array of PIDLSTRUCT structures indicating what folder(s) to monitor
' changes in, and whether to watch the specified folder's subfolder.

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

106 利用Windows的未公开函数SHChangeNotifyRegister实现文件目录操作

' If successful, returns a notification handle which must be passed to SHChangeNotifyDeregister
' when no longer used. Returns 0 otherwise.

' Once the specified message is registered with SHChangeNotifyRegister, the specified
' window's function proc will be notified by the shell of the specified event in (and under)
' the folder(s) speciifed in apidl. On message receipt, wParam points to a SHNOTIFYSTRUCT
' and lParam contains the event's ID value.

' The values in dwItem1 and dwItem2 are event specific. See the description of the values
' for the wEventId parameter of the documented SHChangeNotify API function.
Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type

' ...?
'Declare Function SHChangeNotifyUpdateEntryList Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal Unknown As Long, _
' ByVal cItem As Long, _
' lpps As PIDLSTRUCT) As Boolean
'
'Declare Function SHChangeNotifyReceive Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal uFlags As SHCN_ItemFlags, _
' ByVal dwItem1 As Long, _
' ByVal dwItem2 As Long) As Long

' Closes the notification handle returned from a call to SHChangeNotifyRegister.
' Returns True if succeful, False otherwise.
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean

' ====================================================================

' This function should be called by any app that changes anything in the shell.
' The shell will then notify each "notification registered" window of this action.
Declare Sub SHChangeNotify Lib "shell32" _
(ByVal wEventId As SHCN_EventIDs, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwItem1 As Long, _
ByVal dwItem2 As Long)

' Shell notification event IDs

Public Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1 ' (D) A nonfolder item has been renamed.
SHCNE_CREATE = &H2 ' (D) A nonfolder item has been created.
SHCNE_DELETE = &H4 ' (D) A nonfolder item has been deleted.
SHCNE_MKDIR = &H8 ' (D) A folder item has been created.
SHCNE_RMDIR = &H10 ' (D) A folder item has been removed.
SHCNE_MEDIAINSERTED = &H20 ' (G) Storage media has been inserted into a drive.
SHCNE_MEDIAREMOVED = &H40 ' (G) Storage media has been removed from a drive.
SHCNE_DRIVEREMOVED = &H80 ' (G) A drive has been removed.
SHCNE_DRIVEADD = &H100 ' (G) A drive has been added.
SHCNE_NETSHARE = &H200 ' A folder on the local computer is being shared via the network.
SHCNE_NETUNSHARE = &H400 ' A folder on the local computer is no longer being shared via the network.
SHCNE_ATTRIBUTES = &H800 ' (D) The attributes of an item or folder have changed.
SHCNE_UPDATEDIR = &H1000 ' (D) The contents of an existing folder have changed, but the folder still exists and has not been renamed.
SHCNE_UPDATEITEM = &H2000 ' (D) An existing nonfolder item has changed, but the item still exists and has not been renamed.
SHCNE_SERVERDISCONNECT = &H4000 ' The computer has disconnected from a server.
SHCNE_UPDATEIMAGE = &H8000& ' (G) An image in the system image list has changed.

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

107 利用Windows的未公开函数SHChangeNotifyRegister实现文件目录操作
SHCNE_DRIVEADDGUI = &H10000 ' (G) A drive has been added and the shell should create a new window for the drive.
SHCNE_RENAMEFOLDER = &H20000 ' (D) The name of a folder has changed.
SHCNE_FREESPACE = &H40000 ' (G) The amount of free space on a drive has changed.

#If (WIN32_IE >= &H400) Then
SHCNE_EXTENDED_EVENT = &H4000000 ' (G) Not currently used.
#End If ' WIN32_IE >= &H0400

SHCNE_ASSOCCHANGED = &H8000000 ' (G) A file type association has changed.

SHCNE_DISKEVENTS = &H2381F ' Specifies a combination of all of the disk event identifiers. (D)
SHCNE_GLOBALEVENTS = &HC0581E0 ' Specifies a combination of all of the global event identifiers. (G)
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000 ' The specified event occurred as a result of a system interrupt.
' It is stripped out before the clients of SHCNNotify_ see it.
End Enum

#If (WIN32_IE >= &H400) Then ' ???
Public Const SHCNEE_ORDERCHANGED = &H2 ' dwItem2 is the pidl of the changed folder
#End If

' Notification flags

' uFlags & SHCNF_TYPE is an ID which indicates what dwItem1 and dwItem2 mean
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0 ' LPITEMIDLIST
SHCNF_PATHA = &H1 ' path name
SHCNF_PRINTERA = &H2 ' printer friendly name
SHCNF_DWORD = &H3 ' DWORD
SHCNF_PATHW = &H5 ' path name
SHCNF_PRINTERW = &H6 ' printer friendly name
SHCNF_TYPE = &HFF
' Flushes the system event buffer. The function does not return until the system is
' finished processing the given event.
SHCNF_FLUSH = &H1000
' Flushes the system event buffer. The function returns immediately regardless of
' whether the system is finished processing the given event.
SHCNF_FLUSHNOWAIT = &H2000

#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
'

' Registers the one and only shell change notification.

Public Function SHNotify_Register(hWnd As Long) As Boolean
Dim ps As PIDLSTRUCT

' If we don't already have a notification going...
If (m_hSHNotify = 0) Then

' Get the pidl for the desktop folder.
m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If m_pidlDesktop Then

' Fill the one and only PIDLSTRUCT, we're watching
' desktop and all of the it's subfolders, everything...
ps.pidl = m_pidlDesktop
ps.bWatchSubFolders = True

' Register the notification, specifying that we want the dwItem1 and dwItem2
' members of the SHNOTIFYSTRUCT to be pidls. We're watching all events.
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, ps)
Debug.Print Hex(SHCNF_TYPE Or SHCNF_IDLIST)
Debug.Print Hex(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT)
Debug.Print m_hSHNotify
SHNotify_Register = CBool(m_hSHNotify)

Else
' If something went wrong...
Call CoTaskMemFree(m_pidlDesktop)

End If ' m_pidlDesktop
End If ' (m_hSHNotify = 0)

End Function

' Unregisters the one and only shell change notification.

Public Function SHNotify_Unregister() As Boolean

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

108 利用Windows的未公开函数SHChangeNotifyRegister实现文件目录操作

' If we have a registered notification handle.
If m_hSHNotify Then
' Unregister it. If the call is successful, zero the handle's variable,
' free and zero the the desktop's pidl.
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_pidlDesktop)
m_pidlDesktop = 0
SHNotify_Unregister = True
End If
End If

End Function

' Returns the event string associated with the specified event ID value.

Public Function SHNotify_GetEventStr(dwEventID As Long) As String
Dim sEvent As String

Select Case dwEventID
Case SHCNE_RENAMEITEM: sEvent = "SHCNE_RENAMEITEM" ' = &H1"
Case SHCNE_CREATE: sEvent = "SHCNE_CREATE" ' = &H2"
Case SHCNE_DELETE: sEvent = "SHCNE_DELETE" ' = &H4"
Case SHCNE_MKDIR: sEvent = "SHCNE_MKDIR" ' = &H8"
Case SHCNE_RMDIR: sEvent = "SHCNE_RMDIR" ' = &H10"
Case SHCNE_MEDIAINSERTED: sEvent = "SHCNE_MEDIAINSERTED" ' = &H20"
Case SHCNE_MEDIAREMOVED: sEvent = "SHCNE_MEDIAREMOVED" ' = &H40"
Case SHCNE_DRIVEREMOVED: sEvent = "SHCNE_DRIVEREMOVED" ' = &H80"
Case SHCNE_DRIVEADD: sEvent = "SHCNE_DRIVEADD" ' = &H100"
Case SHCNE_NETSHARE: sEvent = "SHCNE_NETSHARE" ' = &H200"
Case SHCNE_NETUNSHARE: sEvent = "SHCNE_NETUNSHARE" ' = &H400"
Case SHCNE_ATTRIBUTES: sEvent = "SHCNE_ATTRIBUTES" ' = &H800"
Case SHCNE_UPDATEDIR: sEvent = "SHCNE_UPDATEDIR" ' = &H1000"
Case SHCNE_UPDATEITEM: sEvent = "SHCNE_UPDATEITEM" ' = &H2000"
Case SHCNE_SERVERDISCONNECT: sEvent = "SHCNE_SERVERDISCONNECT" ' = &H4000"
Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE" ' = &H8000&"
Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI" ' = &H10000"
Case SHCNE_RENAMEFOLDER: sEvent = "SHCNE_RENAMEFOLDER" ' = &H20000"
Case SHCNE_FREESPACE: sEvent = "SHCNE_FREESPACE" ' = &H40000"

#If (WIN32_IE >= &H400) Then
Case SHCNE_EXTENDED_EVENT: sEvent = "SHCNE_EXTENDED_EVENT" ' = &H4000000"
#End If ' WIN32_IE >= &H0400

Case SHCNE_ASSOCCHANGED: sEvent = "SHCNE_ASSOCCHANGED" ' = &H8000000"

Case SHCNE_DISKEVENTS: sEvent = "SHCNE_DISKEVENTS" ' = &H2381F"
Case SHCNE_GLOBALEVENTS: sEvent = "SHCNE_GLOBALEVENTS" ' = &HC0581E0"
Case SHCNE_ALLEVENTS: sEvent = "SHCNE_ALLEVENTS" ' = &H7FFFFFFF"
Case SHCNE_INTERRUPT: sEvent = "SHCNE_INTERRUPT" ' = &H80000000"
End Select

SHNotify_GetEventStr = sEvent

End Function
--------------------

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

109 回复 107:利用Windows的未公开函数SHChangeNotifyRegister实现文
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

' ====================================================================

Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Const MAX_PATH = 260

' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0

' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum

' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long

' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
Declare Function SHGetFileInfoPidl Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pidl As Long, _
ByVal dwFileAttributes As Long, _
psfib As SHFILEINFOBYTE, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long

' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type

Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

110 回复 107:利用Windows的未公开函数SHChangeNotifyRegister实现文
psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long

Public Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Enum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'

' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)

' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder ID

Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long
Dim pidl As Long
If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then
GetPIDLFromFolderID = pidl
End If
End Function

' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.

Public Function GetDisplayNameFromPIDL(pidl As Long) As String
Dim sfib As SHFILEINFOBYTE
If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then
GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
End If
End Function

' Returns a path from only an absolute pidl (relative to the desktop)

Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function

' Returns the string before first null char encountered (if any) from an ANSII string.

Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

111 回复 110:利用Windows的未公开函数SHChangeNotifyRegister实现文
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

Private Const WM_NCDESTROY = &H82

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) 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 Const GWL_WNDPROC = (-4)

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const OLDWNDPROC = "OldWndProc"
'

Public Function SubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean

If (GetProp(hWnd, OLDWNDPROC) = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If
End If

If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call UnSubClass(hWnd)
MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
End If

End Function

Public Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long

lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If RemoveProp(hWnd, OLDWNDPROC) Then
UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
End If
End If

End Function

Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Select Case uMsg
Case WM_SHNOTIFY
Call Form1.NotificationReceipt(wParam, lParam)

Case WM_NCDESTROY
Call UnSubClass(hWnd)
MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"

End Select

WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)

End Function

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

112 回复 111:利用Windows的未公开函数SHChangeNotifyRegister实现文
Option Explicit
'
' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp
'
' Code was written in and formatted for 8pt MS San Serif
'
' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")
'
' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================
'

Private Sub Form_Load()
If SubClass(hWnd) Then
If IsIDE Then
Text1.Text = vbCrLf & _
"一个 Windows的文件目录操作即时监视程序," & vbCrLf & "可以监视在Explore中的重命名、新建、删除文" & _
vbCrLf & "件或目录;改变文件关联;插入、取出CD和添加" & vbCrLf & "删除网络共享都可以被该程序记录下来。"
End If
Call SHNotify_Register(hWnd)
'Else
' Text1 = "Uh..., it's supposed to work... :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End Sub

Private Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End Function

Private Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End Sub

Private Sub Form_Resize()
On Error GoTo Out
Text1.Move 0, 0, ScaleWidth, ScaleHeight
Out:
End Sub

Public Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT

sOut = SHNotify_GetEventStr(lParam) & vbCrLf

' Fill the SHNOTIFYSTRUCT from it's pointer.
MoveMemory shns, ByVal wParam, Len(shns)

' lParam is the ID of the notication event, one of the SHCN_EventIDs.
Select Case lParam

' ================================================================
' For the SHCNE_FREESPACE event, dwItem1 points to what looks like a 10 byte
' struct. The first two bytes are the size of the struct, and the next two members
' equate to SHChangeNotify's dwItem1 and dwItem2 params. The dwItem1 member
' is a bitfield indicating which drive(s) had it's (their) free space changed. The bitfield
' is identical to the bitfield returned from a GetLogicalDrives call, i.e, bit 0 = A:\, bit
' 1 = B:\, 2, = C:\, etc. Since VB does DWORD alignment when MoveMemory'ing
' to a struct, we'll extract the bitfield directly from it's memory location.
Case SHCNE_FREESPACE
Dim dwDriveBits As Long
Dim wHighBit As Integer
Dim wBit As Integer

MoveMemory dwDriveBits, ByVal shns.dwItem1 + 2, 4

' Get the zero based position of the highest bit set in the bitmask
' (essentially determining the value's highest complete power of 2).
' Use floating point division (we want the exact values from the Logs)
' and remove the fractional value (the fraction indicates the value of

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

113 回复 111:利用Windows的未公开函数SHChangeNotifyRegister实现文
' the last incomplete power of 2, which means the bit isn't set).
wHighBit = Int(Log(dwDriveBits) / Log(2))

For wBit = 0 To wHighBit
' If the bit is set...
If (2 ^ wBit) And dwDriveBits Then

' The bit is set, get it's drive string
sOut = sOut & Chr$(vbKeyA + wBit) & ":\" & vbCrLf

End If
Next

' ================================================================
' shns.dwItem1 also points to a 10 byte struct. The struct's second member (after the
' struct's first WORD size member) points to the system imagelist index of the image
' that was updated.
Case SHCNE_UPDATEIMAGE
Dim iImage As Long

MoveMemory iImage, ByVal shns.dwItem1 + 2, 4
sOut = sOut & "Index of image in system imagelist: " & iImage & vbCrLf

' ================================================================
' Everything else except SHCNE_ATTRIBUTES is the pidl(s) of the changed item(s).
' For SHCNE_ATTRIBUTES, neither item is used. See the description of the values
' for the wEventId parameter of the SHChangeNotify API function for more info.
Case Else
Dim sDisplayname As String

If shns.dwItem1 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem1)
If Len(sDisplayname) Then
sOut = sOut & "first item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "first item path: " & GetPathFromPIDL(shns.dwItem1) & vbCrLf
Else
sOut = sOut & "first item is invalid" & vbCrLf
End If
End If

If shns.dwItem2 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem2)
If Len(sDisplayname) Then
sOut = sOut & "second item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "second item path: " & GetPathFromPIDL(shns.dwItem2) & vbCrLf
Else
sOut = sOut & "second item is invalid" & vbCrLf
End If
End If

End Select

Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
tmrFlashMe = True

End Sub

Private Sub tmrFlashMe_Timer() ' initial settings: Interval = 1, Enabled = False
Static nCount As Integer

If nCount = 0 Then tmrFlashMe.Interval = 200
nCount = nCount + 1
Call FlashWindow(hWnd, True)

' Reset everything after 3 flash cycles
If nCount = 6 Then
nCount = 0
tmrFlashMe.Interval = 1
tmrFlashMe = False
End If

End Sub

作者: 61.142.212.* 2005-10-28 21:46 　回复此发言

--------------------------------------------------------------------------------

114 外壳程序的例子
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub cmdOpen_Click()

'check that the file in the text box exists
If Dir(txtFile) = "" Then
Call MsgBox("The file in the text box does not exist.", vbExclamation)
Exit Sub
End If

'open the file with the default program
Call ShellExecute(hwnd, "Open", txtFile, "", App.Path, 1)

'Note: This is the equivalent of
'right clicking on a file in Windows95
'and selecting "Open"
'
'If you would like to do something
'else to the file rather than opening
'it, right click on a file and see
'what options are in the menu. Then
'change the "Open" in the code above to
'read what the menu item says.
'
'Note: This code is great for opening
'web document into the default
'browser. To open http://www.jelsoft.com
'into the default browser the following
'code would be used:
'
'Call ShellExecute(hwnd,"Open","http://www.jelsoft.com","",app.path,1)
'
'For more demos, please visit Jelsoft VB-World at
'http://www.jelsoft.com
'
'If you have a question or a query, please
'send an email to vbw@jelsoft.com.

End Sub

Private Sub cmdWebSite_Click()
'open up VB-World in the default browser.
Call ShellExecute(hwnd, "Open", "http://www.jelsoft.com/vbw/", "", App.Path, 1)
End Sub

作者: 61.142.212.* 2005-10-28 21:47 　回复此发言

--------------------------------------------------------------------------------

115 用程序终止另一个进程
Option Explicit

Private Sub CmdEndTask_Click()
TerminateTask TaskText.Text
End Sub

----------
Option Explicit

Declare Function EnumWindows Lib "user32" (ByVal wndenmprc As Long, ByVal lParam As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_CLOSE = &H10

Private Target As String
' Check a returned task to see if we should
' kill it.
Public Function EnumCallback(ByVal app_hWnd As Long, ByVal param As Long) As Long
Dim buf As String * 256
Dim title As String
Dim length As Long

' Get the window's title.
length = GetWindowText(app_hWnd, buf, Len(buf))
title = Left$(buf, length)

' See if this is the target window.
If InStr(title, Target) <> 0 Then
' Kill the window.
SendMessage app_hWnd, WM_CLOSE, 0, 0
End If

' Continue searching.
EnumCallback = 1
End Function

' Ask Windows for the list of tasks.
Public Sub TerminateTask(app_name As String)
Target = app_name
EnumWindows AddressOf EnumCallback, 0
End Sub

作者: 61.142.212.* 2005-10-28 21:49 　回复此发言

--------------------------------------------------------------------------------

116 一个任务列表和切换程序演示
Option Explicit

'WIN16/32 Directive
#If Win16 Then
Declare Function ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal flgs As Integer) As Integer
Declare Function GetWindow Lib "User" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal wIndx As Integer) As Integer
Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal wIndx As Integer) As Long
Declare Function GetWindowText Lib "User" (ByVal hWnd As Integer, ByVal lpSting As String, ByVal nMaxCount As Integer) As Integer
Declare Function GetWindowTextLength Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal insaft As Integer, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, ByVal flgs As Integer) As Integer
#Else
Private Declare Function ShowWindow Lib "User32" (ByVal hWnd As Long, ByVal flgs As Long) As Long
Private Declare Function GetWindow Lib "User32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowWord Lib "User32" (ByVal hWnd As Long, ByVal wIndx As Long) As Long
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal wIndx As Long) As Long
Private Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpSting As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowTextLength Lib "User32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal insaft As Long, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, ByVal flgs As Long) As Long
#End If

Const WS_MINIMIZE = &H20000000 ' Style bit 'is minimized'
Const HWND_TOP = 0 ' Move to top of z-order
Const SWP_NOSIZE = &H1 ' Do not re-size window
Const SWP_NOMOVE = &H2 ' Do not reposition window
Const SWP_SHOWWINDOW = &H40 ' Make window visible/active
Const GW_HWNDFIRST = 0 ' Get first Window handle
Const GW_HWNDNEXT = 2 ' Get next window handle
Const GWL_STYLE = (-16) ' Get Window's style bits
Const SW_RESTORE = 9 ' Restore window
Dim IsTask As Long ' Style bits for normal task

' The following bits will be combined to define properties
' of a 'normal' task top-level window. Any window with ' these set will be
' included in the list:
Const WS_VISIBLE = &H10000000 ' Window is not hidden
Const WS_BORDER = &H800000 ' Window has a border

' Other bits that are normally set include:
Const WS_CLIPSIBLINGS = &H4000000 ' can clip windows
Const WS_THICKFRAME = &H40000 ' Window has thick border
Const WS_GROUP = &H20000 ' Window is top of group
Const WS_TABSTOP = &H10000 ' Window has tabstop

Sub cmdExit_Click()
Unload Me ' Get me out of here!
'Set Me = Nothing ' Kill Form reference for good measure
End Sub

Sub cmdRefresh_Click()
FindAllApps ' Update list of tasks
End Sub

Sub cmdSwitch_Click()
Dim hWnd As Long ' handle to window
Dim x As Long ' work area
Dim lngWW As Long ' Window Style bits
If lstApp.ListIndex < 0 Then Beep: Exit Sub
' Get window handle from listbox array
hWnd = lstApp.ItemData(lstApp.ListIndex)
' Get style bits for window
lngWW = GetWindowLong(hWnd, GWL_STYLE)
' If minimized do a restore
If lngWW And WS_MINIMIZE Then
x = ShowWindow(hWnd, SW_RESTORE)
End If
' Move window to top of z-order/activate; no move/resize
x = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW)
End Sub

Sub FindAllApps()
Dim hwCurr As Long
Dim intLen As Long
Dim strTitle As String
' process all top-level windows in master window list
lstApp.Clear
hwCurr = GetWindow(Me.hWnd, GW_HWNDFIRST) ' get first window
Do While hwCurr ' repeat for all windows
If hwCurr <> Me.hWnd And TaskWindow(hwCurr) Then
intLen = GetWindowTextLength(hwCurr) + 1 ' Get length
strTitle = Space$(intLen) ' Get caption
intLen = GetWindowText(hwCurr, strTitle, intLen)
If intLen > 0 Then ' If we have anything, add it
lstApp.AddItem strTitle
' and let's save the window handle in the itemdata array
lstApp.ItemData(lstApp.NewIndex) = hwCurr
End If
End If
hwCurr = GetWindow(hwCurr, GW_HWNDNEXT)
Loop
End Sub

Sub Form_Load()
IsTask = WS_VISIBLE Or WS_BORDER ' Define bits for normal task
FindAllApps ' Update list
End Sub

Sub Form_Paint()
FindAllApps ' Update List
End Sub

Sub Label1_Click()
FindAllApps ' Update list
End Sub

Sub lstApp_DblClick()
cmdSwitch.Value = True
End Sub

Function TaskWindow(hwCurr As Long) As Long
Dim lngStyle As Long
lngStyle = GetWindowLong(hwCurr, GWL_STYLE)
If (lngStyle And IsTask) = IsTask Then TaskWindow = True
End Function

作者: 61.142.212.* 2005-10-28 21:50 　回复此发言

--------------------------------------------------------------------------------

117 允许你让EXE文件在用户第一次使用时输入用户名和序列号, 并将信息
Private Sub Command1_Click()
FiletoImplant$ = SourcePath.Tag + "SICONVRT.EXE" '.EXE file to brand
NumChars% = 30 'Maximum # of chars per string
NumStrings% = 3 'Number of strings to implant

For i = 1 To NumStrings% 'Implant the strings
ImplantString$ = UserText(i - 1).Text 'User input
SearchString$ = String$(NumChars%, 87 + i) 'Start with X
Branded% = Implant(FiletoImplant$, ImplantString$, SearchString$, NumChars%)
If Branded% <> True Then
MsgBox "This copy is already registered to another user.", 48, UserDlg.Caption
UserText(0).SetFocus
UserText(0).SelStart = 0
UserText(0).SelLength = Len(UserText(0).Text)
End If
Next i

outButton.Tag = "continue" 'Move on to next step
UserDlg.Hide
End Sub

Private Sub Command2_Click()
outButton.Tag = "exit"
UserDlg.Hide
End Sub

Private Function Implant(FiletoImplant As String, ImplantString As String, SearchString As String, NumChars As Integer) As Integer
'Brands .EXE file with user information.
'FiletoImplant - .EXE file to be implanted
'ImplantString - string to be implanted (e.g., user name)
'SearchString - string in the .EXE file to be replaced by ImplantString
' (e.g., Const UserName$ = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX")
'NumChars - number of characters in SearchString
'Function returns TRUE if successful, FALSE if not

Const BlockSize = 32768 'size of block read from disk
Dim FileData As String 'string to hold block read from disk
Dim NumBlocks As Integer 'number of complete blocks in .EXE file
Dim LeftOver As Integer 'amount left in partial block
Dim FileLength As Long 'length of .EXE file
Dim BlockPosn As Integer 'block number to be checked

Open FiletoImplant For Binary As #1
FileLength = LOF(1)
NumBlocks = FileLength \ BlockSize
LeftOver = FileLength Mod BlockSize
FileData = String$(BlockSize, 32)
BlockPosn = 0

For Index = 1 To NumBlocks 'search the .EXE file for special
Get #1, , FileData 'string and record location
Posn& = InStr(FileData, SearchString)
If Posn& > 0 Then 'found it!
BlockPosn = Index
Seek 1, Posn& + ((BlockPosn - 1) * BlockSize)
Exit For
End If
Next Index

If BlockPosn = 0 Then 'didn't find it in regular blocks
FileData = "" 'so look in leftovers
FileData = String$(LeftOver, 32)
Get #1, , FileData
Posn& = InStr(FileData, SearchString)
If Posn& = 0 Then 'string still not found
Close #1
Implant = False 'exit function, return FALSE
Exit Function
End If
Seek 1, Posn& 'found it in leftovers!
End If

temp$ = Space$(NumChars) 'temp space for user info
LSet temp$ = ImplantString
Put #1, , temp$ 'brand the .EXE file with user info
Close #1 'close file if all strings implanted
Implant = True 'end the function
End Function

作者: 61.142.212.* 2005-10-28 21:51 　回复此发言

--------------------------------------------------------------------------------

118 取得运行另一个程序并抓取文本
Option Explicit

Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDFIRST = 0

' ***********************************************
' Return information about this window and its
' children.
' ***********************************************
Public Function WindowInfo(window_hwnd As Long)
Dim txt As String
Dim buf As String
Dim buflen As Long
Dim child_hwnd As Long
Dim children() As Long
Dim num_children As Integer
Dim i As Integer

' Get the class name.
buflen = 256
buf = Space$(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left$(buf, buflen)
txt = "Class: " & buf & vbCrLf

' hWnd.
txt = txt & " hWnd: " & _
Format$(window_hwnd) & vbCrLf

' Associated text.
txt = txt & " Text: [" & _
WindowText(window_hwnd) & "]" & vbCrLf

' Make a list of the child windows.
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
Do While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve children(1 To num_children)
children(num_children) = child_hwnd

child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
Loop

' Get information on the child windows.
For i = 1 To num_children
txt = txt & WindowInfo(children(i))
Next i

WindowInfo = txt
End Function

' ************************************************
' Return the text associated with the window.
' ************************************************
Public Function WindowText(window_hwnd As Long) As String
Dim txtlen As Long
Dim txt As String

WindowText = ""
If window_hwnd = 0 Then Exit Function

txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
If txtlen = 0 Then Exit Function

txtlen = txtlen + 1
txt = Space$(txtlen)
txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)
WindowText = Left$(txt, txtlen)
End Function

Private Sub CmdFindText_Click()
Dim app_name As String
Dim parent_hwnd As Long

app_name = AppText.Text
parent_hwnd = FindWindow(vbNullString, app_name)
If parent_hwnd = 0 Then
MsgBox "Application not found."
Exit Sub
End If

ResultsText.Text = app_name & vbCrLf & _
vbCrLf & WindowInfo(parent_hwnd)
End Sub

Private Sub Form_Resize()
Dim wid As Single
Dim hgt As Single
Dim t As Single

wid = ScaleWidth
t = CmdFindText.Top + CmdFindText.Height
hgt = ScaleHeight - t
ResultsText.Move 0, t, wid, hgt
End Sub

作者: 61.142.212.* 2005-10-28 21:52 　回复此发言

--------------------------------------------------------------------------------

119 Shell等待的示例
Option Explicit

' ShellWat sample by Matt Hart - mhart@taascforce.com
' http://www.webczar.com/defcon/mh/vbhelp.html
' http://www.webczar.com/defcon/mh
'
' Shows how to shell to another program, and wait until it finishes
' before continuing.

Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long

Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long

Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000

Private Sub Command1_Click()
Dim iTask As Long, ret As Long, pHandle As Long
iTask = Shell("notepad.exe", vbNormalFocus)
pHandle = OpenProcess(SYNCHRONIZE, False, iTask)
ret = WaitForSingleObject(pHandle, INFINITE)
ret = CloseHandle(pHandle)
MsgBox "Process Finished!"
End Sub

作者: 61.142.212.* 2005-10-28 21:53 　回复此发言

--------------------------------------------------------------------------------

120 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(lpszSoundName As Any, ByVal uFlags As Long) As Long

Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
'Const SND_LOOP = &H8
Const SND_MEMORY = &H4
'Const SND_NOSTOP = &H10
Dim SoundBuffer() As Byte
'Dim BackSound() As Byte
Dim wFlags As Long
Dim Increase As Long
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As Any, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub About1_Click()
Beep
frmAbout.Show 1
End Sub

Private Sub Command1_Click()

If List1.Selected(0) Then
If Text2.Text = "" Or Text3.Text = "" Or Text4(0).Text = "" Or Text4(1).Text = "" Or Text4(2).Text = "" Or Text4(3).Text = "" Then
MsgBox "不要这么心急!还没添完", vbOKOnly, "错误"
Exit Sub
End If
Text1.Locked = False
Text1.Text = "Dear " + Text3.Text + Chr(13) + Chr(10) + "我的宝贝,你可知道," + Chr(13) + Chr(10) + _
"我是多么的爱你?" + Chr(13) + Chr(10) + _
"你那" + Text4(0).Text + "的头发,它是那样的令人陶醉," + Chr(13) + Chr(10) + _
"更不用说你那对" + Text4(1).Text + "的眼睛," + Chr(13) + Chr(10) + _
"它让我如此的痴迷, _" + Chr(13) + Chr(10) + _
"就好象一汪秋水频频荡漾,又似夜晚的繁星点点闪亮。" + Chr(13) + Chr(10) + _
"但最令我疯狂的,还是你那" + Text4(2).Text + "," + Chr(13) + Chr(10) + _
"它总是充满了诱惑,让我产生犯罪的念头," + Chr(13) + Chr(10) + _
"每当我有意或无意间轻触到它的时候,我的全身便燃起了熊熊烈火。" + Chr(13) + Chr(10) + _
"请饶恕我的口不择言,我是如此疯狂地爱着你。" + Chr(13) + Chr(10) + _
"如果你认为我仅仅是爱你的外表,那么你错了," + Chr(13) + Chr(10) + _
"你是如此的" + Text4(3).Text + "," + Chr(13) + Chr(10) + _
"这些才是我爱你的真正原因?" + Chr(13) + Chr(10) + _
"啊,我的宝贝,救救我这颗已被神箭射穿的心灵吧!" + Chr(13) + Chr(10) + _
"让我们珍惜这份情缘," + Chr(13) + Chr(10) + _
"携起手来," + Chr(13) + Chr(10) + _
"一起走向永远,永远......" + Chr(13) + Chr(10) + _
" 爱你的: " + _
Text2.Text
Command3.Enabled = True
Save.Enabled = True
Exit Sub
End If

If List1.Selected(1) Then
If Text2.Text = "" Or Text3.Text = "" Or Text5(0).Text = "" Or Text5(1).Text = "" Or Text5(2).Text = "" Then
MsgBox "不要这么心急!还没添完", vbOKOnly, "错误"
Exit Sub
End If
Text1.Locked = False
Text1.Text = "亲爱的" + Text3.Text + Chr(13) + Chr(10) + "你仿佛有一种魔力," + Chr(13) + Chr(10) + "使我每次见到你都会感到自己的心在狂跳不止," + Chr(13) + Chr(10) + "我知道你根本没有意识到我的存在," + Chr(13) + Chr(10) + "但你的容颜," + Chr(13) + Chr(10) + "已在我逐渐变冷的心中点燃了熊熊烈火," + Chr(13) + Chr(10) + "好几次我想鼓起勇气想你表明心中的感受," + Chr(13) + Chr(10) + "区被你那一双" + Text5(0).Text + "眼睛压了回去," + Chr(13) + Chr(10) + "我是如此的害怕看你的双眼," + Chr(13) + Chr(10) + "只好把话留在心里?" + Chr(13) + Chr(10) + "我努力的强迫自己不去想你," + Chr(13) + Chr(10) + "不要打扰你平静的生活," + Chr(13) + Chr(10) + "尽管如此,当我闭上双眼," + Chr(13) + Chr(10) + "你的身影又浮现在我的眼前?" + Chr(13) + Chr(10) + "我挥手让他散去," + Chr(13) + Chr(10) + "他却纹丝不动," + Chr(13) + Chr(10) + "我终于明白," + Chr(13) + Chr(10) + _

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

121 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
"你对于我来说不只是一阵过眼云烟," + Chr(13) + Chr(10) + _
"而是深深的印在了我的每一个角落?" + Chr(13) + Chr(10) + _
"在我的心中,有一件为你敞开们的小屋," + Chr(13) + Chr(10) + _
"它的名字叫'爱' ," + Chr(13) + Chr(10) + _
"我始终把他藏在那最温暖的角落," + Chr(13) + Chr(10) + _
"等待着你能住在里面我期望有一天," + Chr(13) + Chr(10) + _
"你也能把你的心扉向我敞开," + Chr(13) + Chr(10) + _
"不要让我的梦想一个美丽的泡泡一样破灭," + Chr(13) + Chr(10) + "美丽的东西都是应该" + Text5(1).Text + ",对吗?" + Chr(13) + Chr(10) + "让我的梦想变成现实吧!" + Chr(13) + Chr(10) + "不要让他在折磨我," + Chr(13) + Chr(10) + "我会付出我的一切,关心你,爱护你," + Chr(13) + Chr(10) + "让你这朵美丽的花朵," + Text5(2) + Chr(13) + Chr(10) + "哪怕是有狂风暴雨,," + Chr(13) + Chr(10) + "我的温暖都会在你身边!," + Chr(13) + Chr(10) + " 爱你的:" + Text2.Text
Command3.Enabled = True
Save.Enabled = True
Exit Sub
End If

If List1.Selected(2) Then
If Text2.Text = "" Or Text3.Text = "" Or Text6(0).Text = "" Or Text6(1).Text = "" Or Text6(2).Text = "" Or Text6(3).Text = "" Then
MsgBox "不要这么心急!还没添完", vbOKOnly, "错误"
Exit Sub
End If
Text1.Locked = False
Text1.Text = "亲爱的" + Text3.Text + Chr(13) + Chr(10) + "我的身体里有一百座的核子反应炉" + Chr(13) + Chr(10) + "只要一想到你就像" + Text6(0).Text + "般" + Chr(13) + Chr(10) + "心形的眼珠即时著了火 '泡'你是我今晚的任务" + Chr(13) + Chr(10) + "围绕围绕著你跑了360个400米我是个真爱的超人你是地球" + Chr(13) + Chr(10) + "我是我是我是苍蝇你是果冻完美地跌倒最重要我为你俯冲" + Chr(13) + Chr(10) + "荷尔蒙是威力最大的爆炸把你的理智我的害羞都冲垮" + Chr(13) + Chr(10) + "可不可以靠近过来说说爱要知道冷漠是最没礼貌的落後态度" + Chr(13) + Chr(10) + "让我让我对你发射我最强烈的温柔烧烧的痞子电磁波" + Chr(13) + Chr(10) + "恋爱是青春嘴里的一颗糖我来替你剥开外面的包装" + Chr(13) + Chr(10) + "抱著我如果你尴尬很紧张我用最美的Pose带你到" + Text6(1).Text + Chr(13) + Chr(10) + "噢!让我让我对你发射我最强烈的温柔喔!烧烧的痞子电磁波" + Chr(13) + Chr(10) + "啊!发呆是最危险的自虐狂寂寞是最邪恶的地狱谷耶!" + Chr(13) + Chr(10) + "让我们离开无聊聊的" + Text6(2).Text + _
"飞到电影院看《" + Text6(3) + "》!" + Chr(13) + Chr(10) + "让我让我对你发射我最强烈的温柔烧烧的痞子电磁波" + Chr(13) + Chr(10) + _
"呵呵呵!呵呵呵!呵呵呵呵呵!" + Chr(13) + Chr(10) + _
" 爱你的:" + Text2.Text
Command3.Enabled = True
Save.Enabled = True
Exit Sub
End If

If List1.Selected(3) Then
If Text2.Text = "" Or Text3.Text = "" Or Text7(0).Text = "" Or Text7(1).Text = "" Or Text7(2).Text = "" Or Text7(3).Text = "" Or Text7(4).Text = "" Or Text7(5).Text = "" Or Text7(6).Text = "" Or Text7(7).Text = "" Or Text7(8).Text = "" Then
MsgBox "不要这么心急!还没添完", vbOKOnly, "错误"
Exit Sub
End If
Text1.Locked = False
Text1.Text = "亲爱的" + Text3.Text + Chr(13) + Chr(10) + "我们的感情,在十一届三中全会以来党的一系列正确方针政策的指引下在党的亲切关怀下,在领导的亲自过问下," + Text7(0).Text + "年来正沿着健康的道路蓬勃发展,这主要表现在:" + Chr(13) + Chr(10) + "一、我们共通话" + Text7(1).Text + _

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

122 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
"次。平均每" + Str(Val(Text7(0).Text) / Val(Text7(1).Text)) + "天一次。其中,我给你打了" + Text7(2).Text + "次,占" + Format(Val(Text7(2).Text) / Val(Text7(1).Text), "0%") + ";你给我打了" + Str(Val(Text7(1).Text) - Val(Text7(2).Text)) + "次,占" + Format(1 - Val(Text7(2).Text) / Val(Text7(1).Text), "0%") + ";每次通话最长的达" + Text7(3).Text + "分钟,最短的也有" + Text7(4).Text + "分钟......" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"二、我们约会共" + Text7(5).Text + "次,平均每" + Str(Val(Text7(0).Text) / Val(Text7(5).Text)) + "天一次。其中我主动约你" + Text7(6).Text + "次,占" + Format(Val(Text7(6).Text) / Val(Text7(5).Text), "0%") + ";你约我" + Str(Val(Text7(5).Text) - Val(Text7(6).Text)) + "次,占" + Format(1 - Val(Text7(6).Text) / Val(Text7(5).Text), "0%") + " ;每次约会最长的达" + Text7(7).Text + "小时,最短的也有" + Text7(8).Text + "小时......" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"以上充分证明了一年的交往我们已形成了爱情的共识,我们爱情的主流是互相了解、互相关心、互相帮助,是平等互利的。" + Chr(13) + Chr(10) + "当做任何事物都是一分为二的,缺点的存在是不可避免的," + Chr(13) + Chr(10) + "我们两人虽然都是积极的,但是从以上的数据发展还不太平衡,积极性还存在一定的差距,这是前进中的缺点。" + Chr(10) + Chr(13) + "我相信在新的一年里,我们一定回发扬成绩,克服缺点,再接再厉,携手前进,开创我们爱情的新局面......" + Chr(13) + Chr(10) + _
"因此,我提出三点意见供你参考:" + Chr(13) + Chr(10) + _
"一是要围绕一个'爱'字......" + Chr(13) + Chr(10) + _
"二是要狠抓一个'亲'字......" + Chr(13) + Chr(10) + _
"三是要落实一个'合'字......" + Chr(13) + Chr(10) + _
"让我们宏扬团结拼搏坚韧不拔的精神,共同振兴我们的爱情,争取我们的爱情达到一个新的高度,登上一个新台阶。" + Chr(13) + Chr(10) + "本着'我们的婚事我们办,办好婚事为我们'的精神共创辉煌。" + Chr(13) + Chr(10) + _
" 爱你的:" + Text2.Text

Command3.Enabled = True
Save.Enabled = True
Exit Sub
End If

End Sub

Private Sub Command2_Click()
Text1.Text = ""
Text1.Locked = True

If List1.Selected(0) Then
For i = 0 To 3
Text4(i).Text = ""
Next i
End If

If List1.Selected(1) Then
For i = 0 To 2
Text5(i).Text = ""
Next i
End If
If List1.Selected(2) Then
For i = 0 To 3
Text6(i).Text = ""
Next i
End If
If List1.Selected(3) Then
For i = 0 To 8
Text7(i).Text = ""
Next i
End If
Command3.Enabled = False
Save.Enabled = False

End Sub

Private Sub Command3_Click()
On Error Resume Next
filehandle = FreeFile
'CommonDialog1.Filter = "Text Files|*.txt|All Files (*.*)|*.*"
'CommonDialog1.ShowSave
'If CommonDialog1.FileName <> "" Then
' Open CommonDialog1.FileName For Output As #filehandle
' Print #filehandle, Text1.Text
' Close #filehandle
'End If
'Exit Sub

'Err:
'MsgBox "因为控件没有发现,所以文件保存为在程序同路径下　LoveExpert.txt文件", vbOKOnly, "抱歉!"
MsgBox "文件保存为在程序同路径下　LoveExpert.txt文件", vbOKOnly, "文件保存结果!"
Open App.Path + "\LoveExpert.txt" For Append As #filehandle
Print #filehandle, Text1.Text
Close #filehandle
End Sub

Private Sub Exit_Click()

Unload Me

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

123 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
End Sub

Private Sub Form_Load()
On Error Resume Next
If App.PrevInstance = True Then
Beep
End
End If
Form1.Visible = True
SoundBuffer = LoadResData(101, "CUSTOM")
wFlags = SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY 'Or SND_NOSTOP
'BackSound = LoadResData(102, "CUSTOM")
mciSendString "close MyWav", vbNullString, 0, 0
mciSendString "open " & App.Path & "\why.mid alias MyWav", vbNullString, 0, 0
mciSendString "play MyWav FROM 0", vbNullString, 0, 0
i = Month(Date)
Select Case i
Case 1
Label2.Caption = "一月"
Label4.Caption = "水仙花"
Label6.Caption = "尊敬"
Case 2
Label2.Caption = "二月"
Label4.Caption = "紫罗兰"
Label6.Caption = "诚实,谦让"
Case 3
Label2.Caption = "三月"
Label4.Caption = "郁金香"
Label6.Caption = "爱的倾诉"
Case 4
Label2.Caption = "四月"
Label4.Caption = "康乃馨"
Label6.Caption = "纯粹的爱情"
Case 5
Label2.Caption = "五月"
Label4.Caption = "蔷薇"
Label6.Caption = "美、爱,恋情"
Case 6
Label2.Caption = "六月"
Label4.Caption = "杷子"
Label6.Caption = "我的幸福"
Case 7
Label2.Caption = "七月"
Label4.Caption = "剑兰"
Label6.Caption = "谨慎,坚固"
Case 8
Label2.Caption = "八月"
Label4.Caption = "大莉花"
Label6.Caption = "华丽"
Case 9
Label2.Caption = "九月"
Label4.Caption = "龙胆花"
Label6.Caption = "在你伤心时我尤其爱你"
Case 10
Label2.Caption = "十月"
Label4.Caption = "大波斯菊"
Label6.Caption = "少女的纯洁与爱情"
Case 11
Label2.Caption = "十一月"
Label4.Caption = "菊花"
Label6.Caption = "高尚,清高"
Case 12
Label2.Caption = "十二月"
Label4.Caption = "卡特丽亚"
Label6.Caption = "美人"
End Select
List1.AddItem "传统型"
List1.AddItem "无敌型"
List1.AddItem "思春型"
List1.AddItem "革命数码型"
List1.Selected(0) = True
Frame7.ForeColor = &HFF&
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
mciSendString "close MyWav", vbNullString, 0, 0
frmAbout.Show
End Sub

Private Sub Knoledge1_Click()
Call Label8_Click
Frame7.Visible = True
Frame7.Caption = "情人节的由来"

Text8.Text = " 情人节的来历" + Chr(13) + Chr(10) + _
" 中国人现在用近乎狂热的热情过起了圣诞节一样,情人节也已经悄悄渗透到了无数年轻人的心目当中,成为中国传统节日之外的又一个重要节日。情人节的来历和意义可能并不一定为大多数人所知。下面所要介绍的,不过是众多关于情人节的传说中的一个。" + Chr(13) + Chr(10) + " 在古罗马时期,二月十四日是为表示对约娜的尊敬而设的节日。约娜是罗马众神的皇后,罗马人同时将她尊奉为妇女和婚姻之神。接下来的二月十五日则被称为“卢帕撒拉节”,是用来对约娜治下的其他众神表示尊敬的节日。" + Chr(13) + Chr(10) + " 在古罗马,年轻人和少女的生活是被严格分开的。然而,在卢帕撒拉节,小伙子们可以选择一个自己心爱的姑娘的名字刻在花瓶上。这样,过节的时候,小伙子就可以与自己选择的姑娘一起跳舞,庆祝节日。如果被选中的姑娘也对小伙子有意的话,他们便可一直配对,而且最终他们会坠入爱河并一起步入教堂结婚。后人为此而将每年的二月十四日定为情人节。" + Chr(13) + Chr(10) + _
" 在西方,情人节不但是表达情意的最佳时刻,也是向自己心爱的人求婚的最佳时刻。在这一点上,情人节体现出的,不正是古罗马人设计这个节日的本意吗？　公元三世纪时,古罗马有一位暴君叫克劳多斯(Claudius)。离暴君的宫殿不远,有一座非常漂亮的神庙。修士瓦沦丁(Valentine) 　　就住在这里。罗马人非常崇敬他,男女老幼,不论贫富贵贱,总会群集在他的周围,在祭坛的熊熊圣火前,聆听瓦沦丁的祈祷。" + Chr(13) + Chr(10) + "古罗马的战事一直连绵不断,暴君克劳多斯征召了大批公民前往战场,人们怨声载道。男人们不愿意离开家庭,小伙子们不忍与情人分开。克劳多斯暴跳如雷,他传令人们不许举行婚礼,甚至连所有已订了婚的也马上要解除婚约。许多年轻人就这样告别爱人,悲愤地走向战场。年轻的姑娘们也由于失去爱侣,抑郁神伤。　　瓦沦丁对暴君的虐行感到非常难过。当一对情侣来到神庙请求他的帮助时,瓦沦帝尼在神圣的祭坛前为它们悄悄地举行了婚礼。人们一传十,十传百,很多人来到这里,在瓦沦丁的帮助下结成伴侣。" + Chr(13) + Chr(10) + _

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

124 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
" 消息终于传进了宫殿,传到了暴君的耳里。克劳多斯又一次暴跳如雷,他命令士兵们冲进神庙,将瓦沦丁从一对正在举行婚礼的新人身旁拖走,投入地牢。人们苦苦哀求暴君的劾免,但都徒劳而返。瓦沦丁终于在地牢里受尽折磨而死。悲伤的朋友们将他安葬于圣普拉教堂。那一天是2月14日,那一年是公元270年。　　另外的版本似乎没有这一个精彩。传说中瓦沦丁是最早的基督徒之一,那个时代做一名基督徒意味着危险和死亡。为掩护其他殉教者,瓦沦丁被抓住,投入了监牢。在那里他治愈了典狱长女儿失明的双眼。当暴君听到着一奇迹时,他感到非常害怕,于是将瓦沦丁斩首示众。据传说,在行刑的那一天早晨,瓦沦丁给典狱长的女儿写了一封情意绵绵的告别信,落款是:From　your Valentine (寄自你的瓦沦丁) 　　历史学家们更愿意刨根揪底,他们关于情人节的演绎似乎令人信服。其实远远早于公元270年,当罗马城刚刚奠基时,周围还是一片荒野,成群的狼四处游荡。在罗马人崇拜的众神中,畜牧神卢波库斯(Lupercus)掌管着对牧羊人和羊群的保护。每年二月中,罗马人会举行盛大的典礼来庆祝牧神节。那时的日历与现在相比,要稍微晚一些,所以牧神节实际上是对即将来临的春天的庆祝。" + Chr(13) + Chr(10) + _
" 也有人说这个节日是庆祝法乌努斯" + Chr(13) + Chr(10) + _
" 神(Faunus),它类似于古希腊人身羊足,头上有角的潘神( Pan ),主管畜牧和农业。　　牧神节的起源实在是过于久远了,连公元前一世纪的学者们都无法确认。但是这一节日的重要性是不容置疑的。　　例如史料记载,安东尼(Mark Antony)就是在公元前44年的牧神节上将王冠授与凯撒(Julius Caesar)的。" + Chr(13) + Chr(10) + "每年的二月十五日,修士们会聚集在罗马城中巴沦丁Palantine)山上的一个洞穴旁,据说在这里,古罗马城的奠基者 (Romilus andRemus)被一只母狼扶育长大。在节日的各项庆典中,有一项是年轻的贵族们,手持羊皮鞭,在街道上奔跑。年轻妇女们会聚集在街道两旁,祈望羊皮鞭抽打到她们头上。人们相信这样会使她们更容易生儿育女。在拉丁语中,羊皮鞭被叫做 februa,鞭打叫做 fabruatio, 实际上都含有'纯洁'的意思。二月的名字(February)就是由此而来。" + Chr(13) + Chr(10) + _
" 随着罗马势力在欧洲的扩张,牧神节的习俗被带到了现在的法国和英国等地。人们最乐此不疲的一项节日活动类似于摸彩。年轻女子们的名字被放置于盒子内,然后年轻男子上前抽取。抽中的一对男女成为情人,时间是一年或更长。　　基督教的兴起使人们纪念众神的习俗逐渐淡漠。教士们不希望人们放弃节日的欢乐,于是将牧神节(Lupercalia)改成瓦沦丁节( Valentine's Day),并移至二月十四日。这样,关于瓦沦丁修士的传说和古老的节日就被自然地结合在一起。这一节日在中世纪的英国最为流行。未婚男女的名字被抽出后,他们会互相交换礼物,女子在这一年内成为男子的Valentine。　　在男子的衣袖上会绣上女子的名字,照顾和保护该女子于是成为该男子的神圣职责。" + Chr(13) + Chr(10) + _
" 有史可查的现代意义上的瓦沦丁情人是在十五世纪早期。法国年轻的奥尔良大公在阿根科特(Agincourt)战役中被英军俘虏,然后被关在伦敦塔中很多年。他写给妻子很多首情诗,大约60首保存至今。用鲜花做瓦沦丁节的信物在大约两百年后出现。法王亨利四世(Henry IV)的一个女儿在瓦沦丁节举行了一个盛大的晚会。所有女士从选中她做Valentine的男士那里获得一束鲜花。　　就这样,延续着古老的意大利,法国和英国习俗,我们得以在每年的二月十四日向自己的朋友传递爱的信息。鲜花,心形糖果,用花边和摺穗掩盖了送物人名字的信物,不仅仅是代表着一份份真挚的爱,更是对敢于反抗暴政的瓦沦丁修士的最好缅怀。"

End Sub

Private Sub Knoledge2_Click()

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

125 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
Call Label8_Click
Frame7.Visible = True
Frame7.Caption = "巧克力爱情物语"

Text8.Text = " 巧克力爱情物语" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 正如花有花语,巧克力也有自己的爱情物语,送不同的巧克力表示不同的意义,不妨仔细看看:" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 牛奶巧克力表示你觉得对方很纯品,很乖巧,是个可爱的小精灵。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 黑巧克力表示你觉得对方有个性,很神秘,深不可测。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 白巧克力表示你觉得对方超凡脱俗,不食人间烟火。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 果仁巧克力表示你觉得与对方一起很温馨,很想随时陪伴左右。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 心型巧克力表示“我心属于你”。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 卡通巧克力表示你很欣赏对方的天真烂漫?" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
" 带玩具的巧克力表示你与对方的关系正介于情人和朋友之间?"

End Sub

Private Sub Knoledge3_Click()
Call Label8_Click
Frame7.Visible = True
Frame7.Caption = "送花的数目含义"

Text8.Text = " 送花的数目含义 " + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"1 朵唯一的爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"2 朵你侬我侬" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"3 朵我爱你" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"4 朵誓言与承诺" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"5 朵无悔" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "6 朵顺利" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "7 朵喜相逢" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "8 朵弥补" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"9 朵长相守" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "10 朵完美的你(你)" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"11 朵一心一意;最美" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "12 朵比翼双飞" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"13 朵暗恋" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "17 朵好聚好散" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"20 朵两情相悦" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "21 朵最爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"22 朵双双对对" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "24 朵无时无刻想著你" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"33 朵我爱你;三生三世" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "36 朵我心属於你" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"44 朵至死不渝" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "50 朵无悔的爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"56 朵吾爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "57 朵吾爱吾妻" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"66 朵细水长流" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "77 朵求婚" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"88 朵用心弥补" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "99 朵天长地久" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"100 朵白头偕老;爱你一万年" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "101 朵直到永远" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "108 朵无尽的爱 " + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "144 朵爱你生生世世" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

126 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
"365 朵天天想你 " + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "999 朵天长地久" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"1001 朵直到永远 "
End Sub

Private Sub Knoledge5_Click()
Call Label8_Click
Frame7.Visible = True
Frame7.Caption = "花代表的心思"

Text8.Text = " 花语" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"三色篓:思慕、想念我雏菊:愉快、纤细、幸福矢车菊:幸福" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "福禄考:一致同意瓜叶菊:快活矮牵牛:(白)存在、(紫)情" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "蕾香蓟: 相信得到答覆花菱草: 不要拒绝我美人樱: 诱惑" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "勿忘草:永志勿望霞草:(红)期待的喜悦六佬刎:可怜、同情" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "报春花:初恋、希望鼠尾草:(白)精力充沛(红)心在燃烧、(紫)智慧" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "松叶菊: 情息天竺葵: 诈欺?不实西番莲: 圣爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "曼陀罗:诈情、骗受滨蓟:孤独海石竹:体谅、贴心" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "香蒌: 贞淑?芍药: 善羞?愤怒福寿草: 回想君子兰: 高贵" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "华草: 服从非洲菊: 神秘金莲花: 不稳定?心绪不宁" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "郁金香:爱的表现" + _
"鸢尾: 使者?爱的传达风信子: 游戏?内心的喜悦 " + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "白头翁:(白)真实、(红)恋爱、(黄)绝交、(紫)信澄小苍兰:纯洁" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "娄斗菜:(白)愚钝、(红)挂虑、(紫)胜利德国鸢尾:神圣" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "孤挺花:多话、多嘴百合:尊敬、纯洁陆莲花:迷人的魅力" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "高雪轮: 骗子风铃草: 诚信虞美人: 抚慰" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "翟麦: 野心根节兰: 长寿康乃馨: 伤心" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "黑种草:清新的爱海棠:善感松虫草:追念" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "蝴蝶花:反抗荷花:君子黑百合:诅咒" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "扶桑:热情牵牛花:稍纵即逝石蒜:冷清、孤独" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "木莲: 高尚毛地黄: 晃言加得利亚兰: 神秘?高贵" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "石榴:风饶亚麻:优美朴实野蔷薇:自由" + _
"旋花:恩赐忍冬:背弃茴香:思念" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "熏衣草:清雅、女人味柳穿鱼:纤细卷耳:快乐" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "橙花:爱慕海芋:纯洁莲翘:别碰我" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "梨花:纯情罂粟:华丽、高贵桃花:爱慕" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "凤尾眷:思念杏花:拜访我铁线莲:雅致" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "秋水仙: 遗忘酢酱草: 我不会放弃您?欢悦燕子花: 幸运到来" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "紫藤:热恋、欢迎社鹃花:爱的快乐、节制茶花:(红)谦逊、美德、可爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金省花: 谦逊?卑下隶棠花: 高洁山东窗: 待续?耐久" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金鱼草:傲慢雪柳:殊胜金缕梅:咒文、灵感" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "紫丁香:(紫)初恋的感激(红)爱苗滋生、纯真桔梗花:柔情、嫉妒" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

127 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及
"百日草: 思念亡友香石竹: 热心万寿菊: 自卑" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "鸡冠花:不死飞燕草:正义、自由茑萝:好管闲事" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "千日红: 不朽?不灭凤仙花: 纪念彩叶苋: 绝恋" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金鸡菊:竞争心麦杆菊:永久不变蜀葵:热恋、单纯" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "红花: 差别?区别金针花: 宣告?妩媚玻璃菊: 闺女?追想" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "蓬莴菊:占有恋人,真实的爱千屈菜:悲哀大岩洞:绝望。" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "球根海棠:亲切、单相思火炬花:思念之苦鹿葱:肉体的快乐" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "铃兰:幸福纯洁、纤细、处女的骄做萍蓬草:崇高" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "百于莲:恋爱的造访、恋爱的通讯睡莲:淡泊姜兰:无聊" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "溪荪: 愤慨玉蝉花: 爱的音讯洋玉兰: 自然的爱?威严" + _
"八仙花:自私紫薇:雄辩桅子花:闲雅、清静、幸福者" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "夹竹桃:(桃)咒骂、竹 :志节、节操榆 :尊严、爱国心" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "柳: 追悼?死亡柏: 死亡?阴影桑: 不寻常" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "橄榄:智慧、和平月桂:胜利法国梧桐:天才" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "圣柳:犯罪唐桧:大胆、无远虑长春藤:诡计" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "橡 :权威文竹:哀戚武竹:飘逸" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "青苔:谦逊棕桐:荣耀菩提:安宁" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "蒲公英: 勇气马鞭草: 正义?期待翠茱花: 祝你幸福" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "雷丝花: 纯洁?幸运古代稀: 虚荣千舌草: 初恋" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "天人菊:团结孔雀草:嫉妒、悲爱石竹:急切、莽撞" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金盏花:期望翠菊:远虑紫罗兰:忠实" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"蒲包花: 富贵香碗豆: 俊美?回忆叶牡丹: 利益" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "紫茉莉:臆测、猜忌黄蜀葵:单恋、信任昙花:夜之美人" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "吊钟花:趣味、嗜好紫苑:反省、追想龙胆:正义、清高" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "虎耳草: 情爱红蜀葵: 温和月见草: 美人?魔法" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "美人蕉:坚实葱兰:期待,洁白的爱番红花:青春的快乐" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "水仙:自尊仙客来:疑惑、猜忌瑞香:欢乐、不死" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金银花:献爱,诚爱梅花:高洁素馨:幸福、亲切" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "夹竹桃:(桃)咒骂、(黄)深刻的友情紫葳:女性、名誉" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "玫瑰:美、爱、恋(白)恋的心声、诚心敬爱(红)美丽、贞节、模范。(黄)不贞、嫉妒" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "羽扇豆: 母性爱?妩媚长春花: 追忆向日葵: 崇拜?敬慕" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + _
"大波斯菊:(白)纯洁(红)多情山查:希望紫荆:背叛、疑惑" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "洋桔梗:富放感情、感动牡丹:富贵樱花:欢乐" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "蜡梅:慈爱心茶梅:(红)清雅、谦让、(白)理想的爱" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "球葱:无限悲哀雪片:纯洁串铃花:悲恋" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "东菊:别离球葱:无限悲哀串铃花:悲恋" + Chr(13) + Chr(10) + Chr(13) + Chr(10) + "金栗兰: 隐约之美金栗兰: 隐约"

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

128 恋爱专家 - 主要体现在背景音乐的播放和资源文件中声音的播放以及

End Sub

Private Sub Label7_Click()
On Error Resume Next
If Shape1(1).Top >= 4680 Then
Exit Sub
End If

Timer1.Enabled = False
Frame4.Visible = True
'mciSendString "close MyWav", vbNullString, 0, 0

sndPlaySound SoundBuffer(0), wFlags
While Shape1(1).Top < 4680

Label8.Top = Label8.Top + 50
Shape1(1).Top = Shape1(1).Top + 50

Frame5.Top = Shape1(1).Top + Shape1(1).Height
Wend
Save.Enabled = True
NewFile.Enabled = True
Frame7.Visible = False
mciSendString "close BackSound", vbNullString, 0, 0
End Sub

Private Sub Label8_Click()
On Error Resume Next
If Shape1(1).Top <= Shape1(0).Top + Shape1(0).Height + 20 Then
Exit Sub
End If

sndPlaySound SoundBuffer(0), wFlags

While Shape1(1).Top > Shape1(0).Top + Shape1(0).Height + 20

Label8.Top = Label8.Top - 50
Shape1(1).Top = Shape1(1).Top - 50

Frame5.Top = Shape1(1).Top + Shape1(1).Height
Wend
Frame4.Visible = False
Save.Enabled = False
NewFile.Enabled = False

Timer1.Enabled = True
Frame7.Visible = True

'DoEvents

'mciSendString "close MyWav", vbNullString, 0, 0
'mciSendString "open e:\music\why.mid alias MyWav", vbNullString, 0, 0
'mciSendString "play MyWav", vbNullString, 0, 0

End Sub

Private Sub List1_Click()
For i = 0 To 3
If List1.Selected(i) Then
Frame2(i).Visible = True
Else
Frame2(i).Visible = False
End If
Next i
End Sub

Private Sub New_Click()
Text1.Text = ""
Text1.Locked = True
Text2.Text = ""
Text3.Text = ""

For i = 0 To 3
Text4(i).Text = ""
Next i

For i = 0 To 2
Text5(i).Text = ""
Next i

For i = 0 To 3
Text6(i).Text = ""
Next i

For i = 0 To 8
Text7(i).Text = ""
Next i
End Sub

Private Sub NewFile_Click()
Text1.Locked = True
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""

For i = 0 To 3
Text4(i).Text = ""
Next i

For i = 0 To 2
Text5(i).Text = ""
Next i

For i = 0 To 3
Text6(i).Text = ""
Next i

For i = 0 To 8
Text7(i).Text = ""
Next i

Command3.Enabled = False
Save.Enabled = False

End Sub

Private Sub Save_Click()
Call Command3_Click
End Sub

Private Sub Text1_Change()
If Text1.Locked = True Then
Text1.Text = ""
End If

End Sub

Private Sub Text1_GotFocus()
If Text1.Text <> "" Then
Text1.Locked = False
Else
Text1.Locked = True
End If

End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = 2 Then
If KeyCode = 65 Or KeyCode = 97 Then
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End If

If KeyCode = 67 Or KeyCode = 99 Then
Clipboard.Clear
Clipboard.SetText (Text1.SelText)
End If

If KeyCode = 86 Or KeyCode = 118 Then
Text1.Text = Left(Text1.Text, Text1.SelStart + Text1.SelLength + 2) + Clipboard.GetText + Mid(Text1.Text, Text1.SelStart + Text1.SelLength + Len(Clipboard.GetText) - 3, Len(Text1.Text) - Text1.SelStart + Text1.SelLength)
End If

If KeyCode = 88 Or KeyCode = 120 Then
Text1.Text = Left(Text1.Text, Text1.SelStart) + Mid(Text1.Text, Text1.SelStart + Text1.SelLength + 3, Len(Text1.Text) - Text1.SelStart - Text1.SelLength)
End If
End If

End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If

End Sub

Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Text4_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Text5_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Text6_Change(Index As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Text6_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Text7_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

Private Sub Timer1_Timer()

Dim S As String
If Shape1(1).Top < 4680 Then

If Label39(0).ForeColor <= &H1010FF Then
Increase = &H80800
ElseIf Label39(0).ForeColor >= &HEFEFFF Then
Increase = -&H80800
End If
Label39(0).ForeColor = Label39(0).ForeColor + Increase
Label39(1).ForeColor = Label39(1).ForeColor - Increase
End If

S = String(256, Chr(0))
mciSendString "status MyWav mode", S, Len(S), 0
If Left(S, 7) = "stopped" Or Left(S, 2) = "停止" Then
mciSendString "seek MyWav to start", vbNullString, 0, 0
mciSendString "play MyWav", vbNullString, 0, 0
End If

End Sub

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

129 回复 122:恋爱专家 - 主要体现在背景音乐的播放和资源
Private Sub cmdOK_Click()
Unload Me
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label2.Font.Underline = False
Label4.Font.Underline = False
Label2.ForeColor = &H80000012
Label4.ForeColor = &H80000012
End Sub

Private Sub Label2_Click()
Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE mailto:zhyu_zhyu@163.net", vbHide

End Sub

Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label2.Font.Underline = True
Label4.Font.Underline = False
Label2.ForeColor = &HFF&
Label4.ForeColor = &H80000012
End Sub

Private Sub Label4_Click()
Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE http://kiss21.126.com", vbMaximizedFocus
End Sub

Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label4.Font.Underline = True
Label2.Font.Underline = False
Label4.ForeColor = &HFF&
Label2.ForeColor = &H80000012
End Sub

作者: 61.142.212.* 2005-10-28 21:55 　回复此发言

--------------------------------------------------------------------------------

130 使用API产生动态鼠标的例程
Private Const GCL_HCURSOR = -12
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Any) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Sub Command1_Click()
Dim mhBaseCursor As Long, mhAniCursor As Long
Dim lResult As Long

mhAniCursor = LoadCursorFromFile(Dir1.Path & "\" & File1.FileName)
lResult = SetClassLong((hwnd), GCL_HCURSOR, mhAniCursor)

' 下面可以再加需要显示动态鼠标的控件
lResult = SetClassLong((Me.File1.hwnd), GCL_HCURSOR, mhAniCursor)
End Sub

Private Sub Command2_Click()
Dim mhBaseCursor As Long, mhAniCursor As Long
Dim lResult As Long

lResult = GetClassLong((hwnd), GCL_HCURSOR)
mhAniCursor = DestroyCursor(lResult)

End Sub

Private Sub Command3_Click()
Unload Me
End Sub

Private Sub Command4_Click()
frmabout.Show 1
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()

Drive1.Drive = "c:"

End Sub

Private Sub Form_Unload(Cancel As Integer)
Command2_Click
End Sub
------------\
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label1.ForeColor = vbBlue
Label4.ForeColor = vbBlue
End Sub

Private Sub Label1_Click()
Call ShellExecute(hwnd, "Open", "http://xlh.126.com", "", App.Path, 1)
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label1.ForeColor = vbRed
End Sub

Private Sub Label4_Click()
Call ShellExecute(hwnd, "Open", "mailto:lhxie@126.com", "", App.Path, 1)
End Sub

Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label4.ForeColor = vbRed

End Sub

作者: 61.142.212.* 2005-10-28 22:00 　回复此发言

--------------------------------------------------------------------------------

131 看着超级玛莉不停的追赶着你的鼠标,是不是很有意思呢？(推荐)
Option Explicit
Public Pic As New cut_Pic

Private Sub Form_Load()
Pic.Ini Form1, P(0), P2, 5, 10
Pic.Sound = True
End Sub

Private Sub P2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'突出式功能表
If Button = 2 Then Form1.PopupMenu Form2.A, 2
End Sub

Private Sub Timer1_Timer()
Pic.cutPic
End Sub
---------
Option Explicit

Private Sub A1_Click()
A1.Checked = Not A1.Checked
Form1.Pic.Auto = Not Form1.Pic.Auto
End Sub

Private Sub A2_Click()
A2.Checked = Not A2.Checked
Form1.Pic.Sound = Not Form1.Pic.Sound
End Sub

Private Sub A33_Click(Index As Integer)
Form1.Pic.Ini Form1, Form1.P(Index), Form1.P2, 5, 10
End Sub

Private Sub A4_Click()
Copyright.Show
End Sub

Private Sub A5_Click()
Dim I As Integer
For I = Forms.Count - 1 To 0 Step -1
Unload Forms(I)
Next I
End
End Sub

Private Sub Form_Load()
Dim hMenu As Long
Dim hSubMenu As Long
Dim lngID As Long
Dim I As Integer

hMenu = GetMenu(Form2.hwnd)
hSubMenu = GetSubMenu(hMenu, 0) '
hSubMenu = GetSubMenu(hSubMenu, 2) 'Ω
For I = 0 To 7
lngID = GetMenuItemID(hSubMenu, I)

' ノImage妮┦肚纥钩絏
Pic(I).Picture = Pic(I).Image
Call ModifyMenu(hMenu, lngID, 4, lngID, CLng(Pic(I).Picture))
Next I
End Sub
----------
Option Explicit

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetWindowPos Lib "user32" (ByVal H%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long

Type POINTAPI
X As Long
Y As Long
End Type

Option Explicit

Declare Function BitBlt Lib "GDI32" (ByVal hDestDC 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 dwRop As Long) As Long
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

作者: 61.142.212.* 2005-10-28 22:02 　回复此发言

--------------------------------------------------------------------------------

132 看着超级玛莉不停的追赶着你的鼠标,是不是很有意思呢？(推荐)

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetWindowPos Lib "user32" (ByVal H%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long

Type POINTAPI
X As Long
Y As Long
End Type

-------
'************************************************
'** 程式设计:饶明惠(蛇夫) **
'** 职业:阿兵哥 **
'** E-Mail :snakes@ms8.url.com.tw **
'************************************************
Option Explicit
Private in_Form As Form
Private in_srcPic As PictureBox, in_desPic As PictureBox
Private in_Piece As Integer
Private Gini_Width As Integer, Gini_Height As Integer
Private in_FormX As Integer, in_FormY As Integer
Private in_MoveDistance As Integer
Private GiniX As Integer, GiniY As Integer, GiniY1 As Integer
Private Direct As Integer
Private scrpixelX As Integer, scrpixelY As Integer
Private Wav() As Byte
Private in_Auto As Boolean
Private in_Sound As Boolean
Private CheckGoal As Boolean '检查是否已到了目的
Private CheckMove As Boolean '检查是否有移动

'**********************************本类别为切割Gini图用**************************

Sub Ini(out_Form As Form, out_srcPic As PictureBox, out_desPic As PictureBox, out_Piece As Integer, out_MoveDistance As Integer)
Set in_Form = out_Form
Set in_srcPic = out_srcPic
Set in_desPic = out_desPic
'in_Form.ScaleMode = vbPixels
in_srcPic.ScaleMode = vbPixels
in_desPic.ScaleMode = vbPixels

'计算Gini图的宽、高
in_Piece = out_Piece
Gini_Width = in_srcPic.ScaleWidth / in_Piece
Gini_Height = in_srcPic.ScaleHeight / 2 '输入图片为两倍Gini图高

'表单的宽、高与Gini图相同,但转成twips
in_Form.Width = Gini_Width * Screen.TwipsPerPixelX
in_Form.Height = Gini_Height * Screen.TwipsPerPixelY
in_desPic.Width = in_Form.Width
in_desPic.Height = in_Form.Height
in_MoveDistance = out_MoveDistance
scrpixelX = Screen.TwipsPerPixelX
scrpixelY = Screen.TwipsPerPixelY

'置于最顶层
Call SetWindowPos(in_Form.hwnd, -1, 0, 0, 0, 0, 3)

'载入资源
Wav = LoadResData(111, "WAVE")

Randomize Timer
End Sub
Sub cutPic()
Dim Index As Integer
Static Mouse As POINTAPI

If in_Auto = False Then
'取得滑鼠位置
Call GetCursorPos(Mouse)
Else
If CheckGoal = True Then '随机取得新目标
With Screen
Mouse.X = Int((.Width / .TwipsPerPixelX) * Rnd)
Mouse.Y = Int((.Height / .TwipsPerPixelY) * Rnd)

作者: 61.142.212.* 2005-10-28 22:02 　回复此发言

--------------------------------------------------------------------------------

133 看着超级玛莉不停的追赶着你的鼠标,是不是很有意思呢？(推荐)
End With
CheckGoal = False
End If
End If

'运算后给予相对的Gini图和方向
If Mouse.X > ((in_Form.Left / scrpixelX) + Gini_Width) Then
If Mouse.Y < (in_Form.Top / scrpixelY) Then '右上
Direct = 0: Index = 1
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '右下
Direct = 0: Index = 3
Else '右
Direct = 0: Index = 2
End If
CheckMove = True
ElseIf Mouse.X < (in_Form.Left / scrpixelX) Then
If Mouse.Y < (in_Form.Top / scrpixelY) Then '左上
Direct = 1: Index = 1
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '左下
Direct = 1: Index = 3
Else '左
Direct = 1: Index = 2
End If
CheckMove = True
Else
If Mouse.Y < (in_Form.Top / scrpixelY) Then '上
Direct = 0: Index = 0
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '下
Direct = 0: Index = 4
Else
'到了目的地
CheckGoal = True
If CheckMove = True Then
If in_Sound = True Then Call sndPlaySound(Wav(0), 5) '音效
CheckMove = False
End If
Exit Sub
End If
CheckMove = True
End If

'输入图片第一列为 Gini 遮罩图
' 第二列为 Gini 图

'计算Gini图位置
GiniX = Gini_Width * (Index Mod in_Piece)
GiniY = Gini_Height * (Index \ in_Piece)
GiniY1 = Gini_Height * ((in_Piece + Index) \ in_Piece)

'转换表单与萤幕的单位为 pixel 关系
If ((in_Form.Left / scrpixelX) + (Gini_Width / 2)) < Mouse.X Then
in_FormX = in_FormX + in_MoveDistance '往右走
ElseIf ((in_Form.Left / scrpixelX)) > Mouse.X Then
in_FormX = in_FormX - in_MoveDistance '往左走
End If
If ((in_Form.Top / scrpixelY) + (Gini_Height / 2)) < Mouse.Y Then
in_FormY = in_FormY + in_MoveDistance '往下走
ElseIf ((in_Form.Top / scrpixelY)) > Mouse.Y Then
in_FormY = in_FormY - in_MoveDistance '往上走
End If

in_srcPic.AutoRedraw = True
in_desPic.AutoRedraw = True
in_Form.AutoRedraw = True

'还原萤幕背景 = in_Form的内容
in_desPic.Visible = False
DoEvents

Dim ScrhDC As Long
'取得萤幕资源
ScrhDC = GetDC(0)
'备份萤幕背景
Call BitBlt(in_Form.hdc, 0, 0, Gini_Width, Gini_Height, ScrhDC, in_FormX, in_FormY, vbSrcCopy)
'copy萤幕背景作为 in_desPic的背景
Call BitBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, ScrhDC, in_FormX, in_FormY, vbSrcCopy)
'释放萤幕资源
Call ReleaseDC(0, ScrhDC)

'正常copy Gini图
If Direct = 0 Then
Call StretchBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY, Gini_Width, Gini_Height, vbSrcAnd)
Call StretchBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY1, Gini_Width, Gini_Height, vbSrcPaint)
'水平反转Gini图
ElseIf Direct = 1 Then
Call StretchBlt(in_desPic.hdc, Gini_Width, 0, -Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY, Gini_Width, Gini_Height, vbSrcAnd)
Call StretchBlt(in_desPic.hdc, Gini_Width, 0, -Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY1, Gini_Width, Gini_Height, vbSrcPaint)
End If
in_desPic.Visible = True

'移动表单
in_Form.Move in_FormX * scrpixelX, in_FormY * scrpixelY

in_srcPic.AutoRedraw = False
in_desPic.AutoRedraw = False
in_Form.AutoRedraw = False
End Sub

Public Property Get Auto() As Boolean
Auto = in_Auto
End Property

Public Property Let Auto(ByVal out_Auto As Boolean)
in_Auto = out_Auto
End Property

Public Property Get Sound() As Boolean
Sound = in_Sound
End Property

Public Property Let Sound(ByVal out_Sound As Boolean)
in_Sound = out_Sound
End Property

Private Sub Class_Initialize()
CheckGoal = True
End Sub
-------

作者: 61.142.212.* 2005-10-28 22:02 　回复此发言

--------------------------------------------------------------------------------

134 回复:把焦点定位到任何已运行的窗口。
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ej@bantz.com
'* Web: http://ej.bantz.com/video

'// ------------------------------------------------------------------
'// Windows API Constants / Types / Declarations
'// ------------------------------------------------------------------
Public Const WM_USER = &H400
Type POINTAPI
x As Long
y As Long
End Type
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Declare Function SendMessageS Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As Long

'// ------------------------------------------------------------------
'// Window Messages WM_CAP... which can be sent to an AVICAP window
'// ------------------------------------------------------------------

'// Defines start of the message range
Public Const WM_CAP_START = WM_USER

Public Const WM_CAP_GET_CAPSTREAMPTR = WM_CAP_START + 1

Public Const WM_CAP_SET_CALLBACK_ERROR = WM_CAP_START + 2
Public Const WM_CAP_SET_CALLBACK_STATUS = WM_CAP_START + 3
Public Const WM_CAP_SET_CALLBACK_YIELD = WM_CAP_START + 4
Public Const WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5
Public Const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START + 6
Public Const WM_CAP_SET_CALLBACK_WAVESTREAM = WM_CAP_START + 7
Public Const WM_CAP_GET_USER_DATA = WM_CAP_START + 8
Public Const WM_CAP_SET_USER_DATA = WM_CAP_START + 9

Public Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
Public Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
Public Const WM_CAP_DRIVER_GET_NAME = WM_CAP_START + 12
Public Const WM_CAP_DRIVER_GET_VERSION = WM_CAP_START + 13
Public Const WM_CAP_DRIVER_GET_CAPS = WM_CAP_START + 14

Public Const WM_CAP_FILE_SET_CAPTURE_FILE = WM_CAP_START + 20
Public Const WM_CAP_FILE_GET_CAPTURE_FILE = WM_CAP_START + 21
Public Const WM_CAP_FILE_ALLOCATE = WM_CAP_START + 22
Public Const WM_CAP_FILE_SAVEAS = WM_CAP_START + 23
Public Const WM_CAP_FILE_SET_INFOCHUNK = WM_CAP_START + 24
Public Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25

Public Const WM_CAP_EDIT_COPY = WM_CAP_START + 30

Public Const WM_CAP_SET_AUDIOFORMAT = WM_CAP_START + 35
Public Const WM_CAP_GET_AUDIOFORMAT = WM_CAP_START + 36

Public Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
Public Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Public Const WM_CAP_DLG_VIDEODISPLAY = WM_CAP_START + 43
Public Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Public Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Public Const WM_CAP_DLG_VIDEOCOMPRESSION = WM_CAP_START + 46

Public Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
Public Const WM_CAP_SET_OVERLAY = WM_CAP_START + 51
Public Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52
Public Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Public Const WM_CAP_GET_STATUS = WM_CAP_START + 54
Public Const WM_CAP_SET_SCROLL = WM_CAP_START + 55

Public Const WM_CAP_GRAB_FRAME = WM_CAP_START + 60

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

135 回复:把焦点定位到任何已运行的窗口。
Public Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61

Public Const WM_CAP_SEQUENCE = WM_CAP_START + 62
Public Const WM_CAP_SEQUENCE_NOFILE = WM_CAP_START + 63
Public Const WM_CAP_SET_SEQUENCE_SETUP = WM_CAP_START + 64
Public Const WM_CAP_GET_SEQUENCE_SETUP = WM_CAP_START + 65
Public Const WM_CAP_SET_MCI_DEVICE = WM_CAP_START + 66
Public Const WM_CAP_GET_MCI_DEVICE = WM_CAP_START + 67
Public Const WM_CAP_STOP = WM_CAP_START + 68
Public Const WM_CAP_ABORT = WM_CAP_START + 69

Public Const WM_CAP_SINGLE_FRAME_OPEN = WM_CAP_START + 70
Public Const WM_CAP_SINGLE_FRAME_CLOSE = WM_CAP_START + 71
Public Const WM_CAP_SINGLE_FRAME = WM_CAP_START + 72

Public Const WM_CAP_PAL_OPEN = WM_CAP_START + 80
Public Const WM_CAP_PAL_SAVE = WM_CAP_START + 81
Public Const WM_CAP_PAL_PASTE = WM_CAP_START + 82
Public Const WM_CAP_PAL_AUTOCREATE = WM_CAP_START + 83
Public Const WM_CAP_PAL_MANUALCREATE = WM_CAP_START + 84

'// Following added post VFW 1.1
Public Const WM_CAP_SET_CALLBACK_CAPCONTROL = WM_CAP_START + 85

'// Defines end of the message range
Public Const WM_CAP_END = WM_CAP_SET_CALLBACK_CAPCONTROL

'// ------------------------------------------------------------------
'// Structures
'// ------------------------------------------------------------------
Type CAPDRIVERCAPS
wDeviceIndex As Long ' // Driver index in system.ini
fHasOverlay As Long ' // Can device overlay?
fHasDlgVideoSource As Long ' // Has Video source dlg?
fHasDlgVideoFormat As Long ' // Has Format dlg?
fHasDlgVideoDisplay As Long ' // Has External out dlg?
fCaptureInitialized As Long ' // Driver ready to capture?
fDriverSuppliesPalettes As Long ' // Can driver make palettes?
hVideoIn As Long ' // Driver In channel
hVideoOut As Long ' // Driver Out channel
hVideoExtIn As Long ' // Driver Ext In channel
hVideoExtOut As Long ' // Driver Ext Out channel
End Type

Type CAPSTATUS
uiImageWidth As Long '// Width of the image
uiImageHeight As Long '// Height of the image
fLiveWindow As Long '// Now Previewing video?
fOverlayWindow As Long '// Now Overlaying video?
fScale As Long '// Scale image to client?
ptScroll As POINTAPI '// Scroll position
fUsingDefaultPalette As Long '// Using default driver palette?
fAudioHardware As Long '// Audio hardware present?
fCapFileExists As Long '// Does capture file exist?
dwCurrentVideoFrame As Long '// # of video frames cap'td
dwCurrentVideoFramesDropped As Long '// # of video frames dropped
dwCurrentWaveSamples As Long '// # of wave samples cap'td
dwCurrentTimeElapsedMS As Long '// Elapsed capture duration
hPalCurrent As Long '// Current palette in use
fCapturingNow As Long '// Capture in progress?
dwReturn As Long '// Error value after any operation
wNumVideoAllocated As Long '// Actual number of video buffers
wNumAudioAllocated As Long '// Actual number of audio buffers
End Type

Type CAPTUREPARMS
dwRequestMicroSecPerFrame As Long '// Requested capture rate
fMakeUserHitOKToCapture As Long '// Show "Hit OK to cap" dlg?
wPercentDropForError As Long '// Give error msg if > (10%)

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

136 回复:把焦点定位到任何已运行的窗口。
fYield As Long '// Capture via background task?
dwIndexSize As Long '// Max index size in frames (32K)
wChunkGranularity As Long '// Junk chunk granularity (2K)
fUsingDOSMemory As Long '// Use DOS buffers?
wNumVideoRequested As Long '// # video buffers, If 0, autocalc
fCaptureAudio As Long '// Capture audio?
wNumAudioRequested As Long '// # audio buffers, If 0, autocalc
vKeyAbort As Long '// Virtual key causing abort
fAbortLeftMouse As Long '// Abort on left mouse?
fAbortRightMouse As Long '// Abort on right mouse?
fLimitEnabled As Long '// Use wTimeLimit?
wTimeLimit As Long '// Seconds to capture
fMCIControl As Long '// Use MCI video source?
fStepMCIDevice As Long '// Step MCI device?
dwMCIStartTime As Long '// Time to start in MS
dwMCIStopTime As Long '// Time to stop in MS
fStepCaptureAt2x As Long '// Perform spatial averaging 2x
wStepCaptureAverageFrames As Long '// Temporal average n Frames
dwAudioBufferSize As Long '// Size of audio bufs (0 = default)
fDisableWriteCache As Long '// Attempt to disable write cache
End Type

Type CAPINFOCHUNK
fccInfoID As Long '// Chunk ID, "ICOP" for copyright
lpData As Long '// pointer to data
cbData As Long '// size of lpData
End Type

Type VIDEOHDR
lpData As Long '// address of video buffer
dwBufferLength As Long '// size, in bytes, of the Data buffer
dwBytesUsed As Long '// see below
dwTimeCaptured As Long '// see below
dwUser As Long '// user-specific data
dwFlags As Long '// see below
dwReserved(3) As Long '// reserved; do not use}
End Type

'// The two functions exported by AVICap
Declare Function capCreateCaptureWindowA Lib "avicap32.dll" ( _
ByVal lpszWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Integer, _
ByVal hWndParent As Long, ByVal nID As Long) As Long
Declare Function capGetDriverDescriptionA Lib "avicap32.dll" ( _
ByVal wDriver As Integer, _
ByVal lpszName As String, _
ByVal cbName As Long, _
ByVal lpszVer As String, _
ByVal cbVer As Long) As Boolean

'// ------------------------------------------------------------------
'// String IDs from status and error callbacks
'// ------------------------------------------------------------------

Public Const IDS_CAP_BEGIN = 300 '/* "Capture Start" */
Public Const IDS_CAP_END = 301 '/* "Capture End" */

Public Const IDS_CAP_INFO = 401 '/* "%s" */
Public Const IDS_CAP_OUTOFMEM = 402 '/* "Out of memory" */
Public Const IDS_CAP_FILEEXISTS = 403 '/* "File '%s' exists -- overwrite it?" */
Public Const IDS_CAP_ERRORPALOPEN = 404 '/* "Error opening palette '%s'" */
Public Const IDS_CAP_ERRORPALSAVE = 405 '/* "Error saving palette '%s'" */
Public Const IDS_CAP_ERRORDIBSAVE = 406 '/* "Error saving frame '%s'" */
Public Const IDS_CAP_DEFAVIEXT = 407 '/* "avi" */
Public Const IDS_CAP_DEFPALEXT = 408 '/* "pal" */
Public Const IDS_CAP_CANTOPEN = 409 '/* "Cannot open '%s'" */
Public Const IDS_CAP_SEQ_MSGSTART = 410 '/* "Select OK to start capture\nof video sequence\nto %s." */

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

137 回复:把焦点定位到任何已运行的窗口。
Public Const IDS_CAP_SEQ_MSGSTOP = 411 '/* "Hit ESCAPE or click to end capture" */

Public Const IDS_CAP_VIDEDITERR = 412 '/* "An error occurred while trying to run VidEdit." */
Public Const IDS_CAP_READONLYFILE = 413 '/* "The file '%s' is a read-only file." */
Public Const IDS_CAP_WRITEERROR = 414 '/* "Unable to write to file '%s'.\nDisk may be full." */
Public Const IDS_CAP_NODISKSPACE = 415 '/* "There is no space to create a capture file on the specified device." */
Public Const IDS_CAP_SETFILESIZE = 416 '/* "Set File Size" */
Public Const IDS_CAP_SAVEASPERCENT = 417 '/* "SaveAs: %2ld%% Hit Escape to abort." */

Public Const IDS_CAP_DRIVER_ERROR = 418 '/* Driver specific error message */

Public Const IDS_CAP_WAVE_OPEN_ERROR = 419 '/* "Error: Cannot open the wave input device.\nCheck sample size, frequency, and channels." */
Public Const IDS_CAP_WAVE_ALLOC_ERROR = 420 '/* "Error: Out of memory for wave buffers." */
Public Const IDS_CAP_WAVE_PREPARE_ERROR = 421 '/* "Error: Cannot prepare wave buffers." */
Public Const IDS_CAP_WAVE_ADD_ERROR = 422 '/* "Error: Cannot add wave buffers." */
Public Const IDS_CAP_WAVE_SIZE_ERROR = 423 '/* "Error: Bad wave size." */

Public Const IDS_CAP_VIDEO_OPEN_ERROR = 424 '/* "Error: Cannot open the video input device." */
Public Const IDS_CAP_VIDEO_ALLOC_ERROR = 425 '/* "Error: Out of memory for video buffers." */
Public Const IDS_CAP_VIDEO_PREPARE_ERROR = 426 '/* "Error: Cannot prepare video buffers." */
Public Const IDS_CAP_VIDEO_ADD_ERROR = 427 '/* "Error: Cannot add video buffers." */
Public Const IDS_CAP_VIDEO_SIZE_ERROR = 428 '/* "Error: Bad video size." */

Public Const IDS_CAP_FILE_OPEN_ERROR = 429 '/* "Error: Cannot open capture file." */
Public Const IDS_CAP_FILE_WRITE_ERROR = 430 '/* "Error: Cannot write to capture file. Disk may be full." */
Public Const IDS_CAP_RECORDING_ERROR = 431 '/* "Error: Cannot write to capture file. Data rate too high or disk full." */
Public Const IDS_CAP_RECORDING_ERROR2 = 432 '/* "Error while recording" */
Public Const IDS_CAP_AVI_INIT_ERROR = 433 '/* "Error: Unable to initialize for capture." */
Public Const IDS_CAP_NO_FRAME_CAP_ERROR = 434 '/* "Warning: No frames captured.\nConfirm that vertical sync interrupts\nare configured and enabled." */
Public Const IDS_CAP_NO_PALETTE_WARN = 435 '/* "Warning: Using default palette." */
Public Const IDS_CAP_MCI_CONTROL_ERROR = 436 '/* "Error: Unable to access MCI device." */
Public Const IDS_CAP_MCI_CANT_STEP_ERROR = 437 '/* "Error: Unable to step MCI device." */
Public Const IDS_CAP_NO_AUDIO_CAP_ERROR = 438 '/* "Error: No audio data captured.\nCheck audio card settings." */
Public Const IDS_CAP_AVI_DRAWDIB_ERROR = 439 '/* "Error: Unable to draw this data format." */
Public Const IDS_CAP_COMPRESSOR_ERROR = 440 '/* "Error: Unable to initialize compressor." */
Public Const IDS_CAP_AUDIO_DROP_ERROR = 441 '/* "Error: Audio data was lost during capture, reduce capture rate." */

'/* status string IDs */
Public Const IDS_CAP_STAT_LIVE_MODE = 500 '/* "Live window" */

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

138 回复:把焦点定位到任何已运行的窗口。
Public Const IDS_CAP_STAT_OVERLAY_MODE = 501 '/* "Overlay window" */
Public Const IDS_CAP_STAT_CAP_INIT = 502 '/* "Setting up for capture - Please wait" */
Public Const IDS_CAP_STAT_CAP_FINI = 503 '/* "Finished capture, now writing frame %ld" */
Public Const IDS_CAP_STAT_PALETTE_BUILD = 504 '/* "Building palette map" */
Public Const IDS_CAP_STAT_OPTPAL_BUILD = 505 '/* "Computing optimal palette" */
Public Const IDS_CAP_STAT_I_FRAMES = 506 '/* "%d frames" */
Public Const IDS_CAP_STAT_L_FRAMES = 507 '/* "%ld frames" */
Public Const IDS_CAP_STAT_CAP_L_FRAMES = 508 '/* "Captured %ld frames" */
Public Const IDS_CAP_STAT_CAP_AUDIO = 509 '/* "Capturing audio" */
Public Const IDS_CAP_STAT_VIDEOCURRENT = 510 '/* "Captured %ld frames (%ld dropped) %d.%03d sec." */
Public Const IDS_CAP_STAT_VIDEOAUDIO = 511 '/* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps). %ld audio bytes (%d,%03d sps)" */
Public Const IDS_CAP_STAT_VIDEOONLY = 512 '/* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps)" */
Function capSetCallbackOnError(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnError = SendMessage(lwnd, WM_CAP_SET_CALLBACK_ERROR, 0, lpProc)
End Function
Function capSetCallbackOnStatus(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnStatus = SendMessage(lwnd, WM_CAP_SET_CALLBACK_STATUS, 0, lpProc)
End Function
Function capSetCallbackOnYield(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnYield = SendMessage(lwnd, WM_CAP_SET_CALLBACK_YIELD, 0, lpProc)
End Function
Function capSetCallbackOnFrame(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnFrame = SendMessage(lwnd, WM_CAP_SET_CALLBACK_FRAME, 0, lpProc)
End Function
Function capSetCallbackOnVideoStream(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnVideoStream = SendMessage(lwnd, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, lpProc)
End Function
Function capSetCallbackOnWaveStream(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnWaveStream = SendMessage(lwnd, WM_CAP_SET_CALLBACK_WAVESTREAM, 0, lpProc)
End Function
Function capSetCallbackOnCapControl(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnCapControl = SendMessage(lwnd, WM_CAP_SET_CALLBACK_CAPCONTROL, 0, lpProc)
End Function
Function capSetUserData(ByVal lwnd As Long, ByVal lUser As Long) As Boolean
capSetUserData = SendMessage(lwnd, WM_CAP_SET_USER_DATA, 0, lUser)
End Function
Function capGetUserData(ByVal lwnd As Long) As Long
capGetUserData = SendMessage(lwnd, WM_CAP_GET_USER_DATA, 0, 0)
End Function
Function capDriverConnect(ByVal lwnd As Long, ByVal i As Integer) As Boolean
capDriverConnect = SendMessage(lwnd, WM_CAP_DRIVER_CONNECT, i, 0)
End Function
Function capDriverDisconnect(ByVal lwnd As Long) As Boolean
capDriverDisconnect = SendMessage(lwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
End Function
Function capDriverGetName(ByVal lwnd As Long, ByVal szName As Long, ByVal wSize As Integer) As Boolean
capDriverGetName = SendMessage(lwnd, YOURCONSTANTMESSAGE, wSize, szName)

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

139 回复:把焦点定位到任何已运行的窗口。
End Function
Function capDriverGetVersion(ByVal lwnd As Long, ByVal szVer As Long, ByVal wSize As Integer) As Boolean
capDriverGetVersion = SendMessage(lwnd, WM_CAP_DRIVER_GET_VERSION, wSize, szVer)
End Function
Function capDriverGetCaps(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capDriverGetCaps = SendMessage(lwnd, WM_CAP_DRIVER_GET_CAPS, wSize, s)
End Function
Function capFileSetCaptureFile(ByVal lwnd As Long, szName As String) As Boolean
capFileSetCaptureFile = SendMessageS(lwnd, WM_CAP_FILE_SET_CAPTURE_FILE, 0, szName)
End Function
Function capFileGetCaptureFile(ByVal lwnd As Long, ByVal szName As Long, wSize As String) As Boolean
capFileGetCaptureFile = SendMessageS(lwnd, WM_CAP_FILE_SET_CAPTURE_FILE, wSize, szName)
End Function
Function capFileAlloc(ByVal lwnd As Long, ByVal dwSize As Long) As Boolean
capFileAlloc = SendMessage(lwnd, WM_CAP_FILE_ALLOCATE, 0, dwSize)
End Function
Function capFileSaveAs(ByVal lwnd As Long, szName As String) As Boolean
capFileSaveAs = SendMessageS(lwnd, WM_CAP_FILE_SAVEAS, 0, szName)
End Function
Function capFileSetInfoChunk(ByVal lwnd As Long, ByVal lpInfoChunk As Long) As Boolean
capFileSetInfoChunk = SendMessage(lwnd, WM_CAP_FILE_SET_INFOCHUNK, 0, lpInfoChunk)
End Function
Function capFileSaveDIB(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capFileSaveDIB = SendMessage(lwnd, WM_CAP_FILE_SAVEDIB, 0, szName)
End Function
Function capEditCopy(ByVal lwnd As Long) As Boolean
capEditCopy = SendMessage(lwnd, WM_CAP_EDIT_COPY, 0, 0)
End Function
Function capSetAudioFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capSetAudioFormat = SendMessage(lwnd, WM_CAP_SET_AUDIOFORMAT, wSize, s)
End Function
Function capGetAudioFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Long
capGetAudioFormat = SendMessage(lwnd, WM_CAP_GET_AUDIOFORMAT, wSize, s)
End Function
Function capGetAudioFormatSize(ByVal lwnd As Long) As Long
capGetAudioFormatSize = SendMessage(lwnd, WM_CAP_GET_AUDIOFORMAT, 0, 0)
End Function
Function capDlgVideoFormat(ByVal lwnd As Long) As Boolean
capDlgVideoFormat = SendMessage(lwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
End Function
Function capDlgVideoSource(ByVal lwnd As Long) As Boolean
capDlgVideoSource = SendMessage(lwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
End Function
Function capDlgVideoDisplay(ByVal lwnd As Long) As Boolean
capDlgVideoDisplay = SendMessage(lwnd, WM_CAP_DLG_VIDEODISPLAY, 0, 0)
End Function
Function capDlgVideoCompression(ByVal lwnd As Long) As Boolean
capDlgVideoCompression = SendMessage(lwnd, WM_CAP_DLG_VIDEOCOMPRESSION, 0, 0)
End Function
Function capGetVideoFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Long
capGetVideoFormat = SendMessage(lwnd, WM_CAP_GET_VIDEOFORMAT, wSize, s)
End Function
Function capGetVideoFormatSize(ByVal lwnd As Long) As Long
capGetVideoFormatSize = SendMessage(lwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
End Function
Function capSetVideoFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

140 回复:把焦点定位到任何已运行的窗口。
capSetVideoFormat = SendMessage(lwnd, WM_CAP_SET_VIDEOFORMAT, wSize, s)
End Function
Function capPreview(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capPreview = SendMessage(lwnd, WM_CAP_SET_PREVIEW, f, 0)
End Function
Function capPreviewRate(ByVal lwnd As Long, ByVal wMS As Integer) As Boolean
capPreviewRate = SendMessage(lwnd, WM_CAP_SET_PREVIEWRATE, wMS, 0)
End Function
Function capOverlay(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capOverlay = SendMessage(lwnd, WM_CAP_SET_OVERLAY, f, 0)
End Function
Function capPreviewScale(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capPreviewScale = SendMessage(lwnd, WM_CAP_SET_SCALE, f, 0)
End Function
Function capGetStatus(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capGetStatus = SendMessage(lwnd, WM_CAP_GET_STATUS, wSize, s)
End Function
Function capSetScrollPos(ByVal lwnd As Long, ByVal lpP As Long) As Boolean
capSetScrollPos = SendMessage(lwnd, WM_CAP_SET_SCROLL, 0, lpP)
End Function
Function capGrabFrame(ByVal lwnd As Long) As Boolean
capGrabFrame = SendMessage(lwnd, WM_CAP_GRAB_FRAME, 0, 0)
End Function
Function capGrabFrameNoStop(ByVal lwnd As Long) As Boolean
capGrabFrameNoStop = SendMessage(lwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0)
End Function
Function capCaptureSequence(ByVal lwnd As Long) As Boolean
capCaptureSequence = SendMessage(lwnd, WM_CAP_SEQUENCE, 0, 0)
End Function
Function capCaptureSequenceNoFile(ByVal lwnd As Long) As Boolean
capCaptureSequenceNoFile = SendMessage(lwnd, WM_CAP_SEQUENCE_NOFILE, 0, 0)
End Function
Function capCaptureStop(ByVal lwnd As Long) As Boolean
capCaptureStop = SendMessage(lwnd, WM_CAP_STOP, 0, 0)
End Function
Function capCaptureAbort(ByVal lwnd As Long) As Boolean
capCaptureAbort = SendMessage(lwnd, WM_CAP_ABORT, 0, 0)
End Function
Function capCaptureSingleFrameOpen(ByVal lwnd As Long) As Boolean
capCaptureSingleFrameOpen = SendMessage(lwnd, WM_CAP_SINGLE_FRAME_OPEN, 0, 0)
End Function
Function capCaptureSingleFrameClose(ByVal lwnd As Long) As Boolean
capCaptureSingleFrameClose = SendMessage(lwnd, WM_CAP_SINGLE_FRAME_CLOSE, 0, 0)
End Function
Function capCaptureSingleFrame(ByVal lwnd As Long) As Boolean
capCaptureSingleFrame = SendMessage(lwnd, WM_CAP_SINGLE_FRAME, 0, 0)
End Function
Function capCaptureGetSetup(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capCaptureGetSetup = SendMessage(lwnd, WM_CAP_GET_SEQUENCE_SETUP, wSize, s)
End Function
Function capCaptureSetSetup(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capCaptureSetSetup = SendMessage(lwnd, WM_CAP_SET_SEQUENCE_SETUP, wSize, s)
End Function
Function capSetMCIDeviceName(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capSetMCIDeviceName = SendMessage(lwnd, WM_CAP_SET_MCI_DEVICE, 0, szName)
End Function
Function capGetMCIDeviceName(ByVal lwnd As Long, ByVal szName As Long, ByVal wSize As Integer) As Boolean
capGetMCIDeviceName = SendMessage(lwnd, WM_CAP_GET_MCI_DEVICE, wSize, szName)
End Function

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

141 回复:把焦点定位到任何已运行的窗口。
Function capPaletteOpen(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capPaletteOpen = SendMessage(lwnd, WM_CAP_PAL_OPEN, 0, szName)
End Function
Function capPaletteSave(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capPaletteSave = SendMessage(lwnd, WM_CAP_PAL_SAVE, 0, szName)
End Function
Function capPalettePaste(ByVal lwnd As Long) As Boolean
capPalettePaste = SendMessage(lwnd, WM_CAP_PAL_PASTE, 0, 0)
End Function
Function capPaletteAuto(ByVal lwnd As Long, ByVal iFrames As Integer, ByVal iColor As Long) As Boolean
capPaletteAuto = SendMessage(lwnd, WM_CAP_PAL_AUTOCREATE, iFrames, iColors)
End Function
Function capPaletteManual(ByVal lwnd As Long, ByVal fGrab As Boolean, ByVal iColors As Long) As Boolean
capPaletteManual = SendMessage(lwnd, WM_CAP_PAL_MANUALCREATE, fGrab, iColors)
End Function

---------------
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ej@bantz.com
'* Web: http://ej.bantz.com
'*
Option Explicit

Private Sub Form_Load()

Dim lpszName As String * 100
Dim lpszVer As String * 100
Dim Caps As CAPDRIVERCAPS

'//Create Capture Window
capGetDriverDescriptionA 0, lpszName, 100, lpszVer, 100 '// Retrieves driver info
lwndC = capCreateCaptureWindowA(lpszName, WS_CAPTION Or WS_THICKFRAME Or WS_VISIBLE Or WS_CHILD, 0, 0, 160, 120, Me.hwnd, 0)

'// Set title of window to name of driver
SetWindowText lwndC, lpszName

'// Set the video stream callback function
capSetCallbackOnStatus lwndC, AddressOf MyStatusCallback
capSetCallbackOnError lwndC, AddressOf MyErrorCallback

'// Connect the capture window to the driver
If capDriverConnect(lwndC, 0) Then
'/////
'// Only do the following if the connect was successful.
'// if it fails, the error will be reported in the call
'// back function.
'/////
'// Get the capabilities of the capture driver
capDriverGetCaps lwndC, VarPtr(Caps), Len(Caps)

'// If the capture driver does not support a dialog, grey it out
'// in the menu bar.
If Caps.fHasDlgVideoSource = 0 Then mnuSource.Enabled = False
If Caps.fHasDlgVideoFormat = 0 Then mnuFormat.Enabled = False
If Caps.fHasDlgVideoDisplay = 0 Then mnuDisplay.Enabled = False

'// Turn Scale on
capPreviewScale lwndC, True

'// Set the preview rate in milliseconds
capPreviewRate lwndC, 66

'// Start previewing the image from the camera
capPreview lwndC, True

'// Resize the capture window to show the whole image
ResizeCaptureWindow lwndC

End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

'// Disable all callbacks
capSetCallbackOnError lwndC, vbNull
capSetCallbackOnStatus lwndC, vbNull
capSetCallbackOnYield lwndC, vbNull
capSetCallbackOnFrame lwndC, vbNull
capSetCallbackOnVideoStream lwndC, vbNull
capSetCallbackOnWaveStream lwndC, vbNull
capSetCallbackOnCapControl lwndC, vbNull

End Sub

Private Sub mnuAllocate_Click()

Dim sFile As String * 250
Dim lSize As Long

'// Setup swap file for capture
lSize = 1000000

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

142 回复:把焦点定位到任何已运行的窗口。
sFile = "C:\TEMP.AVI"
capFileSetCaptureFile lwndC, sFile
capFileAlloc lwndC, lSize

End Sub

Private Sub mnuAlwaysVisible_Click()

mnuAlwaysVisible.Checked = Not (mnuAlwaysVisible.Checked)

If mnuAlwaysVisible.Checked Then
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
Else
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
End If

End Sub

Private Sub mnuCompression_Click()
' /*
' * Display the Compression dialog when "Compression" is selected from
' * the menu bar.
' */

capDlgVideoCompression lwndC

End Sub

Private Sub mnuCopy_Click()

capEditCopy lwndC

End Sub

Private Sub mnuDisplay_Click()
' /*
' * Display the Video Display dialog when "Display" is selected from
' * the menu bar.
' */

capDlgVideoDisplay lwndC

End Sub

Private Sub mnuExit_Click()

Unload Me

End Sub

Private Sub mnuFormat_Click()
' /*
' * Display the Video Format dialog when "Format" is selected from the
' * menu bar.
' */

capDlgVideoFormat lwndC
ResizeCaptureWindow lwndC

End Sub

Private Sub mnuPreview_Click()

frmMain.StatusBar.SimpleText = vbNullString
mnuPreview.Checked = Not (mnuPreview.Checked)
capPreview lwndC, mnuPreview.Checked

End Sub

Private Sub mnuScale_Click()

mnuScale.Checked = Not (mnuScale.Checked)
capPreviewScale lwndC, mnuScale.Checked

If mnuScale.Checked Then
SetWindowLong lwndC, GWL_STYLE, WS_THICKFRAME Or WS_CAPTION Or WS_VISIBLE Or WS_CHILD
Else
SetWindowLong lwndC, GWL_STYLE, WS_BORDER Or WS_CAPTION Or WS_VISIBLE Or WS_CHILD
End If

ResizeCaptureWindow lwndC

End Sub

Private Sub mnuSelect_Click()

frmSelect.Show vbModal, Me

End Sub

Private Sub mnuSource_Click()
' /*
' * Display the Video Source dialog when "Source" is selected from the
' * menu bar.
' */

capDlgVideoSource lwndC

End Sub

Private Sub mnuStart_Click()
' /*
' * If Start is selected from the menu, start Streaming capture.
' * The streaming capture is terminated when the Escape key is pressed
' */

Dim sFileName As String
Dim CAP_PARAMS As CAPTUREPARMS

capCaptureGetSetup lwndC, VarPtr(CAP_PARAMS), Len(CAP_PARAMS)

CAP_PARAMS.dwRequestMicroSecPerFrame = (1 * (10 ^ 6)) / 30 ' 30 Frames per second
CAP_PARAMS.fMakeUserHitOKToCapture = True
CAP_PARAMS.fCaptureAudio = False

capCaptureSetSetup lwndC, VarPtr(CAP_PARAMS), Len(CAP_PARAMS)

sFileName = "C:\myvideo.avi"

capCaptureSequence lwndC ' Start Capturing!
capFileSaveAs lwndC, sFileName ' Copy video from swap file into a real file.

End Sub

Private Sub StatusBar1_PanelClick(ByVal Panel As ComctlLib.Panel)

End Sub
---------------
Option Explicit

Private Sub Command1_Click()

End Sub

Private Sub cmdCancel_Click()

Unload Me

End Sub

Private Sub cmdSelect_Click()

Dim sTitle As String
Dim Caps As CAPDRIVERCAPS

If cmboSource.ListIndex <> -1 Then

'// Connect the capture window to the driver
If capDriverConnect(lwndC, cmboSource.ListIndex) Then

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

143 回复:把焦点定位到任何已运行的窗口。

'// Get the capabilities of the capture driver
capDriverGetCaps lwndC, VarPtr(Caps), Len(Caps)

'// If the capture driver does not support a dialog, grey it out
'// in the menu bar.
frmMain.mnuSource.Enabled = Caps.fHasDlgVideoSource
frmMain.mnuFormat.Enabled = Caps.fHasDlgVideoFormat
frmMain.mnuDisplay.Enabled = Caps.fHasDlgVideoDisplay

sTitle = cmboSource.Text

SetWindowText lwndC, sTitle
ResizeCaptureWindow lwndC
End If

End If

Unload Me

End Sub

Private Sub Form_Load()

Dim lpszName As String * 100
Dim lpszVer As String * 100
Dim x As Integer
Dim lResult As Long
Dim Caps As CAPDRIVERCAPS

'// Get a list of all the installed drivers
x = 0
Do
lResult = capGetDriverDescriptionA(x, lpszName, 100, lpszVer, 100) '// Retrieves driver info
If lResult Then
cmboSource.AddItem lpszName
x = x + 1
End If
Loop Until lResult = False

'// Get the capabilities of the current capture driver
lResult = capDriverGetCaps(lwndC, VarPtr(Caps), Len(Caps))

'// Select the driver that is currently being used
If lResult Then cmboSource.ListIndex = Caps.wDeviceIndex

End Sub

-------------
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ejbantz@usa.net
'* Web: http://www.inlink.com/~ejbantz

'// ------------------------------------------------------------------
'// Windows API Constants / Types / Declarations
'// ------------------------------------------------------------------
Public Const WS_BORDER = &H800000
Public Const WS_CAPTION = &HC00000
Public Const WS_SYSMENU = &H80000
Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_THICKFRAME = &H40000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = 1
Public Const SWP_NOZORDER = &H4
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SM_CYCAPTION = 4
Public Const SM_CXFRAME = 32
Public Const SM_CYFRAME = 33
Public Const WS_EX_TRANSPARENT = &H20&
Public Const GWL_STYLE = (-16)
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'// Memory manipulation
Declare Function lStrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Declare Function lStrCpyn Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As Any, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Declare Sub RtlMoveMemory Lib "kernel32" (ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
Declare Sub hmemcpy Lib "kernel32" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'// Window manipulation
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

144 回复:把焦点定位到任何已运行的窗口。
Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public lwndC As Long ' Handle to the Capture Windows

Function MyFrameCallback(ByVal lwnd As Long, ByVal lpVHdr As Long) As Long

Debug.Print "FrameCallBack"

Dim VideoHeader As VIDEOHDR
Dim VideoData() As Byte

'//Fill VideoHeader with data at lpVHdr
RtlMoveMemory VarPtr(VideoHeader), lpVHdr, Len(VideoHeader)

'// Make room for data
ReDim VideoData(VideoHeader.dwBytesUsed)

'//Copy data into the array
RtlMoveMemory VarPtr(VideoData(0)), VideoHeader.lpData, VideoHeader.dwBytesUsed

Debug.Print VideoHeader.dwBytesUsed
Debug.Print VideoData

End Function

Function MyYieldCallback(lwnd As Long) As Long

Debug.Print "Yield"

End Function

Function MyErrorCallback(ByVal lwnd As Long, ByVal iID As Long, ByVal ipstrStatusText As Long) As Long

If iID = 0 Then Exit Function

Dim sStatusText As String
Dim usStatusText As String

'Convert the Pointer to a real VB String
sStatusText = String$(255, 0) '// Make room for message
lStrCpy StrPtr(sStatusText), ipstrStatusText '// Copy message into String
sStatusText = Left$(sStatusText, InStr(sStatusText, Chr$(0)) - 1) '// Only look at left of null
usStatusText = StrConv(sStatusText, vbUnicode) '// Convert Unicode

LogError usStatusText, iID

End Function

Function MyStatusCallback(ByVal lwnd As Long, ByVal iID As Long, ByVal ipstrStatusText As Long) As Long

If iID = 0 Then Exit Function

Dim sStatusText As String
Dim usStatusText As String

'// Convert the Pointer to a real VB String
sStatusText = String$(255, 0) '// Make room for message
lStrCpy StrPtr(sStatusText), ipstrStatusText '// Copy message into String
sStatusText = Left$(sStatusText, InStr(sStatusText, Chr$(0)) - 1) '// Only look at left of null
usStatusText = StrConv(sStatusText, vbUnicode) '// Convert Unicode

frmMain.StatusBar.SimpleText = usStatusText
Debug.Print "Status: ", usStatusText, iID

Select Case iID '

End Select

End Function

Sub ResizeCaptureWindow(ByVal lwnd As Long)

Dim CAPSTATUS As CAPSTATUS
Dim lCaptionHeight As Long
Dim lX_Border As Long
Dim lY_Border As Long

lCaptionHeight = GetSystemMetrics(SM_CYCAPTION)
lX_Border = GetSystemMetrics(SM_CXFRAME)
lY_Border = GetSystemMetrics(SM_CYFRAME)

'// Get the capture window attributes .. width and height
If capGetStatus(lwnd, VarPtr(CAPSTATUS), Len(CAPSTATUS)) Then

'// Resize the capture window to the capture sizes
SetWindowPos lwnd, HWND_BOTTOM, 0, 0, _
CAPSTATUS.uiImageWidth + (lX_Border * 2), _
CAPSTATUS.uiImageHeight + lCaptionHeight + (lY_Border * 2), _
SWP_NOMOVE Or SWP_NOZORDER
End If

Debug.Print "Resize Window."

End Sub

Function MyVideoStreamCallback(lwnd As Long, lpVHdr As Long) As Long

Beep '// Replace this with your code!

End Function

Function MyWaveStreamCallback(lwnd As Long, lpVHdr As Long) As Long

Debug.Print "WaveStream"

End Function

Sub LogError(txtError As String, lID As Long)

frmMain.StatusBar.SimpleText = txtError
Debug.Print "Error: ", txtError, lID

End Sub

作者: 61.142.212.* 2005-10-28 22:07 　回复此发言

--------------------------------------------------------------------------------

145 利用微软的语音引擎使你的程序会朗读,需要安装微软语音引擎或者金
Dim vText As New VTxtAuto.VTxtAuto

Private Sub Command1_Click()
Dim astr As String

Command1.Enabled = False
vText.Register vbNullString, "Speech"
'vtext.Register
astr = "This is a sample of Microsoft Speech Engine?"
vText.Speak astr, vtxtsp_NORMAL Or vtxtst_QUESTION
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set vText = Nothing
End Sub

作者: 61.142.212.* 2005-10-28 22:09 　回复此发言

--------------------------------------------------------------------------------

146 一个屏幕保护的程序(流星)。
Private W As Integer
Private H As Integer

Private Sub Command1_Click()
Label1.Visible = False
MoveTo = move_forward
Command1.Visible = False
Accelarate = False
WindowState = 2
W = ScaleWidth
H = ScaleHeight

For i = 1 To 150

Star(i).x = W / 2
Star(i).y = H / 2
RandomX:
Randomize
Star(i).AddX = Int(Rnd * 29) - Int(Rnd * 29)
If Star(i).AddX = 0 Then GoTo RandomX
RandomY:
Star(i).AddY = Int(Rnd * 19) - Int(Rnd * 19)
If Star(i).AddY = 0 Then GoTo RandomY

Next

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
End
End If

If KeyCode = vbKeySpace Then Accelarate = True
If KeyCode = vbKeyF1 Then
ChDir App.Path
Shell "NOTEPAD.EXE 3Dstarfield.txt", vbMaximizedFocus
End If

End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeySpace Then Accelarate = False

End Sub

Private Sub Form_Load()

Move Screen.Width / 2 - Width / 2, Screen.Height / 2 - Height / 2
Command1.Move ScaleWidth / 2 - Command1.Width / 2, ScaleHeight / 4 - Command1.Height / 2
Label1.Move ScaleWidth / 2 - Label1.Width / 2, ScaleHeight / 2 - Label1.Height / 2

End Sub

Private Sub Timer1_Timer()
If Command1.Visible = True Then Exit Sub

For i = 1 To 150

SetPixel hdc, W / 2, H / 2, &H404040

Select Case Abs(W / 2 - (Star(i).x))
Case Is < 20
col = &H0&
Size = 1
Case Is < 80
col = &H404040
Size = 1
Case Is < 150
col = &H808080
Size = 2
Case Is < 200
col = &HC0C0C0
Size = 3
Case Is < 250
col = &HFFFFFF
Size = 4
Case Else
col = &HFFFFFF
Size = 5

End Select

Select Case Abs(H / 2 - (Star(i).y))

Case Is < 20
If Size = 0 Then
Size = 1
col = back5
End If
Case Is < 80
If Size = 0 Then
col = &H404040
Size = 1
End If
Case Is < 150
If Size < 2 Then
Size = 2
col = &H808080
End If
Case Is < 200
If Size < 3 Then
Size = 3
col = &HC0C0C0
End If
Case Is < 250
If Size < 4 Then
Size = 4
col = &HFFFFFF
End If
Case Else
If Size < 5 Then
Size = 5
col = &HFFFFFF
End If

End Select

SetPixel hdc, W / 2, H / 2, col

Select Case Size
Case 1
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
Case 2
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
Case 3
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
Case 4
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&

作者: 61.142.212.* 2005-10-28 22:10 　回复此发言

--------------------------------------------------------------------------------

147 一个屏幕保护的程序(流星)。
SetPixel Me.hdc, Star(i).x - 1, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
Case 5
SetPixel Me.hdc, Star(i).x + a, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + a, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + a, Star(i).y - 2, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y - 2, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 2 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 2 + Star(i).AddY, col
End Select

Star(i).x = Star(i).x + Star(i).AddX
Star(i).y = Star(i).y + Star(i).AddY
Star(i).AddX = Star(i).AddX + Sgn(Star(i).AddX) * (Size / 5)
Star(i).AddY = Star(i).AddY + Sgn(Star(i).AddY) * (Size / 5)
If Accelarate Then
Star(i).AddX = Star(i).AddX + Sgn(Star(i).AddX) * Size
Star(i).AddY = Star(i).AddY + Sgn(Star(i).AddY) * Size
End If

If Star(i).x < 0 Or Star(i).x > ScaleWidth Or Star(i).y < 0 Or Star(i).y > ScaleHeight Then
Star(i).x = W / 2
Star(i).y = H / 2
RandomX:
Randomize
Star(i).AddX = Int(Rnd * 29) - Int(Rnd * 29)
If Star(i).AddX = 0 Then GoTo RandomX
RandomY:
Star(i).AddY = Int(Rnd * 19) - Int(Rnd * 19)
If Star(i).AddY = 0 Then GoTo RandomY
End If

End Sub

-------------
Public Type Stars
x As Double
y As Integer
AddX As Integer
AddY As Integer
End Type

Public Star(1000) As Stars
Public Accelarate As Boolean

Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

作者: 61.142.212.* 2005-10-28 22:10 　回复此发言

--------------------------------------------------------------------------------

148 MIDI电子琴(建议装上软波表)。(强力推荐)
' 《VB前线》http://vbbattlefront.163.net
'************************************************************
'* VB 系列功能演示程序 *
'* *
'* 如果您发现此程序有任何不妥之处或存在需要改进的地方, *
'* 望告诉我本人,本人将非常感激您,并一定回信致谢! *
'* *
'* by 池星泽(Xing) my Email:vbxing@990.net *
'************************************************************
'*程序编号∶033
'*功能∶MIDI电子琴
'*日期∶4/25/1999
'************************************************************
Option Explicit

Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private isOgain As Boolean '是否重复按键
Private Sta As Integer
Private Sub ComDevies_Click()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Command2_Click()
Open App.Path & "\haap.txt" For Input As #1
ComDevies.ListIndex = 0
ComSounds.ListIndex = 9
HScroll1.Value = 32
Timer2.Enabled = True
Command2.Enabled = False
End Sub

Private Sub ComSounds_Click()
Call program_change(0, 0, ComSounds.ListIndex)
End Sub

Private Sub Form_Load()
Dim Retu As Boolean
Dim i As Integer

Retu = Midi_OutDevsToList(ComDevies)
ComDevies.ListIndex = 0
Call fill_sound_list

For i = 0 To 64
Picture1(i).DragMode = 1
Next
HScroll1.Value = 36
HScroll2.Value = 127
End Sub
Private Sub fill_sound_list()
Dim s As String

Open App.Path & "\genmidi.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, s
ComSounds.AddItem s
Loop
ComSounds.ListIndex = 0
Close #1
End Sub

Private Sub Form_Unload(Cancel As Integer)
midi_OutClose
End
End Sub

Private Sub HScroll1_Change()
Sta = HScroll1.Value
Label2.Caption = Diao(Sta Mod 12)
End Sub

Private Sub HScroll2_Change()
sudu = HScroll2.Value
End Sub

Private Sub HScroll3_Change()
Label6.Caption = HScroll3.Value
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim i As Integer
For i = 0 To 64 '关闭所有的发音
Call note_off(0, i + Sta)
Next
End Sub

Private Sub Picture1_DragOver(Index As Integer, Source As Control, x As Single, Y As Single, State As Integer)
'完成发音
Static OldNote As Integer
If (OldNote <> Index) Or (isOgain = True) Then
Call note_off(0, OldNote + Sta)
Call note_on(0, Index + Sta, sudu) '参数分别为通道编号,音调,速度
OldNote = Index
isOgain = False
End If
End Sub
Private Sub Timer1_Timer()
Dim MyKey As Integer
MyKey% = GetKeyState(VK_LBUTTON)
If MyKey% And &H4000 Then
isOgain = False
Else
isOgain = True
End If
End Sub

Private Sub Timer2_Timer()
Dim s As String
Dim Index As Integer
Line Input #1, s
s = Trim(s)
If s = "End" Then
Close #1
Timer2.Enabled = False
Command2.Enabled = True
Label1_MouseMove 0, 0, 1, 1
Exit Sub
End If
Index = Val(s)
If Index < 100 Then
Index = Index + 7
Picture1_DragOver Index, Picture1(Index), 1, 1, 1
Index = Index + 24

作者: 61.142.212.* 2005-10-28 22:12 　回复此发言

--------------------------------------------------------------------------------

149 MIDI电子琴(建议装上软波表)。(强力推荐)
Picture1_DragOver Index, Picture1(Index), 1, 1, 1
End If
isOgain = True
End Sub
Private Function Diao(i As Integer) As String
Select Case i
Case 0
Diao = "C"
Case 1
Diao = "C#"
Case 2
Diao = "D"
Case 3
Diao = "D#"
Case 4
Diao = "E"
Case 5
Diao = "F"
Case 6
Diao = "F#"
Case 7
Diao = "G"
Case 8
Diao = "G#"
Case 9
Diao = "A"
Case 10
Diao = "A#"
Case 11
Diao = "B"
End Select
End Function
---------------
Option Explicit

Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare Function MIDIOutOpen Lib "winmm.dll" Alias "midiOutOpen" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long

Private Const MAXERRORLENGTH = 128 ' max error text length (including NULL)

Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS结构描述了Musical Instrument Digital Interface(MIDI)输入设备的性能
Type MIDIOUTCAPS
wMid As Integer
wPid As Integer ' 产品 ID
vDriverVersion As Long ' 设备版本
szPname As String * 32 ' 设备 name
wTechnology As Integer ' 设备类型
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type

Dim hMidi As Long

Public Function Midi_OutDevsToList(Obj As Control) As Boolean
Dim i As Integer
Dim midicaps As MIDIOUTCAPS
Dim isAdd As Boolean

Obj.Clear
isAdd = False
If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then '若获取设备信息成功
Obj.AddItem midicaps.szPname '添加设备名称
Obj.ItemData(Obj.NewIndex) = MIDIMAPPER '这是默认设备ID = -1
isAdd = True
End If
'添加其他设备
For i = 0 To midiOutGetNumDevs() - 1
If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
Obj.AddItem midicaps.szPname
Obj.ItemData(Obj.NewIndex) = i
isAdd = True
End If
Next
Midi_OutDevsToList = isAdd
End Function
Public Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer

midi_OutClose
midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
MIDI_OutOpen = (hMidi <> 0)
End Function
Public Sub midi_OutClose()
Dim midi_error As Integer

If hMidi <> 0 Then
midi_error = midiOutClose(hMidi)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
hMidi = 0
End If
End Sub
Public Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
Call midi_outshort(&H90 + ch, kk, v)
End Sub

Public Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 0)
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)
Dim midi_error As Integer

midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100 + b1)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
End Sub
Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
Call control_change(ch, 0, cc0nr)
Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub
Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)
Call midi_outshort(&HB0 + ch, ccnr, v)
End Sub

Sub midisetrpn(ch As Integer, pmsb As Integer, plsb As Integer, msb As Integer, lsb As Integer)
Call midi_outshort(ch, &H65, pmsb)
Call midi_outshort(ch, &H64, plsb)
Call midi_outshort(ch, &H6, msb)
Call midi_outshort(ch, &H26, lsb)
End Sub
Sub midi_outerr(ByVal midi_error As Integer)
Dim s As String
Dim x As Integer

s = Space(MAXERRORLENGTH)
x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
MsgBox s

End Sub

作者: 61.142.212.* 2005-10-28 22:12 　回复此发言

--------------------------------------------------------------------------------

150 电子琴
Option Explicit

Const INVALID_NOTE = -1 ' Code for keyboard keys that we don't handle

Dim numDevices As Long ' number of midi output devices
Dim curDevice As Long ' current midi device
Dim hmidi As Long ' midi output handle
Dim rc As Long ' return code
Dim midimsg As Long ' midi output message buffer
Dim channel As Integer ' midi output channel
Dim volume As Integer ' midi volume
Dim baseNote As Integer ' the first note on our "piano"

' Set the value for the starting note of the piano
Private Sub base_Click()
Dim s As String
Dim i As Integer
s = InputBox("Enter the new base note for the keyboard (0 - 111)", "Base note", CStr(baseNote))
If IsNumeric(s) Then
i = CInt(s)
If (i >= 0 And i < 112) Then
baseNote = i
End If
End If
End Sub

' Select the midi output channel
Private Sub chan_Click(Index As Integer)
chan(channel).Checked = False
channel = Index
chan(channel).Checked = True
End Sub

' Open the midi device selected in the menu. The menu index equals the
' midi device number + 1.
Private Sub device_Click(Index As Integer)
device(curDevice + 1).Checked = False
device(Index).Checked = True
curDevice = Index - 1
rc = midiOutClose(hmidi)
rc = midiOutOpen(hmidi, curDevice, 0, 0, 0)
If (rc <> 0) Then
MsgBox "Couldn't open midi out, rc = " & rc
End If
End Sub

' If user presses a keyboard key, start the corresponding midi note
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
StartNote NoteFromKey(KeyCode)
End Sub

' If user lifts a keyboard key, stop the corresponding midi note
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
StopNote NoteFromKey(KeyCode)
End Sub

Private Sub Form_Load()
Dim i As Long
Dim caps As MIDIOUTCAPS

' Set the first device as midi mapper
device(0).Caption = "MIDI Mapper"
device(0).Visible = True
device(0).Enabled = True

' Get the rest of the midi devices
numDevices = midiOutGetNumDevs()
For i = 0 To (numDevices - 1)
midiOutGetDevCaps i, caps, Len(caps)
device(i + 1).Caption = caps.szPname
device(i + 1).Visible = True
device(i + 1).Enabled = True
Next

' Select the MIDI Mapper as the default device
device_Click (0)

' Set the default channel
channel = 0
chan(channel).Checked = True

' Set the base note
baseNote = 60

' Set volume range
volume = 127
vol.Min = 127
vol.Max = 0
vol.Value = volume

End Sub

Private Sub Form_Unload(Cancel As Integer)
' Close current midi device
rc = midiOutClose(hmidi)
End Sub

' Start a note when user click on it
Private Sub key_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StartNote (Index)
End Sub

' Stop the note when user lifts the mouse button
Private Sub key_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StopNote (Index)
End Sub

' Press the button and send midi start event
Private Sub StartNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
If (key(Index).Value = 1) Then

151 电子琴
Exit Sub
End If
key(Index).Value = 1
midimsg = &H90 + ((baseNote + Index) * &H100) + (volume * &H10000) + channel
midiOutShortMsg hmidi, midimsg
End Sub

' Raise the button and send midi stop event
Private Sub StopNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
key(Index).Value = 0
midimsg = &H80 + ((baseNote + Index) * &H100) + channel
midiOutShortMsg hmidi, midimsg
End Sub

' Get the note corresponding to a keyboard key
Private Function NoteFromKey(key As Integer)
NoteFromKey = INVALID_NOTE
Select Case key
Case vbKeyZ
NoteFromKey = 0
Case vbKeyS
NoteFromKey = 1
Case vbKeyX
NoteFromKey = 2
Case vbKeyD
NoteFromKey = 3
Case vbKeyC
NoteFromKey = 4
Case vbKeyV
NoteFromKey = 5
Case vbKeyG
NoteFromKey = 6
Case vbKeyB
NoteFromKey = 7
Case vbKeyH
NoteFromKey = 8
Case vbKeyN
NoteFromKey = 9
Case vbKeyJ
NoteFromKey = 10
Case vbKeyM
NoteFromKey = 11
Case 188 ' comma
NoteFromKey = 12
Case vbKeyL
NoteFromKey = 13
Case 190 ' period
NoteFromKey = 14
Case 186 ' semicolon
NoteFromKey = 15
Case 191 ' forward slash
NoteFromKey = 16
End Select

End Function

' Set the volume
Private Sub vol_Change()
volume = vol.Value
End Sub
-------
'This is a complete piano application u can contact me at haisrini@email.com

Option Explicit

Public Const MAXPNAMELEN = 32 ' Maximum product name length

' Error values for functions used in this sample. See the function for more information
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error

Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MIDIERR_BASE = 64
Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing
Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy
Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode

'User-defined variable the stores information about the MIDI output device.
Type MIDIOUTCAPS
wMid As Integer ' Manufacturer identifier of the device driver for the MIDI output device
' For a list of identifiers, see the Manufacturer Indentifier topic in the
' Multimedia Reference of the Platform SDK.

wPid As Integer ' Product Identifier Product of the MIDI output device. For a list of
' product identifiers, see the Product Identifiers topic in the Multimedia
' Reference of the Platform SDK.

vDriverVersion As Long ' Version number of the device driver for the MIDI output device.
' The high-order byte is the major version number, and the low-order byte is
' the minor version number.

szPname As String * MAXPNAMELEN ' Product name in a null-terminated string.

wTechnology As Integer ' One of the following that describes the MIDI output device:

作者: 61.142.212.* 2005-10-28 22:18 　回复此发言

--------------------------------------------------------------------------------

152 电子琴
' MOD_FMSYNTH-The device is an FM synthesizer.
' MOD_MAPPER-The device is the Microsoft MIDI mapper.
' MOD_MIDIPORT-The device is a MIDI hardware port.
' MOD_SQSYNTH-The device is a square wave synthesizer.
' MOD_SYNTH-The device is a synthesizer.

wVoices As Integer ' Number of voices supported by an internal synthesizer device. If the
' device is a port, this member is not meaningful and is set to 0.

wNotes As Integer ' Maximum number of simultaneous notes that can be played by an internal
' synthesizer device. If the device is a port, this member is not meaningful
' and is set to 0.

wChannelMask As Integer ' Channels that an internal synthesizer device responds to, where the least
' significant bit refers to channel 0 and the most significant bit to channel
' 15. Port devices that transmit on all channels set this member to 0xFFFF.

dwSupport As Long ' One of the following describes the optional functionality supported by
' the device:
' MIDICAPS_CACHE-Supports patch caching.
' MIDICAPS_LRVOLUME-Supports separate left and right volume control.
' MIDICAPS_STREAM-Provides direct support for the midiStreamOut function.
' MIDICAPS_VOLUME-Supports volume control.
'
' If a device supports volume changes, the MIDICAPS_VOLUME flag will be set
' for the dwSupport member. If a device supports separate volume changes on
' the left and right channels, both the MIDICAPS_VOLUME and the
' MIDICAPS_LRVOLUME flags will be set for this member.
End Type

Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
' This function retrieves the number of MIDI output devices present in the system.
' The function returns the number of MIDI output devices. A zero return value means
' there are no MIDI devices in the system.

Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
' This function queries a specified MIDI output device to determine its capabilities.
' The function requires the following parameters;
' uDeviceID- unsigned integer variable identifying of the MIDI output device. The
' device identifier specified by this parameter varies from zero to one
' less than the number of devices present. This parameter can also be a
' properly cast device handle.
' lpMidiOutCaps- address of a MIDIOUTCAPS structure. This structure is filled with
' information about the capabilities of the device.
' cbMidiOutCaps- the size, in bytes, of the MIDIOUTCAPS structure. Use the Len
' function with the MIDIOUTCAPS variable as the argument to get
' this value.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MMSYSERR_BADDEVICEID The specified device identifier is out of range.
' MMSYSERR_INVALPARAM The specified pointer or structure is invalid.
' MMSYSERR_NODRIVER The driver is not installed.
' MMSYSERR_NOMEM The system is unable to load mapper string description.

Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long

作者: 61.142.212.* 2005-10-28 22:18 　回复此发言

--------------------------------------------------------------------------------

153 电子琴
' The function closes the specified MIDI output device. The function requires a
' handle to the MIDI output device. If the function is successful, the handle is no
' longer valid after the call to this function. A successful function call returns
' MMSYSERR_NOERROR.

' A failure returns one of the following:
' MIDIERR_STILLPLAYING Buffers are still in the queue.
' MMSYSERR_INVALHANDLE The specified device handle is invalid.
' MMSYSERR_NOMEM The system is unable to load mapper string description.

Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
' The function opens a MIDI output device for playback. The function requires the
' following parameters
' lphmo- Address of an HMIDIOUT handle. This location is filled with a
' handle identifying the opened MIDI output device. The handle
' is used to identify the device in calls to other MIDI output
' functions.
' uDeviceID- Identifier of the MIDI output device that is to be opened.
' dwCallback- Address of a callback function, an event handle, a thread
' identifier, or a handle of a window or thread called during
' MIDI playback to process messages related to the progress of
' the playback. If no callback is desired, set this value to 0.
' dwCallbackInstance- User instance data passed to the callback. Set this value to 0.
' dwFlags-Callback flag for opening the device. Set this value to 0.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MIDIERR_NODEVICE- No MIDI port was found. This error occurs only when the mapper is opened.
' MMSYSERR_ALLOCATED- The specified resource is already allocated.
' MMSYSERR_BADDEVICEID- The specified device identifier is out of range.
' MMSYSERR_INVALPARAM- The specified pointer or structure is invalid.
' MMSYSERR_NOMEM- The system is unable to allocate or lock memory.

Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
' This function sends a short MIDI message to the specified MIDI output device. The function
' requires the handle to the MIDI output device and a message is packed into a doubleword
' value with the first byte of the message in the low-order byte. See the code sample for
' how to create this value.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MIDIERR_BADOPENMODE- The application sent a message without a status byte to a stream handle.
' MIDIERR_NOTREADY- The hardware is busy with other data.
' MMSYSERR_INVALHANDLE- The specified device handle is invalid.

作者: 61.142.212.* 2005-10-28 22:18 　回复此发言

--------------------------------------------------------------------------------

154 回复:把焦点定位到任何已运行的窗口。
Option Explicit

Private Sub cmdScreen_Click()
Set Picture1.Picture = CaptureScreen()
End Sub

Private Sub cmdForm_Click()
'
' Get the whole form inclusing borders, caption,...
'
Set Picture1.Picture = CaptureForm(Me)
End Sub

Private Sub cmdClient_Click()
'
' Just get the client area of the form,
' no borders, caption,...
'
Set Picture1.Picture = CaptureClient(Me)
End Sub

Private Sub cmdActive_Click()
Dim EndTime As Date
'
' Give the user 2 seconds to activate
' a window then capture it.
'
MsgBox "Two seconds after you close this dialog " & _
"the active window will be captured.", _
vbInformation, "Capture Active Window"
'
' Wait for two seconds
'
EndTime = DateAdd("s", 2, Now)
Do Until Now > EndTime
DoEvents
Loop
'
' Get the active window.
' Set focus back to form
'
Set Picture1.Picture = CaptureActiveWindow()
Me.SetFocus
End Sub

Private Sub cmdPrint_Click()
'
' Print the contents of the picturebox.
'
Call PrintPictureToFitPage(Printer, Picture1.Picture)
Printer.EndDoc
End Sub

Private Sub cmdClear_Click()
Set Picture1.Picture = Nothing
End Sub

Private Sub Form_Load()
'
' Capture any form or window including the screen into a
' Visual Basic Picture object. Once the on-screen image
' is captured in the Picture object, it can be printed
' using the PaintPicture method of the Visual Basic
' Printer object.
'
' Automatically resize the picturebox
' according to the size of its contents.
'
Picture1.AutoSize = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set frmCapture = Nothing
End Sub

------------
Option Explicit
Option Base 0
'
' This module contains several routines for capturing windows into a
' picture. All routines have palette support.
'
' CreateBitmapPicture - Creates a picture object from a bitmap and palette.
' CaptureWindow - Captures any window given a window handle.
' CaptureActiveWindow - Captures the active window on the desktop.
' CaptureForm - Captures the entire form.
' CaptureClient - Captures the client area of a form.
' CaptureScreen - Captures the entire screen.
' PrintPictureToFitPage - prints any picture as big as possible on the page.
'
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type

Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
'
' DC = Device Context
'
' Creates a bitmap compatible with the device associated
' with the specified DC.
Private Declare Function CreateCompatibleBitmap Lib "GDI32" ( _

作者: 61.142.212.* 2005-10-28 22:22 　回复此发言

--------------------------------------------------------------------------------

155 回复:把焦点定位到任何已运行的窗口。
ByVal hDC As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long

' Retrieves device-specific information about a specified device.
Private Declare Function GetDeviceCaps Lib "GDI32" ( _
ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long

' Retrieves a range of palette entries from the system palette
' associated with the specified DC.
Private Declare Function GetSystemPaletteEntries Lib "GDI32" ( _
ByVal hDC As Long, ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
As Long

' Creates a memory DC compatible with the specified device.
Private Declare Function CreateCompatibleDC Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Creates a logical color palette.
Private Declare Function CreatePalette Lib "GDI32" ( _
lpLogPalette As LOGPALETTE) As Long

' Selects the specified logical palette into a DC.
Private Declare Function SelectPalette Lib "GDI32" ( _
ByVal hDC As Long, ByVal hPalette As Long, _
ByVal bForceBackground As Long) As Long

' Maps palette entries from the current logical
' palette to the system palette.
Private Declare Function RealizePalette Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Selects an object into the specified DC. The new
' object replaces the previous object of the same type.
' Returned is the handle of the replaced object.
Private Declare Function SelectObject Lib "GDI32" ( _
ByVal hDC As Long, ByVal hObject As Long) As Long

' Performs a bit-block transfer of color data corresponding to
' a rectangle of pixels from the source DC into a destination DC.
Private Declare Function BitBlt Lib "GDI32" ( _
ByVal hDCDest As Long, ByVal XDest As Long, _
ByVal YDest As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hDCSrc As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
As Long

' Retrieves the DC for the entire window, including title bar,
' menus, and scroll bars. A window DC permits painting anywhere
' in a window, because the origin of the DC is the upper-left
' corner of the window instead of the client area.
Private Declare Function GetWindowDC Lib "USER32" ( _
ByVal hWnd As Long) As Long

' Retrieves a handle to a display DC for the Client area of
' a specified window or for the entire screen. You can use
' the returned handle in subsequent GDI functions to draw in
' the DC.
Private Declare Function GetDC Lib "USER32" ( _
ByVal hWnd As Long) As Long

' Releases a DC, freeing it for use by other applications.
' The effect of the ReleaseDC function depends on the type
' of DC. It frees only common and window DCs. It has no
' effect on class or private DCs.
Private Declare Function ReleaseDC Lib "USER32" ( _
ByVal hWnd As Long, ByVal hDC As Long) As Long

' Deletes the specified DC.
Private Declare Function DeleteDC Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Retrieves the dimensions of the bounding rectangle of the
' specified window. The dimensions are given in screen
' coordinates that are relative to the upper-left corner

作者: 61.142.212.* 2005-10-28 22:22 　回复此发言

--------------------------------------------------------------------------------

156 回复:把焦点定位到任何已运行的窗口。
' of the screen.
Private Declare Function GetWindowRect Lib "USER32" ( _
ByVal hWnd As Long, lpRect As RECT) As Long

' Returns a handle to the Desktop window. The desktop
' window covers the entire screen and is the area on top
' of which all icons and other windows are painted.
Private Declare Function GetDesktopWindow Lib "USER32" () As Long

' Returns a handle to the foreground window (the window
' the user is currently working). The system assigns a
' slightly higher priority to the thread that creates the
' foreground window than it does to other threads.
Private Declare Function GetForegroundWindow Lib "USER32" () As Long

' Creates a new picture object initialized according to a PICTDESC
' structure, which can be NULL, to create an uninitialized object if
' the caller wishes to have the picture initialize itself through
' IPersistStream::Load. The fOwn parameter indicates whether the
' picture is to own the GDI picture handle for the picture it contains,
' so that the picture object will destroy its picture when the object
' itself is destroyed. The function returns an interface pointer to the
' new picture object specified by the caller in the riid parameter.
' A QueryInterface is built into this call. The caller is responsible
' for calling Release through the interface pointer returned - phew!
Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
' - Creates a bitmap type Picture object from a bitmap and palette.
'
' hBmp
' - Handle to a bitmap
'
' hPal
' - Handle to a Palette
' - Can be null if the bitmap doesn't use a palette
'
' Returns
' - Returns a Picture object containing the bitmap
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Dim r As Long
Dim Pic As PicBmp
'
' IPicture requires a reference to "Standard OLE Types"
'
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'
' Fill in with IDispatch Interface ID
'
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'
' Fill Pic with the necessary parts.
'
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With
'
' Create the Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'
' Return the new Picture object.
'
Set CreateBitmapPicture = IPic
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureWindow
' - Captures any portion of a window.
'
' hWndSrc
' - Handle to the window to be captured
'
' bClient
' - If True CaptureWindow captures from the bClient area of the
' window
' - If False CaptureWindow captures from the entire window

作者: 61.142.212.* 2005-10-28 22:22 　回复此发言

--------------------------------------------------------------------------------

157 回复:把焦点定位到任何已运行的窗口。
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
' - Specify the portion of the window to capture
' - Dimensions need to be specified in pixels
'
' Returns
' - Returns a Picture object containing a bitmap of the specified
' portion of the window that was captured
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function CaptureWindow(ByVal hWndSrc As Long, _
ByVal bClient As Boolean, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture

Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
'
' Get the proper Device Context (DC) depending on the value of bClient.
'
If bClient Then
hDCSrc = GetDC(hWndSrc) 'Get DC for Client area.
Else
hDCSrc = GetWindowDC(hWndSrc) 'Get DC for entire window.
End If
'
' Create a memory DC for the copy process.
'
hDCMemory = CreateCompatibleDC(hDCSrc)
'
' Create a bitmap and place it in the memory DC.
'
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
'
' Get the screen properties.
'
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) 'Raster capabilities
HasPaletteScrn = RasterCapsScrn And RC_PALETTE 'Palette support
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) 'Palette size
'
' If the screen has a palette make a copy and realize it.
'
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'
' Create a copy of the system palette.
'
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
'
' Select the new palette into the memory DC and realize it.
'
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
'
' Copy the on-screen image into the memory DC.
'
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
LeftSrc, TopSrc, vbSrcCopy)
'
' Remove the new copy of the on-screen image.
'
hBmp = SelectObject(hDCMemory, hBmpPrev)
'
' If the screen has a palette get back the
' palette that was selected in previously.
'
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
'
' Release the DC resources back to the system.
'
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
'
' Create a picture object from the bitmap
' and palette handles.
'
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CaptureScreen() As Picture
Dim hWndScreen As Long
'
' Get a handle to the desktop window.
hWndScreen = GetDesktopWindow()
'
' Capture the entire desktop.
'
With Screen
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
.Width \ .TwipsPerPixelX, .Height \ .TwipsPerPixelY)
End With
End Function

Public Function CaptureForm(frm As Form) As Picture
'
' Capture the entire form.

作者: 61.142.212.* 2005-10-28 22:22 　回复此发言

--------------------------------------------------------------------------------

158 回复:把焦点定位到任何已运行的窗口。
'
With frm
Set CaptureForm = CaptureWindow(.hWnd, False, 0, 0, _
.ScaleX(.Width, vbTwips, vbPixels), _
.ScaleY(.Height, vbTwips, vbPixels))
End With
End Function

Public Function CaptureClient(frm As Form) As Picture
'
' Capture the client area of the form.
'
With frm
Set CaptureClient = CaptureWindow(.hWnd, True, 0, 0, _
.ScaleX(.ScaleWidth, .ScaleMode, vbPixels), _
.ScaleY(.ScaleHeight, .ScaleMode, vbPixels))
End With
End Function

Public Function CaptureActiveWindow() As Picture
Dim hWndActive As Long
Dim RectActive As RECT
'
' Get a handle to the active/foreground window.
' Get the dimensions of the window.
'
hWndActive = GetForegroundWindow()
Call GetWindowRect(hWndActive, RectActive)
'
' Capture the active window.
'
With RectActive
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _
.Right - .Left, .Bottom - .Top)
End With
End Function

Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintPictureToFitPage
' - Prints a Picture object as big as possible.
'
' Prn
' - Destination Printer object
'
' Pic
' - Source Picture object
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim PicRatio As Double
Dim PrnWidth As Double
Dim PrnHeight As Double
Dim PrnRatio As Double
Dim PrnPicWidth As Double
Dim PrnPicHeight As Double
Const vbHiMetric As Integer = 8
'
' Determine if picture should be printed in landscape
' or portrait and set the orientation.
'
If Pic.Height >= Pic.Width Then
Prn.Orientation = vbPRORPortrait 'Taller than wide
Else
Prn.Orientation = vbPRORLandscape 'Wider than tall
End If
'
' Calculate device independent Width to Height ratio for picture.
'
PicRatio = Pic.Width / Pic.Height
'
' Calculate the dimentions of the printable area in HiMetric.
'
With Prn
PrnWidth = .ScaleX(.ScaleWidth, .ScaleMode, vbHiMetric)
PrnHeight = .ScaleY(.ScaleHeight, .ScaleMode, vbHiMetric)
End With
'
' Calculate device independent Width to Height ratio for printer.
'
PrnRatio = PrnWidth / PrnHeight
'
' Scale the output to the printable area.
'
If PicRatio >= PrnRatio Then
'
' Scale picture to fit full width of printable area.
'
PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
Else
'
' Scale picture to fit full height of printable area.
'
PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
End If
'
' Print the picture using the PaintPicture method.
'
Call Prn.PaintPicture(Pic, 0, 0, PrnPicWidth, PrnPicHeight)
End Sub

----------------

作者: 61.142.212.* 2005-10-28 22:22 　回复此发言

--------------------------------------------------------------------------------

159 bmp->ico
' Bmp2Ico.frm
'
' By Herman Liu
'
' To show how to make an icon file out of a bitmap, and vice versa.
'
' Sometimes you see a nice bitmap picture, or part of it, and want to make it as an icon.
' You can do what you want now (Just add "file open" and "file save" functions to open the
' bmp/ico file and save the ico/bmp file respectively. That is, for example, instead of
' using the existing image in Picture1, load your own. When it is converted into an icon in
' Picture2, save it to a file name you want. Of course, in this case, you may want to fix
' the size of the image first).
'
' Notes: If you have a copy of my "IconEdit", and you want to give yourself a challenge, you
' can incorporate this code into it. This will be fairly easy. (Basically, you only need to
' add a few menu items, as almost all the APIs here are already there, so are all major
' procedures). In "IconEdit" I have left out many functions, since I don't want to blur the
' essentials. For example, if I open up just the Region function, there would be
' implications on Flip/Rotate/Invert and I have to allow region dragging and so on.)
'
Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function CreateIconIndirect Lib "user32" (icoinfo As ICONINFO) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lppictDesc As _
pictDesc, riid As Guid, ByVal fown As Long, ipic As IPicture) As Long

Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, _
icoinfo As ICONINFO) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
ByVal crColor As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long

Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type

Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Const PICTYPE_BITMAP = 1
Const PICTYPE_ICON = 3
Dim iGuid As Guid
Dim hdcMono
Dim bmpMono
Dim bmpMonoTemp
Const stdW = 32
Const stdH = 32
Dim mresult

作者: 61.142.212.* 2005-10-28 22:25 　回复此发言

--------------------------------------------------------------------------------

160 bmp->ico
Private Sub Form_Load()
' Create monochrome hDC and bitmap
hdcMono = CreateCompatibleDC(hdc)
bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
With iGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
End Sub

Private Sub command1_Click()
On Error Resume Next
Dim mtransp As Long
' Let us select a background color here (just a matter of choice)
picImage.BackColor = Picture1.BackColor
' Area having the following color is to be transparent
mtransp = Picture1.Point(0, 0)
' Create transparent part
CreateTransparent Picture1, picImage, mtransp
' Create a mask
CreateMask_viaMemoryDC picImage, picMask
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcAnd)
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcInvert)
BuildIcon Picture2
SavePicture Picture2.Picture, App.Path & "/Frombmp.ico"
End Sub

Private Sub command2_Click()
On Error Resume Next
Dim i, j
Dim p, q

Picture4.Picture = Picture3.Image

'--------------------------------------------------------
'NB This following is only a matter of variation, not a must.

' Let us select the form's color as background color here
' and replace the existing one with it.
'--------------------------------------------------------
p = Picture4.Point(0, 0)
q = Me.BackColor
' Paint the desired color as if backgound
For i = 0 To stdW
For j = 0 To stdH
If Picture4.Point(i, j) = p Then
Picture4.PSet (i, j), q
End If
Next j
Next i

SavePicture Picture4.Picture, App.Path & "/Fromico.bmp"
End Sub

' To let you see it again and again.
Private Sub Command3_Click()
Picture2.Picture = LoadPicture()
End Sub

Private Sub Command4_Click()
Picture4.Picture = LoadPicture()
End Sub

Private Function CreateMask_viaMemoryDC(Pic1 As PictureBox, Pic2 As PictureBox) As Boolean
On Error GoTo errHandler
CreateMask_viaMemoryDC = False

Dim dx As Long, dy As Long
Dim hdcMono2 As Long, bmpMono2 As Long, bmpMonoTemp2 As Long

dx = Pic1.ScaleWidth
dy = Pic1.ScaleHeight

' Create memory device context (0 is screen, as we want the new
' DC compatible with the screen).
hdcMono2 = CreateCompatibleDC(0)
If hdcMono2 = 0 Then
GoTo errHandler
End If
' Create monochrome bitmap, of a wanted size
bmpMono2 = CreateCompatibleBitmap(hdcMono2, dx, dy)
' Get a monohrome bitmap by default after putting in the
' above created bitmap into the DC.
bmpMonoTemp2 = SelectObject(hdcMono2, bmpMono2)
' Copy bitmap of Pic1 to memory DC to create mono mask of the color bitmap.
mresult = BitBlt(hdcMono2, 0, 0, dx, dy, Pic1.hdc, 0, 0, vbSrcCopy)
' Copy mono memory mask to a picture box, as wanted in this case
mresult = BitBlt(Pic2.hdc, 0, 0, dx, dy, hdcMono2, 0, 0, vbSrcCopy)

' Clean up
Call SelectObject(hdcMono2, bmpMonoTemp2)
Call DeleteDC(hdcMono2)
Call DeleteObject(bmpMono2)

CreateMask_viaMemoryDC = True
Exit Function
errHandler:
MsgBox "MakeMask_viaMemoryDC"

作者: 61.142.212.* 2005-10-28 22:25 　回复此发言

--------------------------------------------------------------------------------

161 bmp->ico
End Function

Private Sub ExtractIconComposite(inPic As PictureBox)
On Error Resume Next
Dim ipic As IPicture
Dim icoinfo As ICONINFO
Dim pDesc As pictDesc
Dim hDCWork
Dim hBMOldWork
Dim hNewBM
Dim hBMOldMono

GetIconInfo inPic.Picture, icoinfo
hDCWork = CreateCompatibleDC(0)
hNewBM = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)

hBMOldWork = SelectObject(hDCWork, hNewBM)
hBMOldMono = SelectObject(hdcMono, icoinfo.hBMMask)
BitBlt hDCWork, 0, 0, stdW, stdH, hdcMono, 0, 0, vbSrcCopy
SelectObject hdcMono, hBMOldMono
SelectObject hDCWork, hBMOldWork
With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_BITMAP
.hImage = hNewBM
End With
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picMask = ipic
Set ipic = Nothing

pDesc.hImage = icoinfo.hBMColor
' Third parameter set to 1 (true) to let picture be destroyed automatically
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picImage = ipic

DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
Set hBMOldMono = Nothing
End Sub

Private Sub BuildIcon(inPic As PictureBox)
On Error Resume Next
Dim hOldMonoBM
Dim hDCWork
Dim hBMOldWork
Dim hBMWork
Dim ipic As IPicture
Dim pDesc As pictDesc
Dim icoinfo As ICONINFO

BitBlt hdcMono, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcCopy
SelectObject hdcMono, bmpMonoTemp
hDCWork = CreateCompatibleDC(0)

With inPic
hBMWork = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)
End With

hBMOldWork = SelectObject(hDCWork, hBMWork)
BitBlt hDCWork, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcCopy
SelectObject hDCWork, hBMOldWork

With icoinfo
.fIcon = 1
.xHotspot = 16 ' Doesn't matter here
.yHotspot = 16
.hBMMask = bmpMono
.hBMColor = hBMWork
End With

With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_ICON
.hImage = CreateIconIndirect(icoinfo)
End With

OleCreatePictureIndirect pDesc, iGuid, 1, ipic

inPic.Picture = LoadPicture()
inPic = ipic
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
End Sub

Sub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _
inTrasparentColor As Long)
On Error Resume Next
Dim mMaskDC As Long
Dim mMaskBmp As Long
Dim mTempMaskBMP As Long
Dim mMonoBMP As Long
Dim mMonoDC As Long
Dim mTempMonoBMP As Long
Dim mSrcHDC As Long, mDestHDC As Long
Dim w As Long, h As Long

w = inpicSrc.ScaleWidth
h = inpicSrc.ScaleHeight

mSrcHDC = inpicSrc.hdc
mDestHDC = inpicDest.hdc

' Set back color of source pic and dest pic to the desired transparent color
mresult = SetBkColor&(mSrcHDC, inTrasparentColor)
mresult = SetBkColor&(mDestHDC, inTrasparentColor)

' Create a mask DC compatible with dest image
mMaskDC = CreateCompatibleDC(mDestHDC)
' and a bitmap of its size
mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
' Move that bitmap into mMaskDC
mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)

' Meanwhile create another DC for mono bitmap
mMonoDC = CreateCompatibleDC(mDestHDC)
' and its bitmap, a mono one (by setting nPlanes and nbitcount
' both to 1)
mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)

' Copy source image to mMonoDC
mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)

' Copy mMonoDC into mMaskDC
mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)

'We don't need mMonoBMP any longer
mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
mresult = DeleteObject(mMonoBMP)
mresult = DeleteDC(mMonoDC)

'Now copy source image to dest image with XOR
mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)

'Copy the mMaskDC to dest image with AND
mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)

'Copy source image to dest image with XOR
BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
'Picture is there to stay
inpicDest.Picture = inpicDest.Image

' We don't need these
mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
mresult = DeleteObject(mMaskBmp)
mresult = DeleteDC(mMaskDC)
End Sub

' Last clear up
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SelectObject bmpMono, bmpMonoTemp
DeleteObject bmpMono
DeleteDC hdcMono
End Sub

162 从资源文件中读取各种格式图片。
Option Explicit
'
' Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
' Demonstrates how to load GIFs and JPGs from file and resource, as well
' as all other supported graphics formats (bmp, dib, wmf,.emf, ico, cur).
'
' Is based loosely on the C code from the following:
' "Q218972 - SAMPLE: How To Load and Display Graphics Files w/LOADPIC.EXE"
' http://support.microsoft.com/support/kb/articles/Q218/9/72.ASP
'

Private Sub Form_Load()
Picture1.TabStop = False
Option1(0) = True
End Sub

Private Sub Command1_Click()
Set Picture1 = PictureFromFile(hwnd)
End Sub

Private Sub Option1_Click(Index As Integer)
Select Case Index
Case 0: Set Picture1 = PictureFromBits(LoadResData("Beany", "bmp"))
Case 1: Set Picture1 = PictureFromBits(LoadResData("Busy_l", "cur"))
Case 2: Set Picture1 = PictureFromBits(LoadResData("Cartman", "jpg"))
Case 3: Set Picture1 = PictureFromBits(LoadResData("ccrpAbout", "gif"))
Case 4: Set Picture1 = PictureFromBits(LoadResData("Desktop", "ico"))
Case 5: Set Picture1 = PictureFromBits(LoadResData("Moneybag", "wmf"))
End Select
End Sub
--------
Option Explicit
'
' Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
Public Enum CBoolean ' enum members are Long data types
CFalse = 0
CTrue = 1
End Enum

Public Const S_OK = 0 ' indicates successful HRESULT

'WINOLEAPI CreateStreamOnHGlobal(
' HGLOBAL hGlobal, // Memory handle for the stream object
' BOOL fDeleteOnRelease, // Whether to free memory when the object is released
' LPSTREAM * ppstm // Indirect pointer to the new stream object
');
Declare Function CreateStreamOnHGlobal Lib "ole32" _
(ByVal hGlobal As Long, _
ByVal fDeleteOnRelease As CBoolean, _
ppstm As Any) As Long

'STDAPI OleLoadPicture(
' IStream * pStream, // Pointer to the stream that contains picture's data
' LONG lSize, // Number of bytes read from the stream
' BOOL fRunmode, // The opposite of the initial value of the picture's property
' REFIID riid, // Reference to the identifier of the interface describing the type
' // of interface pointer to return
' VOID ppvObj // Indirect pointer to the object, not AddRef'd!!
');
Declare Function OleLoadPicture Lib "olepro32" _
(pStream As Any, _
ByVal lSize As Long, _
ByVal fRunmode As CBoolean, _
riid As GUID, _
ppvObj As Any) As Long

Public Type GUID ' 16 bytes (128 bits)
dwData1 As Long ' 4 bytes
wData2 As Integer ' 2 bytes
wData3 As Integer ' 2 bytes
abData4(7) As Byte ' 8 bytes, zero based
End Type

Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long

Public Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

Public Const GMEM_MOVEABLE = &H2
Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

作者: 61.142.212.* 2005-10-28 22:27 　回复此发言

--------------------------------------------------------------------------------

163 从资源文件中读取各种格式图片。

' ====================================================================

Public Const MAX_PATH = 260

Public Type OPENFILENAME ' ofn
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

' OPENFILENAME Flags
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_FILEMUSTEXIST = &H1000

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'

Public Function PictureFromFile(hwnd As Long, Optional sFile As String = "") As StdPicture
Dim ofn As OPENFILENAME
Dim ff As Integer
Dim abFile() As Byte

' If a file's path is not specified show the dialog.
If (Len(sFile) = 0) Then
With ofn
.lStructSize = Len(ofn)
.hWndOwner = hwnd
.lpstrFilter = "All Picture Files" & vbNullChar & "*.bmp;*.dib;*.gif;*.jpg;*.wmf;*.emf;*.ico;*.cur" & vbNullChar & _
"Bitmaps (*.bmp;*.dib)" & vbNullChar & "*.bmp;*.dib" & vbNullChar & _
"GIF Images (*.gif)" & vbNullChar & "*.gif" & vbNullChar & _
"JPEG Images (*.jpg)" & vbNullChar & "*.jpg" & vbNullChar & _
"Metafiles (*.wmf;*.emf)" & vbNullChar & "*.wmf;*.emf" & vbNullChar & _
"Icons (*.ico;*.cur)" & vbNullChar & "*.ico;*.cur" & vbNullChar & _
"All Files (*.*)" & vbNullChar & "*.*" & vbNullChar & vbNullChar
.lpstrFile = String$(MAX_PATH, 0)
.nMaxFile = MAX_PATH
.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
End With

If GetOpenFileName(ofn) Then
sFile = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, vbNullChar) - 1)
End If
End If

' If we have a file path, load it into a byte array and try to make
' a picture out of it...
If Len(sFile) Then
ff = FreeFile
Open sFile For Binary As ff
ReDim abFile(LOF(ff) - 1)
Get #ff, , abFile
Close ff

Set PictureFromFile = PictureFromBits(abFile)
End If

End Function

Public Function PictureFromBits(abPic() As Byte) As IPicture ' not a StdPicture!!
Dim nLow As Long
Dim cbMem As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture As GUID
Dim istm As stdole.IUnknown ' IStream
Dim ipic As IPicture

' Get the size of the picture's bits
On Error GoTo Out
nLow = LBound(abPic)
On Error GoTo 0
cbMem = (UBound(abPic) - nLow) + 1

' Allocate a global memory object
hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
If hMem Then

' Lock the memory object and get a pointer to it.
lpMem = GlobalLock(hMem)
If lpMem Then

' Copy the picture bits to the memory pointer and unlock the handle.
MoveMemory ByVal lpMem, abPic(nLow), cbMem
Call GlobalUnlock(hMem)

' Create an ISteam from the pictures bits (we can explicitly free hMem
' below, but we'll have the call do it...)
If (CreateStreamOnHGlobal(hMem, CTrue, istm) = S_OK) Then
If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then

' Create an IPicture from the IStream (the docs say the call does not
' AddRef its last param, but it looks like the reference counts are correct..)
Call OleLoadPicture(ByVal ObjPtr(istm), cbMem, CFalse, IID_IPicture, PictureFromBits)

End If ' CLSIDFromString
End If ' CreateStreamOnHGlobal
End If ' lpMem

' Call GlobalFree(hMem)
End If ' hMem

Out:
End Function

164 全屏的下雪场景制作
Dim Snow(1000, 2), Amounty As Integer

Private Sub Form_Load()
Form1.Show
DoEvents
Randomize: Amounty = 325
For J = 1 To Amounty
Snow(J, 0) = Int(Rnd * Form1.Width)
Snow(J, 1) = Int(Rnd * Form1.Height)
Snow(J, 2) = 10 + (Rnd * 20)
Next J

Do While Not (DoEvents = 0)
For LS = 1 To 10
For I = 1 To Amounty
OldX = Snow(I, 0): OldY = Snow(I, 1): Snow(I, 1) = Snow(I, 1) + Snow(I, 2)
If Snow(I, 1) > Form1.Height Then Snow(I, 1) = 0: Snow(I, 2) = 5 + (Rnd * 30): Snow(I, 0) = Int(Rnd * Form1.Width): OldX = 0: OldY = 0
Coloury = 8 * (Snow(I, 2) - 10): Coloury = 60 + Coloury: PSet (OldX, OldY), QBColor(0): PSet (Snow(I, 0), Snow(I, 1)), RGB(Coloury, Coloury, Coloury)
Next I
Next LS
Label1.Refresh
Loop
End
End Sub

Private Sub Timer1_Timer()

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
End
End Sub

作者: 61.142.212.* 2005-10-28 22:30 　回复此发言

--------------------------------------------------------------------------------

165 雨滴特效显示图片
'需求一个PictureBox( Named picture2),一个Command按键)
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Const SRCCOPY = &HCC0020
Private Picture1 As New StdPicture

Private Sub Command1_Click()
Dim i As Long
Dim j As Long
Dim height5 As Long, width5 As Long
Dim hMemDc As Long

'stdPicture物件的度量单位是Himetric所以要转换成Pixel
height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
If height5 > Picture2.ScaleHeight Then
height5 = Picture2.ScaleHeight
End If
width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
If width5 > Picture2.ScaleWidth Then
width5 = Picture2.ScaleWidth
End If
'Create Memory DC
hMemDc = CreateCompatibleDC(Picture2.hdc)
'将Picture1的BitMap图指定给hMemDc
Call SelectObject(hMemDc, Picture1.Handle)
For i = height5 To 1 Step -1
Call BitBlt(Picture2.hdc, 0, i, width5, 1, _
hMemDc, 0, i, SRCCOPY)
For j = i - 1 To 1 Step -1
Call BitBlt(Picture2.hdc, 0, j, width5, 1, _
hMemDc, 0, i, SRCCOPY)
Next j
Next
Call DeleteDC(hMemDc)
End Sub

Private Sub Form_Load()
Dim i As Long
Picture2.ScaleMode = 3 '设定成Pixel的度量单位
'设定待Display的图
Set Picture1 = LoadPicture("benz-sl.jpg")
End Sub

166 一个像“南极星”的自动隐藏工具栏。(推荐)
Option Explicit

Dim BarData As APPBARDATA

Dim bAutoHide As Boolean
Dim bAnimate As Boolean
Private Sub Form_Load()

Dim lResult As Long

Move 0, 0, 0, 0
Screen.MousePointer = vbDefault

bAutoHide = True
bAnimate = True

BarData.cbSize = Len(BarData)
BarData.hwnd = hwnd
BarData.uCallbackMessage = WM_MOUSEMOVE
lResult = SHAppBarMessage(ABM_NEW, BarData)
lResult = SetRect(BarData.rc, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
BarData.uEdge = ABE_TOP
lResult = SHAppBarMessage(ABM_QUERYPOS, BarData)
If bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 2 'tbrToolBar.Bands("ToolBar").Height + 6
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
BarData.lParam = True
lResult = SHAppBarMessage(ABM_SETAUTOHIDEBAR, BarData)
If lResult = 0 Then
bAutoHide = False
Else
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top - 42, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
End If
End If
If Not bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 42
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

Static bRecieved As Boolean
Dim lResult As Long
Dim newRC As RECT
Dim lMessage As Long

lMessage = x / Screen.TwipsPerPixelX

If bRecieved = False Then
bRecieved = True
Select Case lMessage
Case WM_ACTIVATE
lResult = SHAppBarMessage(ABM_ACTIVATE, BarData)
Case WM_WINDOWPOSCHANGED
lResult = SHAppBarMessage(ABM_WINDOWPOSCHANGED, BarData)
Case ABN_STATECHANGE
lResult = SetRect(BarData.rc, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
BarData.uEdge = ABE_TOP
lResult = SHAppBarMessage(ABM_QUERYPOS, BarData)
If bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 2
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
BarData.lParam = True
lResult = SHAppBarMessage(ABM_SETAUTOHIDEBAR, BarData)
If lResult = 0 Then
bAutoHide = False
Else
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top - 42, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
End If
End If
If Not bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 42
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
End If
Case ABN_FULLSCREENAPP
Beep
End Select
bRecieved = False
End If
End Sub

Private Sub Form_Resize()
picFrame.Move 0, 0, Width, Height
End Sub

Private Sub Form_Unload(Cancel As Integer)
If BarData.hwnd <> 0 Then SHAppBarMessage ABM_REMOVE, BarData
End Sub

Private Sub picFrame_DblClick()
Unload Me
End Sub

Private Sub picFrame_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim lResult As Long
Dim iCounter As Integer

167 一个像“南极星”的自动隐藏工具栏。(推荐)
If Top < 0 Then
If bAnimate Then
For iCounter = -36 To -1
BarData.rc.Top = iCounter
lResult = SetWindowPos(BarData.hwnd, 0&, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
Next
End If
BarData.rc.Top = 0
lResult = SetWindowPos(BarData.hwnd, HWND_TOPMOST, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_SHOWWINDOW)
tmrHide.Enabled = True
End If
End Sub

Private Sub tmrHide_Timer()
Dim lResult As Long
Dim lpPoint As POINTAPI
Dim iCounter As Integer
lResult = GetCursorPos(lpPoint)
If lpPoint.x < Left \ Screen.TwipsPerPixelX Or lpPoint.x > (Left + Width) \ Screen.TwipsPerPixelX Or lpPoint.y < Top \ Screen.TwipsPerPixelY Or lpPoint.y - 10 > (Top + Height) \ Screen.TwipsPerPixelY Then
If bAnimate Then
For iCounter = -1 To -37 Step -1
BarData.rc.Top = iCounter
lResult = SetWindowPos(BarData.hwnd, 0&, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
Next
End If
BarData.rc.Top = -42
lResult = SetWindowPos(BarData.hwnd, HWND_TOPMOST, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
tmrHide.Enabled = False
End If
End Sub

----------
Option Explicit

Type POINTAPI
x As Long
y As Long
End Type

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long ' message specific
End Type

Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Const WM_MOUSEMOVE = &H200
Public Const WM_ACTIVATE = &H6
Public Const WM_WINDOWPOSCHANGED = &H47

Public Const ABE_BOTTOM = 3
Public Const ABE_LEFT = 0
Public Const ABE_RIGHT = 2
Public Const ABE_TOP = 1
Public Const ABM_ACTIVATE = &H6
Public Const ABM_GETAUTOHIDEBAR = &H7
Public Const ABM_GETSTATE = &H4
Public Const ABM_GETTASKBARPOS = &H5
Public Const ABM_NEW = &H0
Public Const ABM_QUERYPOS = &H2
Public Const ABM_REMOVE = &H1
Public Const ABM_SETAUTOHIDEBAR = &H8
Public Const ABM_SETPOS = &H3
Public Const ABM_WINDOWPOSCHANGED = &H9
Public Const ABN_FULLSCREENAPP = &H2
Public Const ABN_POSCHANGED = &H1
Public Const ABN_STATECHANGE = &H0
Public Const ABN_WINDOWARRANGE = &H3

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1

Public Const HWND_TOP = 0
Public Const HWND_TOPMOST = -1

Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40

168 类似于东方快车工具条的东东的源码。(推荐)
'程序∶池星泽
'获得鼠标指针在屏幕坐标上的位置
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
'获得窗口在屏幕坐标中的位置
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
'判断指定的点是否在指定的巨型内部
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, _
ByVal ptx As Long, ByVal pty As Long) As Long
'准备用来使窗体始终在最前面
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter _
As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags _
As Long) As Long
'用来移动窗体
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Const HWND_TOPMOST = -1

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Is_Move_B As Boolean '判断指针是否位于移动栏(本例中移动栏位于窗体的侧一小地方)
Private Is_Movestar_B As Boolean '判断移动是否开始
Private MyRect As RECT
Private MyPoint As POINTAPI
Private Movex As Long, Movey As Long '记录窗体移动前,窗体左上角与鼠标指针位置间的纵横距离
Private max As Long '窗口变长以后的尺寸(用户可随意改动)

Private Sub Command1_Click(Index As Integer)
Form1.SetFocus
Select Case Index
Case 0
Form1.PopupMenu Form2.mnu_file, vbPopupMenuLeftAlign, 240, max - 30
Case 1
Case 7
Command1(8).Enabled = Not Command1(8).Enabled
If Command1(8).Enabled = True Then
Command1(7).Picture = Image2(1).Picture
Picture1.Width = 4455
Form1.Width = Form1.Width + 1820
Else
Command1(7).Picture = Image2(0).Picture
Picture1.Width = 2645
Form1.Width = Form1.Width - 1820
End If
Line (0, 0)-(Form1.Width, Form1.Height), vbBlue, BF
Get_Windows_Rect
'......
Case 13
End
' .....
End Select
End Sub

Private Sub Form_Load()
Timer1.Interval = 50: Timer2.Interval = 1000
Form1.BackColor = vbBlue
Get_Windows_Rect
End Sub
Sub Get_Windows_Rect()
Dim dl&
max = 390: Form1.Height = max
Form1.Top = 0 '窗体始终放在屏幕顶部
dl& = GetWindowRect(Form1.hwnd, MyRect)
End Sub
Private Sub Form_Paint()
'使窗体始终置于最前面
If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
Form1.Height \ Screen.TwipsPerPixelY, 0
End If
End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Is_Move_B Then
Movex = MyPoint.X - MyRect.Left
Movey = MyPoint.Y - MyRect.Top
Is_Movestar_B = True
End If
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dl&
If Is_Movestar_B Then
dl& = MoveWindow(Form1.hwnd, MyPoint.X - Movex, MyPoint.Y - Movey, _
MyRect.Right - MyRect.Left, MyRect.Bottom, -1)
End If
End Sub

Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Get_Windows_Rect
Is_Movestar_B = False
End Sub

Private Sub Timer1_Timer()
Dim dl&
dl& = GetCursorPos(MyPoint)
If (PtInRect(MyRect, MyPoint.X, MyPoint.Y) And _
Form1.Height = max) Or MyPoint.Y <= 3 Then
' If MyPoint.Y <= 3 Then
Form1.BackColor = vbBlue '窗体背景颜色(用户可随意改动)
Form1.Height = max
'判断鼠标指针是否位于窗体拖动区
If MyPoint.X - MyRect.Left <= 10 Or Is_Movestar_B Then
Screen.MousePointer = 15
Is_Move_B = True
Else
Screen.MousePointer = 0
Is_Move_B = False
End If
Else
If Not Is_Movestar_B Then
Form1.Height = 30 '窗体变小
End If
End If
End Sub

Private Sub Timer2_Timer()
Static color As Integer
If color > 64 Then color = 0
Line (0, 0)-(Form1.Width, Form1.Height), QBColor(color Mod 16), BF
color = color + 15
End Sub
---------

Private Sub mnu_exit_Click()
End
End Sub

169 cool bg
'1.程式名称:炫彩式的启动表单
'2.开发日期:05/28/1999
'3.开发环境:Visual Basic 5.0 中文专业版 + SP3
'4.作者姓名:宋世杰 (小翰,Jaric)
'5.作者信箱:jaric@tacocity.com.tw
'6.作者网址:http://fly.to/jaric 或 http://tacocity.com.tw/jaric
'7.网址名称:Visual Basic 实战网
'8.注意事项:您可以任意散布本程式,但是请勿将以上说明删除,谢谢!
' 如果本程式经过您的修改,可以在下方加入您的个人资讯。
'VB编程乐园 http://www.vbeden.com 整理

Option Explicit

Public Sub splash(obj As Object, r As Byte, g As Byte, b As Byte, fr As Byte, fg As Byte, fb As Byte, no As Long)
Dim i As Long, n1 As Single, n2 As Single
For i = 0 To no
n2 = i / no
n1 = 1 - n2
obj.BackColor = RGB(Int(r * n1 + fr * n2), _
Int(g * n1 + fg * n2), Int(b * n1 + fb * n2))
DoEvents
Next
End Sub

Private Sub Command1_Click()
Call splash(Command1, 255, 0, 0, 255, 255, 0, 50)
End Sub

Private Sub Form_Load()
Dim msg As String
Show
Call splash(Me, 255, 0, 0, 0, 0, 255, 3000)
Call splash(Me, 0, 0, 255, 0, 255, 0, 3000)
msg = "VB实战网 http://fly.to/jaric"
FontSize = 18
FontBold = True
CurrentX = (ScaleWidth - TextWidth(msg)) / 2
CurrentY = (ScaleHeight - TextHeight(msg)) / 2
Print msg
End Sub

170 制作半透明窗体
函数SetLayeredWindowAttributes
　　使用这个函数,可以轻松的实现半透明窗体。按照微软的要求,透明窗体窗体在创建时应使用WS_EX_LAYERED参数(用CreateWindowEx),或者在创建后设置该参数(用SetWindowLong),我选用后者。全部函数、常量声明如下:
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
　　其中hwnd是透明窗体的句柄,crKey为颜色值,bAlpha是透明度,取值范围是[0,255],dwFlags是透明方式,可以取两个值:当取值为LWA_ALPHA时,crKey参数无效,bAlpha参数有效;当取值为LWA_COLORKEY时,bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明--这个功能很有用:我们不必再为建立不规则形状的窗体而调用一大堆区域分析、创建、合并函数了,只需指定透明处的颜色值即可,哈哈哈哈!请看具体代码。
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
代码一:一个半透明窗体
Private Sub Form_Load()
　　Dim rtn As Long
　　rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
　　rtn = rtn Or WS_EX_LAYERED
　　SetWindowLong hwnd, GWL_EXSTYLE, rtn
　　SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA
End Sub

代码二:形状不规则的窗体
Private Sub Form_Load()
　　Dim rtn As Long
　　BorderStyler=0
　　rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
　　rtn = rtn Or WS_EX_LAYERED
　　SetWindowLong hwnd, GWL_EXSTYLE, rtn
　　SetLayeredWindowAttributes hwnd, &HFF0000, 0, LWA_COLORKEY '将扣去窗口中的蓝色
End Sub

171 用VB实现队列播放MP3
　　队列播放MP3就是在文件列表框中一次选择多个MP3文件,让播放程序顺序地播放选择的MP3文件。这是一般的MP3播放器都有的功能,如何在VB程序设计中来实现队列播放MP3的方法呢？
　　首先介绍一下程序中要用到的MediaPlayer控件。它不是VB的标准控件,而是Windows操作系统自带的一个多媒体控件。大家可以在VB开发环境中的单击“工程”→“部件”对话框中,添加MediaPlayer控件。如果要播放MP3,则至少要6.01以上版本的MediaPlayer控件(Windows98中自带的就是这个版本)。如果在部件对话框中找不到MicroSoft Mediaplayer Control,那可能是你没有安装附件所致,这需要在系统中安装相应的附件。
　　正因为使用了Windows自带的控件,所以编出的程序的可移植性很好,更为重要的是,MediaPlayer控件可以播放包括AVI、MOV、WAV、MPG、MP3、M3U、QT等等在内的28种多媒体视频、音频格式的文件,可谓功能强大。
　　这个程序正是利用了MediaPlayer控件可以播放MP3和M3U文件的特性来实现队列播放MP3的。我再说一下M3U文件,这种文件实际上是ASCII码文件,如果你用记事本打开它,就可以发现文件的内容实际上就是多媒体文件的地址列表,能够播放它的程序会顺序播放文件里列出的多媒体文件。
　　下面就是程序的实现步骤:
　　首先建立一个新窗体Form1,添加DriveListBox,DirListBox,FileListBox各一个,Caption属性分别设为Drive1,Dir1和File1,再添加CommandButton以及MediaPlayer控件各一个。然后编写代码如下:
　　Option Explicit
　　Private Sub Command1_Click()
　　Dim num As Integer
　　Dim filename As String
　　Dim filenum As Integer
　　Dim i As Integer
　　num=File1.ListCount
　　filenum=FreeFile
　　Open 〃C:filelist.m3u〃 For Output As #filenum
　　For i=0 To num-1
　　　If File1.Selected(i) Then
　　　　filename=File1.Path+〃〃+File1.List(i)
　　　End If
　　　Print #filenum,filename
　　Next
　　Close #filenum
　　MediaPlayer1.filename=〃C:filelist.m3u〃
　　End Sub
　　Private Sub Dir1_Change()
　　File1.Path=Dir1.Path
　　End Sub
　　Private Sub Drive1_Change()
　　Dir1.Path=Drive1.Drive
　　End Sub
　　程序在Win98系统中调试通过。使用的时候只要选好MP3歌曲所在的文件夹,在文件框中用Shift或Ctrl键选择多个文件即可实现队列播放。
　　怎么样,快去编写自己的WinAmp吧。

172 制作自己的MP3播放器
　MP3的名字在当今这个世界上无疑是非常“亮”的了,而且,和MP3有关的东西也是异常火暴,比如MP3播放器。我们今天自己来设计一个MP3的播放器,当然,是不能随身携带的……

　　我们选择一个名为MP3PLAY的控件,它是由德国Dialog Dedien公司编写设计的,我们可以选用自己熟悉的语言来对它进行控制,这里我们使用VB。

　　首先,看看和这个控件有关的一些东西,比如:控件的属性、事件、方法。

　　属性:(按字母的顺序排列)

　　BitRate,Mp3流的比特率。ChannelMode,用于规定声道的工作模式,若值为0,则为立体声;为1,则是左声道;2为右声道;3为单声道。FrameCount,已打开的MP3流的总帧数。FrameNotifyCount,有这样的功能:播放指定的帧数以后,控件自动向我们的客户程序发出一个消息,而我们的程序就可以通过这个消息来进行一些处理,比如在显示器上进行一些提示等等。HasChecksuns,返回校验信息。IsCopyrighted,返回版权信息。IsOriginal,返回复制信息。Layer,MP3流所采用的编码层次。TotalTime,以毫秒为单位计算的回放的总时间。MsPerFrame,以毫秒为单位计算的每帧占用的时间。SampleFrequency,采样的速率。

　　可写的属性:FrameNotifyCount、ChannelMode。

　　可读的属性:所有的。

　　事件:

　　ActFrame,每播放由FrameNotifyCount指定的帧数以后就产生一次该事件,并在参数中给出了当前播放的帧号。AboutBox(),显示关于对话框。Authorize(Name,Password),在该控件注册以后,会得到一个注册号,否则,这个控件就是未经合法授权的,则只能播放MP3文件的前30秒,在注册以后,该方法会将授权号输入给控件,如果授权号与用户名合法,则控件返回0,否则返回5。Close(),关闭MP3文件。GetVolumeLeft()、GetVolumeRight(),返回左右声道的音量的大小,值的范围是0至65536。GetVolumeLeftP()、GetVolumeRightP(),以百分比的形式返回左右声道的音量的大小。Open(InputFile,OutputFile),打开InputFile指定的MP3文件,以WAV的形式写入OutputFile指定的WAV 文件,如果OutputFile为空的话,则MP3解码将直接从声卡播放出来。Play(),开始播放已打开的MP3文件。Pause(),暂停播放,再次调用时恢复。SetVolume()、SetVolumeP(),设置系统播放时的音量。SetErrorMode(Errmode),设置错误报告模式,Errmode为0时表示在各个方法调用结束直接返回错误代码,为1时表示采用标准的OLE异常处理方式。stop(),停止播放。Seek(Frame),跳到指定的帧数。

　　好了,下来看看原代码吧:

　　Private Sub Command1_Click()

　　Text1.Visible = False

　　a = Mp3Play1.Open(〃c:love.mp3〃, 〃〃)

　　Mp3Play1.Play

　　End Sub

　　Private Sub Command2_Click()

　　Mp3Play1.Close

　　End

　　End Sub

　　在这里,有两个命令按钮,一个名为“播放”,另一个名为“结束”,代码如上。另外,这个程序仅仅是一个例子,还有许多需要改进的地方,诸如界面、功能等等许多东西,这里就不多说了。相信这个例程和上面对控件的介绍已经可以实现许多功能强大的播放器了,是不是？

作者: 61.142.212.* 2005-10-28 22:50 　回复此发言

--------------------------------------------------------------------------------

173 制作TopMost窗口
制作TopMost窗口很简单,只需一个API函数就可以实现。
下面的例子就实现了这个功能。
>>步骤1----建立新工程,在窗体上放置一个CommandButton按钮。
>>步骤2----编写如下代码:

Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Declare Function SetWindowPos Lib \"user32\" ( _
ByVal hwnd As Long,ByVal hWndInsertAfter As Long, _
ByVal X As Long,ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long

Private Sub Command1_Click()
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE _
Or SWP_NOSIZE
End Sub

>>步骤3----编译运行,点击Command1,看看是不是始终位于最上层。
要去掉TopMost属性,只要将参数HWND_TOPMOST换成HWND_NOTOPMOST,
当然,得说明常量:HWND_NOTOPMOST = -2

174 利用VB控件操作目录和文件夹
利用VB控件操作目录和文件夹【字体:大中小】
作者:[Gdibn] 来源:[互动网络] 浏览:[ 113 ] 评论:[0]

第 1 页

　　(一) 察看和显示目录下的文件和文件夹

　　对于这个实现,其实很简单。首先想到的就是VB中给我们提供的现成的控件。主要有这么两类:

　　一类是驱动器列表框(DriveListBox)、目录列表框(DirListBox)和文件列表框(FileListBox)三个控件组合而成的自定义对话框;

　　另一类是windows提供的标准对话框。

　　他们在工具箱中的位置和图标如下所示:

　　1、驱动器列表框是一个下拉式的列表框,他和一般下拉式的列表框的不同仅在于功能上的不同,它提供了一个驱动器的列表。当单击右边的箭头时,则弹出计算机中的所有驱动器的下拉列表。默认状态下,在驱动器列表中显示的是当前驱动器,我们可以输入或从下拉列表中选择有效的驱动器标示符。

　　下面是它的主要属性,事件和方法.

　　属性Drive本属性用于返回或设置运行时选择的驱动器.默认值为当前驱动器
　　改变Drive属性会触发Change事件.
　　示例: Drive1.Drive = “c:”
　　设置C盘为当前驱动器.
　　事件Change当选择一个新驱动器或通过代码改变了Drive属性时触发该事件

　　下面是示例代码:

　　Private Sub Drive1_Change()
　　Dir1.Path = Drive1.Drive
　　‘当选择一个新驱动器时,将驱动器列表中选中的当前驱动器,赋给目录列表的路径.
　　End Sub

　　2、目录列表框

　　目录列表框用于显示当前驱动器的目录结构,目录列表框从最高层目录开始,显示当前驱动器的目录结构,并按层次关系缩进跟目录下的所有子目录。下面是它的主要属性,方法和事件:

　　属性Path本属性用于返回或设置运行时选择的路径,默认路径为当前路径.改变Dri属性会触发Change事件.

　　示例: Dri1.Path = Drive1.Drive

　　设置在驱动器列表框中选中的驱动器盘符为目录列表的当前路径.
　　ListIndex本属性用来返回或设置控件中当前被选择的项目索引号.目录列表框中的每一个目录都可以通过ListIndex属性来标识.由Path属性所设置的当前目录的ListIndex属性值总是-1,而它上面的目录的ListIndex属性值为-2,再上面的为-3,以此类推;而它所包含的子目录恰恰相反,紧挨着的第一个子目录的ListIndex属性值为0,往下一次加一.
　　ListCount本属性返回当前目录下的所有子目录书.ListCount的值比最大的ListIndex的值大1.
　　事件Change当选择一个新目录或通过代码改变了Path属性时触发该事件

　　下面是示例代码:

　　Private Sub Dir1_Change()

　　'将文件列表框的路径值,设置为目录列表框所选中的路径值

　　File1.Path = Dir1.Path

　　End Sub

　　3、文件列表框

　　文件列表框用来显示当前目录中的部分或者全部文件.文件列表框的大部分属性和一般的列表框相同,都具有大小,位置,字体,颜色等以及List,ListCount,ListIndex等属性.下面是主要的属性:

　　属性Path本属性用于返回或设置运行时选择的路径以显示其下的文件,默认路径为当前路径.改变Dri属性会触发PathChange事件.

　　示例: File1.Path= Dri1.Path

　　设置在目录列表框中选中的路径为文件列表的当前路径.
　　Pattern本属性用来确定程序运行时,列表框中显示那些类型的文件.除了使用”*” ”?”等通配符外,在参数中还可以使用分号”;”来分割多种文件类型.例如:”*.ext;*.bat”
　　FileName本属性返回或设置所选文件的路径和文件名.可以从本属性值中返回当前列表中选择的文件名.路径可用Path属性单独检索.在功能上,本属性值与ListIndex等价.如果没有文件被选中,FileName属性将返回0长度的字符串.改变甭属性值可能会产生一个或多个如下事件:PathChange(如果改变路径),PatternChange(如果改变模式),DblClick(如果指定存在的文件)

175 利用VB控件操作目录和文件夹
　　事件Click当选择一个新的文件时触发该事件

　　下面是示例代码:

　　Private Sub File1_Click()

　　Picture1.Picture = LoadPicture(Dir1.Path & " " & File1.FileName)

　　‘在图片框中显示选定的图形文件.

　　End Sub

　　4、标准对话框

　　CommonDialog控件提供了一组标准的操作对话框,进行诸如打开,和保存文件,设置打印选项,以及选择颜色和字体等操作.通过运行windows帮助引擎还能显示帮助.

　　CommonDialog控件在visual basic和Microsoft Windows动态链接库commdlg.dll的例程之间提供了一个接口.为了用这个控件创建一个对话框,commdlg.dll必须存在于microsoft Windows的system目录下.然后再visual basic中选择工程/部件,并在显示的部件对话框中选中Microsoft common　Dialog Control 6.0,确定后,在工具栏里就显示了出来.如下图所示:

　　在应用程序中要使用CommonDialog控件,可将其添加到窗体中并设置其属性.控件所显示的对话框有控件的方法确定.在运行时,当相应的方法被调用时,将显示一个对话框或是执行帮助引擎;在设计时,CommonDialog 控件是以图标的形式显示在窗体中的.该图标的大小不能改变.

　　使用指定的方法,CommonDialog控件能够显示下列对话框:

　　方法所显示的对话框
　　ShowOpen显示[打开]对话框
　　ShowSave显示[另存为]对话框
　　ShowColor显示[颜色]对话框
　　ShowFont显示[字体]对话框
　　ShowPrinter显示[打印]或[打印选项]对话框
　　Showhelp显示windows帮助引擎

　　下面是它的主要属性,方法:

　　属性Filer该属性应用于CommonDialog控件中的[打开][另存为]对话框.本属性用来返回或设置在对话框[类型]列表框中显示的过滤器.过滤的作用是确定对话框中文件列表框中显示的文件类型.例如:设置为*.txt时,将显示文本文件.要显示多种类型的文件,可以用管道(|)符号(ASCII124)将他们分开.管道符号前后不能加空格.如:*.rm|*.rmvb
　　Action该属性返回或设置一个表示所显示对话框类型的整数.具体如下.
　　设置数值说明
　　0没有操作
　　1显示[打开]对话框
　　2显示[另存为]对话框
　　3显示[颜色]对话框
　　4显示[字体]对话框
　　5显示[打印]或[打印选项]对话框
　　6运行WINHLP32.EXE
　　FileName本属性应用于CommonDialog控件的[打开][另存为]对话框.

　　本属性返回或设置所选文件的路径和文件名.如果在运行时被创建,FileName属性将返回0长度的字符串,表示当前没有选择文件.在CommonDialog控件里,可以在打开对话框之前设置FileName属性来设定初始文件名.

　　可以从本属性值中返回当前列表中选择的文件名.路径可用Path属性单独检索.在功能上,本属性值与ListIndex等价.如果没有文件被选中,FileName属性将返回0长度的字符串.

　　改变甭属性值可能会产生一个或多个如下事件:PathChange(如果改变路径),PatternChange(如果改变模式),DblClick(如果指定存在的文件)
　　事件Click当选择一个新的文件时触发该事件

　　下面是一个例子:

　　我们在这里要做一个VCD的播放器,下面是界面.

　　下表是其中所用到的控件及其属性设置:

　　对象特性设置值
　　窗体名称Frmvcd
　　BorderStyle1
　　CaptionVCD播放器
　　菜单标题文件
　　名称Mnufile
　　标题打开
　　名称Mnuopen
　　标题播放
　　名称Mnuplay
　　标题退出
　　名称Mnuexit
　　标题选项
　　名称Mnuoption
　　标题连续播放
　　名称Mnurepeat
　　标题静音
　　名称Mnuslient
　　多媒体控件名称Mmcontrol
　　Picture控件名称Picture1
　　通用对话框名称Commondialog1

　　下面是主要程序代码代码:

　　Private Sub mnuopen_Click() ’当点击菜单中的打开时执行

176 利用VB控件操作目录和文件夹

　　'在未选择文件时,文件名为空字符,播放菜单不可用

　　mnuplay.Enabled =False
　　CommonDialog1.FileName = ""

　　'下面语句设置文件过滤方式,可显示扩展名为avi,dat,wav和mid文件

　　CommonDialog1.Filter = "(*.avi)|*.avi|(*.wave)|*.wav|(vcd *.dat)|*.dat|(midi *.mid)|*.mid"

　　'初始化文件过滤方式为*.avi

　　CommonDialog1.FilterIndex = 1

　　'建立打开方式的通用对话框,也可使用commondialog1.showopen

　　CommonDialog1.Action = 1

--------------
'打开一个文件前先关闭前一次被打开的多媒体设备

　　MMControl1.Command = "close"

　　Select CommonDialog1.FilterIndex
　　Case 1 '选择*.avi

　　　'设置多媒体设备类型为avividio
　　　MMControl1.DeviceType = "avividio"
　　　'设置时间格式为帧
　　　MMControl1.TimeFormat = 3
　　　'设置播放的文件为通用对话框中选择的文件
　　　MMControl1.FileName = CommonDialog1.FileName
　　　'打开文件
　　　MMControl1.Command = "open "
　　Case 2 '选择*.wav
　　　'设置多媒体设备类型为waveaudio
　　　MMControl1.DeviceType = "waveaudio"
　　　'设置时间格式为帧
　　　MMControl1.TimeFormat = 3
　　　'设置播放的文件为通用对话框中选择的文件
　　　MMControl1.FileName = CommonDialog1.FileName
　　　'打开文件
　　　MMControl1.Command = "open "
　　Case 3 '选择*.dat
　　　'设置多媒体设备类型为Mpegvidio
　　　MMControl1.DeviceType = "Mpegvidio"
　　　'设置时间格式为帧
　　　MMControl1.TimeFormat = 3
　　　'设置播放的文件为通用对话框中选择的文件
　　　MMControl1.FileName = CommonDialog1.FileName
　　　'打开文件
　　　MMControl1.Command = "open "
　　Case 4 '选择*.mid
　　　'设置多媒体设备类型为waveaudio
　　　MMControl1.DeviceType = "waveaudio"
　　　'设置时间格式为帧
　　　MMControl1.TimeFormat = 3
　　　'设置播放的文件为通用对话框中选择的文件
　　　MMControl1.FileName = CommonDialog1.FileName
　　　'打开文件
　　　MMControl1.Command = "open "
　　End Select
　　'设置hwnddisplay的值,使媒体文件能够在picture控件中播放
　　MMControl1.hWndDisplay = Picture1.hWnd
　　End Sub

　　(二)新建、修改、删除目录

　　以上控件除了通用对话框(CommonDialog)之外一般只能显示当前的目录结构,对于在磁盘上新建、修改、删除目录却基本无能为力。

　　我们先来看看通用对话框对文件夹的新建,修改和删除操作.

　　1、新建目录

　　我们只要在显示出来的通用对话框的空白位置,单击鼠标,选择“新建”即可在指定的路径下创建新的目录,或者点击通用对话框右上角的新建图表(如下图所示),也可以在指定的路径下创建新的目录
　　

　　2、修改文件夹名称

　　可以在显示出来的通用对话框中,用鼠标右键点击选择所要修改的文件夹,再弹出的快捷菜单中,选择重命名,即可修改目录名称。如下图所示:

　　3、删除文件夹

　　同修改文件夹名称一样,我们只要选择删除即可。如上图所示。

　　而且这种方法比RmDir更简便,它还可以删除包含有文件和子文件夹的文件夹。

　　除了以上控件,windows还给我们提供了一个叫做FileSystemObject(简称FSO)对象。FSO对象模型中包括了计算机文件系统所有的对象。见下表。利用这些对象可以更方便的操作文件系统。

　　对象功能
　　Drive允许收集系统的驱动器信息,诸如驱动器的可用空间
　　Folder允许创建、删除或移动文件夹,并向系统查询文件夹的名称、路径等等

作者: 61.142.212.* 2005-10-30 00:05 　回复此发言

--------------------------------------------------------------------------------

177 利用VB控件操作目录和文件夹
　　Files允许创建、删除或移动文件,并向系统查询文件的名称、路径等等
　　FileSysterObject此为主要对象,提供一整套用于创建、删除、搜集相关信息,以及通常的操作驱动器,文件夹,和文件的方法。
　　TextStream允许读写文本文件

　　下面我们一起来看看怎样用FSO对象来显示、新建、修改以及删除目录。

　　FSO对象模型包含在Scripting的类型库中,此类型库存在于Scrrun.dll文件中.使用FSO对象模型,首先要建立一个FileSystemObject对象。有两种方法可以实现。一种是从”工程”菜单中的”引用”对话框选择”Microsoft Scripting Runtime”项,然后在代码窗口中声明一个FileSystemObject类型的变量.语句如下:

　　Dim fso As New FileSystemObject

　　另一种方法是在代码中使用CreatObject方法动态的创建一个FileSystemObject对象.语句如下:

　　Dim fso As Object ‘ 声明对象变量
　　Set fso = CreatObject(“Scripting. FileSystemObject”) ‘创建FSO对象

　　我们具体看看FileSystemObject的主要属性.

　　1、驱动器

　　(1) Drives属性是FileSystemObject对象的唯一属性,它返回Drives集合中所有可用驱动器的只读集合。对于可删除的驱动器,不需要将媒体插入其中,就可以在Drives集合中显示出来。下面是它的主要属性有两个:一个是Count,另一个是Item.Count属性返回Drives集合或Dictionary对象中的条目数.Item属性用来返回或设置Drives集合或Dictionary对象中与指定关键字相关的项目.

　　下面代码说明了如何获得Drives集合,以及如何用For Eacn……Next语句来访问该集合中的每个Drive:

　　Sub ShowDriveList()

　　Dim fs As Object, d, dc, s,n
　　创建文件系统对象
　　Set fs = CreatObject(“Scripting. FileSystemObject”)
　　创建驱动器集合
　　Set dc= fs.Drives
　　'取的驱动器对象
　　For Each d in dc
　　s = s & d.DriveLetter & “-” ‘格式化文本
　　If d.DriverType = Remote Then ‘如果是Remote类型的驱动器
　　　n = d.ShareName ‘取得它的共享名
　　Else
　　　n = d.volumeName ‘否则取得它的卷标
　　End if
　　s= s& n & vbCrLf ‘格式化文本
　　Next
　　MsgBox s ‘显示文本
　　End sub

　　(2) 当然我们也可以用Drive对象.Drive对象提供了对磁盘驱动器或网络共享属性的访问方法.下面是它的主要属性及其解释:

　　Availablespace驱动器已用空间DriveLetter驱动器指定的字母
　　Freespace驱动器剩余空间DriverType驱动器类型
　　TotalSize驱动器全部空间FileSystem驱动器文件系统
　　IsReady驱动器是否已准备Path驱动器根目录
　　SerizlNumber驱动器序列号VolumeName驱动器卷标
　　ShareName驱动器共享名

　　主要的方法就是GetDrive,此方法用来访问一个已有的驱动器,该方法返回一个与指定路径中的驱动器相对应的Drive对象。下面的代码中,我们将说明怎样取得一个指定的驱动器的相关信息:

　　Sub ShowFreeSpace(drvPath) ‘显示指定目录下的驱动器的信息
　　Dim fs As Object, d, s
　　Set fs = CreateObject("Scripting.FileSystemObject") ‘创建文件系统对象
　　Set d = fs.GetDrive(fs.GetDriveName(drvPath)) ‘创建并得到指定取目录下的驱动器
　　s = "Drive" & UCase(drvPath) & "-" ‘格式化文本
　　s = s & d.VolumeName & vbCrLf ‘得到驱动器的卷标
　　s = s & "FreeSpace:" & FormatNumber(d.FreeSpace / 1024, 0)
　　'计算驱动器的剩余磁盘空间
　　s = s & "Kbytes"
　　MsgBox s ‘显示
　　End Sub

　　下面是filesystemobject的其他方法

　　CreateFolder该方法的作用是创建一个文件夹。所要创建的文件夹必须是不存在的,否则出错。
　　CreateTextFile该方法的作用是产生一个指定的文件名,并返回一个TextStream对象,该对象可被用于对指定的文件进行读写。如果overwrite参数为False或未指定,对于一个已存在的文件,将产生错误。
　　DeleteFile该方法的作用是删除一个指定的文件。如果指定的文件不存在,则出错。
　　DeleteFolder该方法的作用是删除一个文件夹及其内容。如果没有发现匹配的文件夹则出错。该方法不能确定文件夹中是否包含内容。
　　DriveExists该方法的作用是用来确定驱动器是否存在。如果指定的驱动器存在,则返回True,否则返回False。但对于可删除介质的驱动器,即使没有介质存在,DriveExists方法也返回True,因此最好使用IsReady属性确定驱动器是否准备就绪。
　　FileExists该方法的作用是判断指定的文件对象是否存在于当前文件夹
　　FolderExists该方法的作用是判断指定的文件夹对象是否存在于当前文件夹

作者: 61.142.212.* 2005-10-30 00:05 　回复此发言

--------------------------------------------------------------------------------

178 回复 177:利用VB控件操作目录和文件夹
GetDrive该方法的作用是返回一个在指定路径中的与某个驱动器相对应的Drive对象。对于网络驱动器,将首先检查该共享是否存在。
　　GerDriveName该方法的作用是返回包括某一指定路径上的驱动器名的字符串。如果驱动器不能确定,则返回一个0长度字符串。该方法只对指定的路径起作用,它并不试图解析路径,也不检查指定路径是否存在。
　　GetExtensionName该方法的作用是返回指定路径中最后一个组成部分的扩展名。
　　GetFile该方法的作用是返回指定路径中与某一文件相关的File对象。一定要保证所指定的文件是实际存在的。否则将产生错误。
　　GetFileName该方法的作用是返回指定路径的最后一个组成部分的文件名。
　　GetFolder该方法的作用是返回指定路径上的与某个文件夹相关的Folder对象.要保证指定的文件夹是实际存在的,否则会出错. 使用Folder对象的第一部就是先用FileSystemObjectd的GetFolder方法得到Folder对象
　　GetParentFolderName该方法的作用是返回一个包含指定路径上的最后一个组成部分的父文件夹的名称。
　　MoveFile该方法的作用是将一个或多个文件从一个地方移动到另一个地方。
　　MoveFolder该方法的作用是移动一个或多个文件夹,如果源路径包含通配符,或目的路径以斜杠()为结束,则表明目的路径为已存在的路径,在此文件夹中移动相匹配的文件夹.否则,认为目的路径是一个要创建的目标文件夹的名字.如果目的路径为一个已存在的文件或目的路径为一个目录,则出错.如果没有任何文件与源路径中的通配符相匹配也出错.
　　OpenTextFile该方法可用来打开一个指定的文件,并返回一个TextStream对象。用于读文件或追加文件。

　　2、文件夹

　　对文件夹的操作,我们可以使用folder对象,它提供了对文件夹所有属性和方法的访问.下表市对其主要属性的解释:

　　DateCreated返回指定文件或文件夹的创建日期和时间
　　DateLastAccessed返回最后一次访问指定文件或文件夹的日期和时间
　　Drive返回指定文件或文件夹所在的驱动器符号
　　Files返回由File对象组成的所有Files集合,这些Files集合包含在指定的文件夹中,包括设置了隐藏和系统文件属性的那些文件夹
　　IsRootFolder如果指定的文件夹是根文件夹,则返回True,否则返回False
　　Name设置或返回指定文件或文件夹的名称
　　ParentFolder返回指定文件或文件夹的父文件夹的Folder对象
　　Path返回指定文件、文件夹或驱动器的路径
　　ShortName返回较早的需要8.3文件命名约定的程序所使用的短文件名
　　ShortPath返回较早的需要8.3文件命名约定的程序所使用的短路径
　　Size对文件来说,本属性返回以字节为单位的文件大小;对文件夹来说,返回以字节为单位包括其中所有文件或子文件夹的大小
　　SubFolders返回包含所有文件夹的一个Folders集合,这些文件夹包含在某个特定文件夹中, 包括设置了隐藏和系统文件属性的那些文件夹
　　Type返回指定文件或文件夹的类型信息.

　　使用Folder对象的第一部就是先用FileSystemObjectd的GetFolder方法得到Folder对象, 该方法的作用是返回指定路径上的与某个文件夹相关的Folder对象.要保证指定的文件夹是实际存在的,否则会出错.

　　让我们来看一看其中的各种属性及其用法吧.

　　(1)Attributes属性可以返回文件或文件夹的属性,或者设置他们的新属性.所设属性可以是以下值中任意一个或多个的逻辑组合.

　　常数值说明
　　Normal0为一般文件,不设置属性
　　ReadOnly1为只读文件,属性为读/写
　　Hidden2为隐藏文件,属性为读/写
　　System 4为系统文件,属性为读/写
　　Volume8为磁盘驱动器卷标,属性为只读
　　Directory16为文件夹或目录,属性为只读
　　Archive32在上次备份后已经改变的文件,属性为读/写
　　Alias64为链接或快捷方式,属性为只读

作者: 61.142.212.* 2005-10-30 00:05 　回复此发言

--------------------------------------------------------------------------------

179 回复 177:利用VB控件操作目录和文件夹
　　Compressed128为压缩文件,属性为只读

　　(2)DateCreated属性返回指定文件或文件夹的创建日期和时间,本属性为只读属性.

　　下面是用法:

　　Sub ShowFolderList( folderspec ) ‘folderspec 为文件夹名称
　　Dim fs , f, f1,fc , s
　　Set fs = CreateObject(“Scripting.FileSystemObject”)
　　Set f = fs.GetFolder(folderspec) ‘得到folderspec文件夹相关的folder对象
　　Set fc = f.SubFolders ‘得到folder对象所包含的文件夹的folder集合
　　For Each fi in fc ‘访问folder集合中的每一个folder
　　s= s & f1.name ‘格式化要显示的文本
　　s= s & vbCrLf
　　Next
　　MsgBox s ‘用对话框显示信息
　　End Sub

　　(3)DateLastModified属性用来返回最后一次修改指定文件或文件夹的日期和时间,本属性为只读.

　　下面代码用一个文件举例说明了DataLastModified属性的用法:

　　Sub ShowFileAccessInfo(filespec)
　　Dim fs,f,s
　　Set fs = CreateObject(“Scripting.FileSystemObject”)
　　Set f = fs.GetFolder(folderspec) ‘得到folderspec文件夹相关的folder对象
　　s= Ucase(filespec) & vbCrLf
　　s= s& “Created:” & f.DateCreate & vbCrLf
　　s= s & “Last Accessed :” & f.DateLastAccessed & vbCrLf
　　s= s & “Last Modifide :” & f.DateLastModified
　　MsgBox s, 0,”File Access Info”
　　End Sub

　　(4)Type属性返回关于某个文件或文件夹类型的信息.例如对于以.TXT结尾的文本文件来说,本属性会返回”Text Document”.下面的代码举例说明了返回某个文件夹类型的Type属性的用法.在这个示例中,试图将Recycle Bin的路径或其他唯一的文件夹提供给过程.

　　Sub ShowFileSize( filespec )
　　Dim fs,f,s
　　Set fs = CreateObject(“Scripting.FileSystemObject”)
　　Set f = fs.GetFolder(folderspec) ‘得到folderspec文件夹相关的folder对象
　　S = Ucase(f.Name) & “is a ” & f.Type ‘格式化文本
　　MsgBox s,o, “File Size Info ” ‘显示信息
　　End Sub

　　主要方法有:

　　(1)Copy方法:

　　该方法的作用是拷贝一个指定的文件或文件夹到指定的目录.该方法和FileSystemObject.CopyFile方法的作用相同

　　(2)CreateTextFile方法:

　　该方法的作用是产生一个指定的文件名,并返回一个TextStream对象,该对象可被用于对指定的文件进行读写.如果overwrite参数为False或未指定,对于一个已存在的文件,将产生错误.

　　(3)Delete方法:

　　该方法的作用是删除一个指定的文件或文件夹.如果指定的文件或文件夹不存在,则发生一个错误.对于一个File或Folder来说,Delete方法的运行的结果和执行FileSystemObject.DeleteFile或FileSystemObject.DeleteFolder的结果是一样的.Delete方法执行时与指定的文件夹中时候有内容无关.

　　(4)Move

　　该方法用来将一个指定的文件夹或文件从一个地方移动到另一个地方,如果只是想移动一个文件或文件夹,则使用Move方法和使用FileSystemObject.MoveFile或FileSystemObject.MoveFolder操作的结果是一样的,但是如果要同时移动多个文件或文件夹,则只能使用后者。

　　讲了这么多,还是让我们来看一下具体的实现方法:

　　1、创建一个文件夹

　　可以使用FileSystemObject对象的CreateFolder方法来实现,但要创建的文件夹必须不存在,否则出错。特别注意,FileSystemObject对象不能创建或删除驱动器。

　　下面的例子可以在应用程序所在目录下创建一个文件夹

　　Sub CreateFolder(folderspec)
　　Dim fs
　　Set fs = CreatObject(“Scripting.FileSystemObject”)
　　fs.CreaterFolder(folderspec )
　　End sub

　　2、删除一个或多个文件夹

　　可以使用FileSystemObject对象的Deletfolder方法,或者folder对象的Delete方法

　　Sub DeleteFolder(folderspec)
　　Dim fs
　　Set fs = CreatObject(“Scripting.FileSystemObject”)
　　fs.DeleteFolder(folderspec & “100”)
　　‘Set f = fs.GetFolder(folderspec) ‘得到folderspec文件夹相关的folder对象
　　‘f.Delete
　　End sub

　　3、移动一个或多个文件夹

　　可以使用FileSystemObject对象的Movefolder方法,或者folder对象的Move方法

　　Sub MoveFolder(folderspec)
　　Dim fs
　　Set fs = CreatObject(“Scripting.FileSystemObject”)

作者: 61.142.212.* 2005-10-30 00:05 　回复此发言

--------------------------------------------------------------------------------

180 VB中控件大小随窗体大小变化
VB中控件大小随窗体大小变化【字体:大中小】
作者:[Gdibn] 来源:[互动网络] 浏览:[ 8 ] 评论:[0]

当前是:全文显示

　　有时窗体变化后,如改变分辨率后控件大小却不能随之改变。手工代码调整实在麻烦,下面的模块实现自动查找窗体上控件并使其改变大小以适应窗体变化。

　　在Form的Resize事件中调用函数Resize_All就能实现控件自动调整大小,如:

　　Private Sub Form_Resize()
　　Dim H, i As Integer
　　On Error Resume Next
　　Resize_ALL Me 'Me是窗体名,Form1,Form2等等都可以

　　End Sub

　　在模块中添加以下代码:

　　Public Type ctrObj
　　Name As String
　　Index As Long
　　Parrent As String
　　Top As Long
　　Left As Long
　　Height As Long
　　Width As Long
　　ScaleHeight As Long
　　ScaleWidth As Long
　　End Type

　　Private FormRecord() As ctrObj
　　Private ControlRecord() As ctrObj
　　Private bRunning As Boolean
　　Private MaxForm As Long
　　Private MaxControl As Long
　　Private Const WM_NCLBUTTONDOWN = &HA1
　　Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
　　Private Declare Function ReleaseCapture Lib "USER32" () As Long

　　Function ActualPos(plLeft As Long) As Long

　　If plLeft < 0 Then
　　ActualPos = plLeft + 75000
　　Else
　　ActualPos = plLeft
　　End If

　　End Function

　　Function FindForm(pfrmIn As Form) As Long

　　Dim i As Long
　　FindForm = -1

　　If MaxForm > 0 Then
　　
　　For i = 0 To (MaxForm - 1)
　　　If FormRecord(i).Name = pfrmIn.Name Then
　　　　FindForm = i
　　　　Exit Function
　　　End If
　　Next i
　　End If

　　End Function

　　Function AddForm(pfrmIn As Form) As Long

　　Dim FormControl As Control
　　Dim i As Long
　　ReDim Preserve FormRecord(MaxForm + 1)

　　FormRecord(MaxForm).Name = pfrmIn.Name
　　FormRecord(MaxForm).Top = pfrmIn.Top
　　FormRecord(MaxForm).Left = pfrmIn.Left
　　FormRecord(MaxForm).Height = pfrmIn.Height
　　FormRecord(MaxForm).Width = pfrmIn.Width
　　FormRecord(MaxForm).ScaleHeight = pfrmIn.ScaleHeight
　　FormRecord(MaxForm).ScaleWidth = pfrmIn.ScaleWidth
　　AddForm = MaxForm
　　MaxForm = MaxForm + 1

　　For Each FormControl In pfrmIn
　　i = FindControl(FormControl, pfrmIn.Name)
　　If i < 0 Then
　　　i = AddControl(FormControl, pfrmIn.Name)
　　End If
　　Next FormControl

　　End Function

　　Function FindControl(inControl As Control, inName As String) As Long

　　Dim i As Long
　　FindControl = -1

　　For i = 0 To (MaxControl - 1)
　　If ControlRecord(i).Parrent = inName Then
　　　If ControlRecord(i).Name = inControl.Name Then
　　　　On Error Resume Next
　　　　If ControlRecord(i).Index = inControl.Index Then
　　　　　FindControl = i
　　　　　Exit Function
　　　　End If
　　　　On Error GoTo 0
　　　End If
　　End If
　　Next i
　　End Function

　　Function AddControl(inControl As Control, inName As String) As Long

181 VB中控件大小随窗体大小变化

　　ReDim Preserve ControlRecord(MaxControl + 1)
　　On Error Resume Next
　　ControlRecord(MaxControl).Name = inControl.Name
　　ControlRecord(MaxControl).Index = inControl.Index
　　ControlRecord(MaxControl).Parrent = inName

　　If TypeOf inControl Is Line Then
　　ControlRecord(MaxControl).Top = inControl.Y1
　　ControlRecord(MaxControl).Left = ActualPos(inControl.X1)
　　ControlRecord(MaxControl).Height = inControl.Y2
　　ControlRecord(MaxControl).Width = ActualPos(inControl.X2)
　　Else
　　ControlRecord(MaxControl).Top = inControl.Top
　　ControlRecord(MaxControl).Left = ActualPos(inControl.Left)
　　ControlRecord(MaxControl).Height = inControl.Height
　　ControlRecord(MaxControl).Width = inControl.Width
　　End If

　　inControl.IntegralHeight = False
　　On Error GoTo 0
　　AddControl = MaxControl
　　MaxControl = MaxControl + 1
　　End Function

　　Function PerWidth(pfrmIn As Form) As Long

　　Dim i As Long
　　i = FindForm(pfrmIn)

　　If i < 0 Then
　　i = AddForm(pfrmIn)
　　End If

　　PerWidth = (pfrmIn.ScaleWidth * 100) \ FormRecord(i).ScaleWidth
　　End Function

　　Function PerHeight(pfrmIn As Form) As Double

　　Dim i As Long
　　i = FindForm(pfrmIn)

　　If i < 0 Then
　　i = AddForm(pfrmIn)
　　End If

　　PerHeight = (pfrmIn.ScaleHeight * 100) \ FormRecord(i).ScaleHeight
　　End Function

　　Public Sub ResizeControl(inControl As Control, pfrmIn As Form)

　　On Error Resume Next
　　Dim i As Long
　　Dim widthfactor As Single, heightfactor As Single
　　Dim minFactor As Single
　　Dim yRatio, xRatio, lTop, lLeft, lWidth, lHeight As Long
　　yRatio = PerHeight(pfrmIn)
　　xRatio = PerWidth(pfrmIn)
　　i = FindControl(inControl, pfrmIn.Name)

　　If inControl.Left < 0 Then
　　lLeft = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
　　Else
　　lLeft = CLng((ControlRecord(i).Left * xRatio) \ 100)
　　End If

　　lTop = CLng((ControlRecord(i).Top * yRatio) \ 100)
　　lWidth = CLng((ControlRecord(i).Width * xRatio) \ 100)
　　lHeight = CLng((ControlRecord(i).Height * yRatio) \ 100)
　　If TypeOf inControl Is Line Then

　　If inControl.X1 < 0 Then
　　　inControl.X1 = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
　　Else
　　　inControl.X1 = CLng((ControlRecord(i).Left * xRatio) \ 100)
　　End If

　　inControl.Y1 = CLng((ControlRecord(i).Top * yRatio) \ 100)
　　If inControl.X2 < 0 Then
　　　inControl.X2 = CLng(((ControlRecord(i).Width * xRatio) \ 100) - 75000)
　　Else
　　　inControl.X2 = CLng((ControlRecord(i).Width * xRatio) \ 100)
　　End If

　　inControl.Y2 = CLng((ControlRecord(i).Height * yRatio) \ 100)
　　Else
　　inControl.Move lLeft, lTop, lWidth, lHeight
　　inControl.Move lLeft, lTop, lWidth
　　inControl.Move lLeft, lTop
　　End If

　　End Sub

　　Public Sub ResizeForm(pfrmIn As Form)

　　Dim FormControl As Control
　　Dim isVisible As Boolean
　　Dim StartX, StartY, MaxX, MaxY As Long

182 VB中控件大小随窗体大小变化
　　Dim bNew As Boolean

　　If Not bRunning Then
　　bRunning = True

　　If FindForm(pfrmIn) < 0 Then
　　　bNew = True
　　Else
　　　bNew = False
　　End If
　　If pfrmIn.Top < 30000 Then
　　　isVisible = pfrmIn.Visible
　　　On Error Resume Next
　　　If Not pfrmIn.MDIChild Then
　　　　On Error GoTo 0
　　　　' ' pfrmIn.Visible = False
　　　Else

　　　　If bNew Then
　　　　　StartY = pfrmIn.Height
　　　　　StartX = pfrmIn.Width
　　　　　On Error Resume Next
　　　　　For Each FormControl In pfrmIn
　　　　　　If FormControl.Left + FormControl.Width + 200 > MaxX Then
　　　　　　　MaxX = FormControl.Left + FormControl.Width + 200
　　　　　　End If

　　　　　　If FormControl.Top + FormControl.Height + 500 > MaxY Then
　　　　　　　MaxY = FormControl.Top + FormControl.Height + 500
　　　　　　End If

　　　　　　If FormControl.X1 + 200 > MaxX Then
　　　　　　　MaxX = FormControl.X1 + 200
　　　　　　End If

　　　　　　If FormControl.Y1 + 500 > MaxY Then
　　　　　　　MaxY = FormControl.Y1 + 500
　　　　　　End If

　　　　　　If FormControl.X2 + 200 > MaxX Then
　　　　　　　MaxX = FormControl.X2 + 200
　　　　　　End If

　　　　　　If FormControl.Y2 + 500 > MaxY Then
　　　　　　　MaxY = FormControl.Y2 + 500
　　　　　　End If

　　　　　Next FormControl

　　　　　On Error GoTo 0
　　　　　pfrmIn.Height = MaxY
　　　　　pfrmIn.Width = MaxX
　　　　End If

　　　　On Error GoTo 0
　　　End If

　　　For Each FormControl In pfrmIn
　　　　ResizeControl FormControl, pfrmIn
　　　Next FormControl

　　　On Error Resume Next

　　　If Not pfrmIn.MDIChild Then
　　　　On Error GoTo 0
　　　　pfrmIn.Visible = isVisible
　　　Else

　　　　If bNew Then
　　　　pfrmIn.Height = StartY
　　　　pfrmIn.Width = StartX

　　　　For Each FormControl In pfrmIn
　　　　　ResizeControl FormControl, pfrmIn
　　　　Next FormControl

　　　End If
　　End If
　　On Error GoTo 0
　　End If
　　bRunning = False
　　End If

　　End Sub

　　Public Sub SaveFormPosition(pfrmIn As Form)

　　Dim i As Long

　　If MaxForm > 0 Then

　　For i = 0 To (MaxForm - 1)

　　　If FormRecord(i).Name = pfrmIn.Name Then

　　　　FormRecord(i).Top = pfrmIn.Top
　　　　FormRecord(i).Left = pfrmIn.Left
　　　　FormRecord(i).Height = pfrmIn.Height
　　　　FormRecord(i).Width = pfrmIn.Width
　　　　Exit Sub
　　　End If
　　Next i

　　AddForm (pfrmIn)
　　End If
　　End Sub

　　Public Sub RestoreFormPosition(pfrmIn As Form)

　　Dim i As Long
　　If MaxForm > 0 Then
　　For i = 0 To (MaxForm - 1)
　　　If FormRecord(i).Name = pfrmIn.Name Then
　　　　If FormRecord(i).Top < 0 Then
　　　　　pfrmIn.WindowState = 2
　　　　ElseIf FormRecord(i).Top < 30000 Then
　　　　　pfrmIn.WindowState = 0
　　　　　pfrmIn.Move FormRecord(i).Left, FormRecord(i).Top, FormRecord(i).Width, FormRecord(i).Height
　　　　Else
　　　　　pfrmIn.WindowState = 1
　　　　End If
　　　　　Exit Sub
　　　End If
　　Next i
　　End If
　　End Sub

　　Public Sub Resize_ALL(Form_Name As Form)

　　Dim OBJ As Object
　　For Each OBJ In Form_Name
　　ResizeControl OBJ, Form_Name
　　Next OBJ
　　End Sub

　　Public Sub DragForm(frm As Form)

　　On Local Error Resume Next
　　Call ReleaseCapture
　　Call SendMessage(frm.hwnd, WM_NCLBUTTONDOWN, 2, 0)

　　End Sub

183 VB中利用API函数实现屏幕颜色数设定
VB中利用API函数实现屏幕颜色数设定【字体:大中小】
作者:[Gdibn] 来源:[互动网络] 浏览:[ 7 ] 评论:[0]

第 1 页

　　原则上,只改这一次,下一次开机会还原,但如果需重开机,才会Update Registry中的设定,并重开机。

　　如果要永久设定其设定值,请将

b = ChangeDisplaySettings(DevM, 0)

　　改成

b = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)

　　注:

　　DevM.dmBitsPerPel 便是设定颜色数,其实应说每个Pixel要多少Bits来显示

　　4 --> 16色
　　8 --> 256色
　　16 --> 65536色以此类推

Option Explicit
Private Declare Function EnumDisplaySettings Lib "user32" Alias _
"EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, _
ByVal iModeNum As Long, lpDevMode As Any) As Long

Private Declare Function ChangeDisplaySettings Lib "user32" Alias _
"ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, _
ByVal dwReserved As Long) As Long

Const EWX_REBOOT = 2 ’ 重开机
Const CCDEVICENAME = 32
Const CCFORMNAME = 32

Const DM_BITSPERPEL = &H40000
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const CDS_UPDATEREGISTRY = 1
Private Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer

dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer

dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private DevM As DEVMODE
Private Sub Command1_Click()
Dim a As Boolean
Dim i As Long
Dim b As Long
Dim ans As Long
a = EnumDisplaySettings(0, 0, DevM) ’Initial Setting
DevM.dmBitsPerPel = 8 ’设定成256色
DevM.dmFields = DM_BITSPERPEL
b = ChangeDisplaySettings(DevM, 0)
If b = DISP_CHANGE_RESTART Then
　ans = MsgBox("要重开机设定才能完成,重开？", vbOKCancel)
　If ans = 1 Then
　　b = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
　　Call ExitWindowsEx(EWX_REBOOT, 0)
　End If
Else
　If b <> DISP_CHANGE_SUCCESSFUL Then
　　Call MsgBox("设定有误", vbCritical)
　End If
End If
End Sub

184 使用Word的“艺术字”工具
Word 97中的“艺术字”工具(WordArt)能创建出各种各样的文字,令人赏心悦目。如果能在VB中使用“艺术字”该有多好啊!由于有了面向对象技术中的代码重用思想,现在就可以轻松地实现这个愿望了。
　　代码重用主要有两种形式,即二进制代码重用与源代码重用。前者是通过创建和使用对象来实现的;后者,顾名思义,是通过继承实现的,后者在C++语言中被广泛使用。由于Visual Basic不支持继承,所以在VB中的代码重用主要是指二进制代码重用,并且VB算得上是二进制代码重用的先驱。它的基本思路是:首先将待重用的代码和数据编译为二进制文件,称为ActiveX服务器部件,然后在客户应用程序里创建部件中类的对象来调用该部件。在VB中最为人们所熟悉的控件就是典型的二进制代码重用的例子,每个控件都是一个ActiveX部件,在向窗体中添加一个控件的同时就创建了该控件类的一个新实例,然后通过调用该控件的属性、方法和事件就重用了该控件中的代码。
　　Word 97本身就是一个庞大的代码部件,也就是说,Word 97中的整个对象库是对外开放的,它允许其他应用程序对其进行编程。换句话说,Word 97中的对象能被其他应用程序所调用。而“艺术字”正是Word 97中的一种对象,因此可以方便地在VB中调用它。
　　要使用“艺术字”,必须先把Word 97的对象库加入到程序中,然后创建一个对象变量来保持对Word应用程序对象的引用,可以用两种方法创建对Word应用程序对象的引用,一种方法是直接声明一个Word应用程序的对象变量,例如:
　　Dim w As New Word.Application
　　这种方法称为前期绑定,它速度较快;另一种方法是声明一个对象变量w,然后把用CreateObject函数创建出的Word应用程序对象赋给w,例如:
　　Dim w As Object
　　Set w=CreateObject("Word.Application")
　这种方法称为后期绑定,它速度较慢。在创建了Word应用程序对象后,就可以以代码的方式像在Word中进行具体操作那样创建新文档,并在文档中加入“艺术字”。在创建好“艺术字”之后,用剪贴板将其传给窗体。在创建Word应用程序对象时,VB会在后台自动打开Word,因此,在程序结束时,应该先关闭Word,其代码如下:
　　w.Quit wdDoNotSaveChanges
　　下面用一个具体的项目实例帮你轻松学习如何在VB中使用Word对象。
　　(1)启动Microsoft Visual Basic 5.0,选择“标准EXE”,创建一个新项目;
　　(2)选择“项目”菜单中的“引用”选项,显示“引用”对话框,选中"Microsoft Word 8.0 Object Library"和"Microsoft Office 8.0 Object Library"两项,单击“确定”按钮(见图1);
　　(3)将下列代码加入到Form1的“通用”|“声明”选项中:
　　Dim w As New Word.Application
　　(4)将下列代码加入到Form1的Load事件中:
　　Private Sub Form_Load()
　　 w.Documents.Add.Select
　　 w.ActiveDocument.Shapes.AddTextEffect(0,"艺术字","隶书",48#,-1,0,183.75,70.5).Select
　End Sub
　　这里显示的字样是隶书的“艺术字”三个字,你可以根据自己的喜好来改变字体(如宋体、楷体等)以及改变字样;
　　(5)将下列代码加入到Form1的Click事件中:
　　Private Sub Form_Click()
　　 w.Selection.ShapeRange.TextEffect.PresetTextEffect = Int(Rnd(1) * 30)
　　 w.Selection.ShapeRange.TextEffect.FontName = "隶书"
　　 w.Selection.Copy
　　 Picture = Clipboard.GetData()
　　End Sub
　(6)将下列代码加入到Form1的Unload事件中:
　　Private Sub Form_Unload(Cancel As Integer)
　　 w.Quit wdDoNotSaveChanges
　　 Set w = Nothing
　　End Sub
　　(7)在窗体上放置一个按钮,其Caption属性为"Exit",并在它的Click事件中处理退出:
　　Private Sub Command1_Click()
　　 End
　　End Sub
　　(8)运行程序后,当鼠标在窗体上单击时,会随机地显示出一种“艺术字”字型(Word中共有30种内建“艺术字”字型),下图分别给出了隶书与宋体两种不同字体的字样为“艺术字”的几种情形。
　　　同样,由这个实例可以举一反三,即我们也可以在VB中使用Excel的图表、PowerPoint的幻灯片,因为Office 97中的产品都是代码部件,这些产品中的对象库都是可以被其他应用程序调用的,所以只要了解这些对象的外部接口(属性、方法和事件),就可以方便地调用这些对象了。

作者: 61.142.212.* 2005-10-30 00:09 　回复此发言

--------------------------------------------------------------------------------

185 浅出浅入美化界面
浅出浅入美化界面
--------------------------------------------------------------------------------
作者:不详　来源于:中国VB网　发布时间:2005-10-29
先在窗体上加一个按钮,两个timer控件,然后在窗体上加入如下代码
Dim rtn As Long
Dim slo As Integer
Private Sub Command1_Click()
Timer1.Enabled = False
slo = 255 '定义透明度为完全显示
rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes Me.hwnd, 0, slo, LWA_ALPHA
Timer2.Enabled = True
End Sub

Private Sub Form_Load()
c = 1
rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE) '获取窗体大小
rtn = rtn Or WS_EX_LAYERED '赋予rtn为 WS_Ex_Layered
SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn '将半透明值赋予给窗体
SetLayeredWindowAttributes Me.hwnd, 0, 0, LWA_ALPHA '赋予窗体半透明
Timer1.Interval = 1
Timer1.Enabled = True '浅出浅入开始
Timer2.Interval = 1
Timer2.Enabled = False
Me.Visible = True '显示窗体,否则会造成窗体显示后才浅出浅入
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
If slo < 255 Then
slo = slo + 25 '这里控制显示速度
rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes Me.hwnd, 0, slo, LWA_ALPHA
'范围:0~255
Else
Timer1.Enabled = False
End If
End Sub

Private Sub Timer2_Timer()

On Error Resume Next
If slo > 0 Then
slo = slo - 25 '这里控制显示速度
rtn = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes Me.hwnd, 0, slo, LWA_ALPHA
Else
Unload Me
End If
End Sub

'在新建立一个模块,加入如下代码:
'声明
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

--------------------------------------------------------------------------------

186 托盘气球提示
托盘气球提示
--------------------------------------------------------------------------------
作者:叶帆　来源于:中国VB网　发布时间:2005-10-29
Option Explicit

'*************************************************************************
'**函数名:cmdDel_Click
'**输入:无
'**输出:无
'**功能描述:删除图标
'**全局变量:
'**调用模块:
'**作者:叶帆
'**日期:2004-10-14 09:34:58
'**修改人:
'**日期:
'**版本:V1.0.0
'*************************************************************************
Private Sub cmdDel_Click()
DelNotifyIcon Me
End Sub

'*************************************************************************
'**函数名:cmdShow_Click
'*************************************************************************
Private Sub cmdShow_Click()
ShowNotifyIcon Me, txtTitle, txtInfo, cmbType.ListIndex
End Sub

'*************************************************************************
'**函数名:Form_Load
'*************************************************************************
Private Sub Form_Load()
cmbType.ListIndex = 1 '信息图标
cmdShow_Click '显示信息
End Sub
'*************************************************************************
'**函数名:Form_Unload
'**输入:Cancel(Integer) -
'**输出:无
'**功能描述:结束
'**全局变量:
'**调用模块:
'**作者:叶帆
'**日期:2004-10-14 09:35:32
'**修改人:
'**日期:
'**版本:V1.0.0
'*************************************************************************
Private Sub Form_Unload(Cancel As Integer)

'删除图标
cmdDel_Click

' 卸载所有窗体
Dim frm As Form
For Each frm In Forms
Unload frm
Next
End Sub

--------------------------------------------------------------------------------
'模块代码

'*************************************************************************
'**模块名:mdlNotifyBase
'**说明:YFsoft 版权所有2004 - 2005(C)
'**创建人:叶帆
'**日期:2004-10-14 09:17:46
'**修改人:
'**日期:
'**描述:显示托盘提示模块
'**版本:V1.0.0
'*************************************************************************
Option Explicit
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_RBUTTONUP = &H205
Private Const WM_USER = &H400
Private Const WM_NOTIFYICON = WM_USER + 1 ' 自定义消息
Private Const WM_LBUTTONDBLCLK = &H203
Private Const GWL_WNDPROC = (-4)
' 关于气球提示的自定义消息, 2000下不产生这些消息
Private Const NIN_BALLOONSHOW = (WM_USER + &H2) ' 当 Balloon Tips 弹出时执行

187 托盘气球提示
Private Const NIN_BALLOONHIDE = (WM_USER + &H3) ' 当 Balloon Tips 消失时执行(如 SysTrayIcon 被删除),
' 但指定的 TimeOut 时间到或鼠标点击 Balloon Tips 后的消失不发送此消息
Private Const NIN_BALLOONTIMEOUT = (WM_USER + &H4) ' 当 Balloon Tips 的 TimeOut 时间到时执行
Private Const NIN_BALLOONUSERCLICK = (WM_USER + &H5) ' 当鼠标点击 Balloon Tips 时执行。
' 注意:在XP下执行时 Balloon Tips 上有个关闭按钮,
' 如果鼠标点在按钮上将接收到 NIN_BALLOONTIMEOUT 消息。

Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Private Type NOTIFYICONDATA
cbSize As Long ' 结构大小(字节)
hwnd As Long ' 处理消息的窗口的句柄
uId As Long ' 唯一的标识符
uFlags As Long ' Flags
uCallBackMessage As Long ' 处理消息的窗口接收的消息
hIcon As Long ' 托盘图标句柄
szTip As String * 128 ' Tooltip 提示文本
dwState As Long ' 托盘图标状态
dwStateMask As Long ' 状态掩码
szInfo As String * 256 ' 气球提示文本
uTimeoutOrVersion As Long ' 气球提示消失时间或版本
' uTimeout - 气球提示消失时间(单位:ms, 10000 -- 30000)
' uVersion - 版本(0 for V4, 3 for V5)
szInfoTitle As String * 64 ' 气球提示标题
dwInfoFlags As Long ' 气球提示图标
End Type
' dwState to NOTIFYICONDATA structure
Private Const NIS_HIDDEN = &H1 ' 隐藏图标
Private Const NIS_SHAREDICON = &H2 ' 共享图标
' dwInfoFlags to NOTIFIICONDATA structure
Private Const NIIF_NONE = &H0 ' 无图标
Private Const NIIF_INFO = &H1 ' "消息"图标
Private Const NIIF_WARNING = &H2 ' "警告"图标
Private Const NIIF_ERROR = &H3 ' "错误"图标
' uFlags to NOTIFYICONDATA structure
Private Const NIF_ICON As Long = &H2
Private Const NIF_INFO As Long = &H10
Private Const NIF_MESSAGE As Long = &H1
Private Const NIF_STATE As Long = &H8
Private Const NIF_TIP As Long = &H4
' dwMessage to Shell_NotifyIcon
Private Const NIM_ADD As Long = &H0
Private Const NIM_DELETE As Long = &H2
Private Const NIM_MODIFY As Long = &H1
Private Const NIM_SETFOCUS As Long = &H3
Private Const lngNIM_SETVERSION As Long = &H4
Private lngPreWndProc As Long

'*************************************************************************
'**函数名:ShowNotifyIcon
'**输入:frm(Form) - 窗体
'** :strTitle(String) - 托盘提示标题
'** :strInfo(String) - 托盘提示信息
'** :Optional lngType(Long = 1) - 托盘提示类型 0 无 1 信息 2 警告 3 错误
'** :Optional lngTime(Long = 10000) - 停留时间
'**输出:无
'**功能描述:显示托盘图标提示信息
'**全局变量:
'**调用模块:
'**作者:叶帆
'**日期:2004-10-14 09:23:14
'**修改人:
'**日期:
'**版本:V1.0.0
'*************************************************************************
Public Sub ShowNotifyIcon(frm As Form, strTitle As String, strInfo As String, Optional lngType As Long = 1, Optional lngTime As Long = 10000)

' 向托盘区添加图标
Dim IconData As NOTIFYICONDATA

strTitle = strTitle & vbNullChar
strInfo = strInfo & vbNullChar

With IconData
.cbSize = Len(IconData)
.hwnd = frm.hwnd
.uId = 0
.uFlags = NIF_TIP Or NIF_ICON Or NIF_MESSAGE Or NIF_INFO Or NIF_STATE

188 托盘气球提示
.uCallBackMessage = WM_NOTIFYICON
.szTip = strTitle
.hIcon = frm.Icon.Handle
.dwState = 0
.dwStateMask = 0
.szInfo = strInfo
.szInfoTitle = strTitle
.dwInfoFlags = lngType
.uTimeoutOrVersion = lngTime
End With

If lngPreWndProc = 0 Then '没有初始化
Shell_NotifyIcon NIM_ADD, IconData
lngPreWndProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf WindowProc)
Else '已初始化
Shell_NotifyIcon NIM_MODIFY, IconData
End If

End Sub

'*************************************************************************
'**函数名:DelNotifyIcon
'**输入:frm(Form) - 窗体
'**输出:无
'**功能描述:删除托盘图标
'**全局变量:
'**调用模块:
'**作者:叶帆
'**日期:2004-10-14 09:33:01
'**修改人:
'**日期:
'**版本:V1.0.0
'*************************************************************************
Public Sub DelNotifyIcon(frm As Form)
If lngPreWndProc <> 0 Then
' 删除托盘区图标
Dim IconData As NOTIFYICONDATA
With IconData
.cbSize = Len(IconData)
.hwnd = frm.hwnd
.uId = 0
.uFlags = NIF_TIP Or NIF_ICON Or NIF_MESSAGE
.uCallBackMessage = WM_NOTIFYICON
.szTip = ""
.hIcon = frm.Icon.Handle
End With
Shell_NotifyIcon NIM_DELETE, IconData
SetWindowLong frm.hwnd, GWL_WNDPROC, lngPreWndProc
lngPreWndProc = 0
End If
End Sub
'*************************************************************************
'**函数名:WindowProc
'**输入:ByVal hwnd(Long) -
'** :ByVal msg(Long) -
'** :ByVal wParam(Long) -
'** :ByVal lParam(Long) -
'**输出:(Long) -
'**功能描述:frmTest 窗口入口函数
'**全局变量:
'**调用模块:
'**作者:叶帆
'**日期:2004-10-14 09:19:06
'**修改人:
'**日期:
'**版本:V1.0.0
'*************************************************************************
Function WindowProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' 拦截 WM_NOTIFYICON 消息
If msg = WM_NOTIFYICON Then
Select Case lParam
Case WM_RBUTTONUP
' 右键单击图标是运行这里的代码, 可以在这里添加弹出右键菜单的代码
Case WM_LBUTTONDBLCLK
' 左键单击显示窗体
frmTest.Show
Case NIN_BALLOONSHOW
Debug.Print "显示气球提示"
Case NIN_BALLOONHIDE
Debug.Print "删除托盘图标"
Case NIN_BALLOONTIMEOUT
Debug.Print "气球提示消失"
Case NIN_BALLOONUSERCLICK
Debug.Print "单击气球提示"
End Select
End If
WindowProc = CallWindowProc(lngPreWndProc, hwnd, msg, wParam, lParam)
End Function

189 灰色按钮克星--按钮激活
灰色按钮克星--按钮激活
--------------------------------------------------------------------------------
作者:bbsxwk 　来源于:中国VB网　发布时间:2005-10-29
现在有很多软件未注册时有些按钮是灰色的,不能按下,通过以下小程序即可激活他.
03年的时候我用delphi写过一个http://www.onlinedown.net/soft/23743.htm 当时跌跌撞撞,在大富翁里请教了好多高手才完成.现在学了VB了,于是自己从新用VB写了一个,从中也了解一下VB里一些API的用法.
我们要用到的API有:
GetForegroundWindow,EnumChildWindows,IsWindowEnabled,EnableWindow
下面我一一写出这几个API的意义
GetForegroundWindow:获得前台窗口的句柄。这里的“前台窗口”是指前台应用程序的活动窗口
EnumChildWindows:为指定的父窗口枚举子窗口
IsWindowEnabled:判断窗口是否处于活动状态(在vb里使用:针对vb窗体和控件,请用enabled属性)
EnableWindow:在指定的窗口里允许或禁止所有鼠标及键盘输入(在vb里使用:在vb窗体和控件中使用Enabled属性)
好了有这几个API就足够写出这个小程序了.
程序很简单,首先新建一个工程,在窗体里放下2个Label,1个Button,1个Timer
控件设置:把Label1的Caption设为"句柄:",Label2的Name设为LabHwnd,Caption为空．Command1的Caption为"激活",Timer1的Enable设为False,Interval设为1000.
以下为代码部分:
'Module
Option Explicit
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long

Public Function GetButtonHandle(ByVal hwnd As Long, lParam As Long) As Long '返回每个控件的句柄
GetButtonHandle = True '设定为True才会再找下一个
If IsWindowEnabled(hwnd) = False Then '判断是否有enable的东东
Call EnableWindow(hwnd, True) '调用激活
End If
End Function
'Form
Option Explicit
Dim ButtonHandle As Long
Private Sub Command1_Click()
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
LabHwnd.Caption = GetForegroundWindow '显示句柄
ButtonHandle = GetForegroundWindow
ButtonHandle = EnumChildWindows(ButtonHandle, AddressOf GetButtonHandle, ButtonHandle) '这个API我不是很懂第3个参数的意义,因为如果声明的时候把 ByVal lParam As Long 改为 ByVal lParam As Form 这样这个参数改为Form1就可以了,好像没有什么意义,希望知道的能告诉我实际含义.
End Sub

190 奇形怪状的窗体
奇形怪状的窗体
--------------------------------------------------------------------------------
作者:不详　来源于:中国VB网　发布时间:2005-9-10
普通的窗体都是方方的,使用API函数可以做出一些奇怪的形状。比如,窗体是圆角矩形,在中间挖一个椭圆形的洞。

先要理解一个重要的概念:区域。区域是描述设备场景中某一块的GDI对象,每个区域都有一个句柄。一个区域可以是矩形,也可以是复杂的多边形,甚至是几个区域组织在一起。窗体默认的区域就是我们看到的矩形,当然它并非一定要用这个默认的区域

现在开始,首先在窗体上做一个圆角矩形区域,这是窗体的大致轮廓。在圆角矩形里再确定一个椭圆形的区域,然后把这两个区域组织成一个区域,并设置窗体的区域为这个组织出来的区域。

CreateRoundRectRgn函数用于创建一个圆角矩形区域;CreateEllipticRgn用于创建一个椭圆区域;CombineRgn函数用于将两个区域组合为一个新区域;SetWindowRgn函数允许您改变窗口的区域。使用其他的函数还可以做出其他更奇怪的窗体。

源代码如下:

Option Explicit

' API 函数声明

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'常数声明

Private Const RGN_DIFF = 4
' 目标区域被设置为两个区域不相交的部分

'模块级变量声明

Private OutRgn As Long
' 外边的圆角矩形区域
Private InRgn As Long
' 里边的椭圆区域
Private MyRgn As Long
' 圆角区域剪切掉椭圆区域后的区域,也是窗体最终的形状

Private Sub Form_Click()
If OutRgn <> 0 And InRgn <> 0 And MyRgn <> 0 Then Exit Sub
Dim w As Long, h As Long
w = ScaleX(Form1.Width, vbTwips, vbPixels)
h = ScaleY(Form1.Height, vbTwips, vbPixels)
MyRgn = CreateRectRgn(0, 0, 0, 0)
OutRgn = CreateRoundRectRgn(30, 30, w - 30, h - 30, 100, 100)
InRgn = CreateEllipticRgn(100, 100, w - 100, h - 100)
Call CombineRgn(MyRgn, OutRgn, InRgn, RGN_DIFF)
Call SetWindowRgn(Form1.hWnd, MyRgn, True)
Form1.BackColor = QBColor(4)
End Sub

Private Sub Form_DblClick()
Unload Form1
End Sub

Private Sub Form_Load()
OutRgn = 0
InRgn = 0
MyRgn = 0
Form1.Width = 7800
Form1.Height = 6000
End Sub

Private Sub Form_Unload(Cancel As Integer)
If MyRgn <> 0 Then DeleteObject MyRgn
If OutRgn <> 0 Then DeleteObject OutRgn
If InRgn <> 0 Then DeleteObject InRgn
End Sub

这个程序运行后,在窗体上单击,窗体就会变形,双击窗体程序结束。要注意的是,在卸载窗体时,用DeleteObject函数删除已定义的区域。

191 VB游戏写作技巧(1)秀图篇
VB游戏写作技巧(1)秀图篇
--------------------------------------------------------------------------------
作者:不详　来源于:中国VB网　发布时间:2004-10-20
一开始,我想先从游戏的图形先讲起好了,毕竟游戏最重要的就是画面,一个没有漂亮图形的游戏,我连碰都不想去碰。那该怎么处理游戏的图形呢？VB提供了一个非常好用的控制项--PictureBox,有了这个控制项我们才能轻松的在程式中秀出图形,现在就来看看PictureBox有那些特性可以让我们在游戏中使用。

Picture 属性:只要将这个属性填入正常的图形档名,VB就会自动帮我们载入图形档。

Visible 属性:这个属性可以让图形消失或让图形出现在画面上。
用法:Form1.Picture1.Visible = False '消失
Form1.Picture1.Visible = True '出现

Left 属性:表示图形的位置的X座标。
Top 属性:表示图形的位置的Y座标。
用法:改变这两个属性就可以改变图形的位置。

ScaleMode 属性:设定PictureBox所使用的座标单位,一般都设为"3-像素"

知道了PictureBox的特性後,要怎么样把它应用到游戏中呢？举个例子好了,我现在要做一个打砖块的游戏,需要用到那些图片呢？砖块、球、击球的板子,一共有三张图,所以我们就使用三个PictureBox,将图片载入到PictureBox里面,如下面所示:

Picture1 砖块的图片
Picture2 球的图片
Picture3 板子的图片

接著我就可以写,当我按下方向键的右键时,Picture3的left属性+1,按下左键则-1,这样一来不就可以控制板子的左右移动了吗？球也是一样,只要每隔一段时间更改一次Picture2的left和top 属性,就可以做出球移动的效果了。

或许有人会觉得奇怪,一张图就要用到一个PictureBox,小游戏的图不多还没关系,如果是RPG的话不就要动用到几千个甚至几万个PictureBox？岂不是麻烦死了？所以如果图片很多的时候,我通常都是把图全部都放在同一个图形档里面,这样就只要用到一个PictureBox了,要用图片时从里面把它抓出来就好了,不过要怎么抓呢？我建议使用函数BitBlt()来做图形的搬移。

使用BitBlt函数前要先宣告:

Declare Sub BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long)

hDestDC 目的地的DC
x 目的地的座标x
y 目的地的座标y
nWidth 来源图片的宽度
nHight 来源图片的高度
hSrcDC 来源图片的DC
xsrc 来源图片的座标x
ysrc 来源图片的座标y
dwrop 运算方法:&HCC0020 PUT
&H8800C6 AND
&HEE0086 OR
&H660046 XOR

现在有两个PictureBox
Picture1 AutoRedRaw 属性设为Ture
ScaleMode 属性设为"3-像素"
Picture2 AutoRedRaw 属性设为Ture
ScaleMode 属性设为"3-像素"

若想将Picture2里(10,10)-(100,100)区域内的图形拷贝到Picture1的(0,0)
可以这样写:

BitBlt Picture1.hdc,0,0,90,90,Picture2.hdc,10,10,&HCC0020

这样子平常写游戏时就只要设两个PictureBox,一个专门用来显示,另一个则用来放图形资料,需要时再用BitBlt函数覆制过去就好了,不是很方便吗？

192 VB游戏写作技巧(2)网络篇
VB游戏写作技巧(2)网络篇
--------------------------------------------------------------------------------
作者:不详　来源于:中国VB网　发布时间:2004-10-20
这一次写的是如何用VB来写网路程式的方法,你可不要以为这是什么深奥的程式,其实只要一个Winsock 控制项就可以了,现在就来介绍一下Winsock 的用法:

步骤一:首先要先把控制项给叫出来,你只要按下Ctrl+T後选取Winsock Control 5.0若是用VB6 的就选Winsock Control 6.0,这样就可以使用Winsock元件。

步骤二:再来我们必须先确定程式是作Server端还是Client端的,要先设定一些属性:

Server写法:winsock1.localPort = 5400 (数字可以随便设)
winsock1.Listen (等待连线)

Client写法:winsock1.RemoteHost = "对方IP"
winsock1.RemoteProt = 5400 (必须要和Server端相同)
winsock1.LocalProt = 0
winsock1.Connect (连线)

连线之前Client端要先知道Server端的IP,接著等到Server端等待连线时,Client端就可以呼叫Connect方法,双方连线成功後就可以传输资料。

步骤三:当Client连线的时候Server端会引发ConnectionRequest事件,Server的程式要这样子写:

Private Sub Winsock1_ConnectionRequest(ByVal requestID As long)
winsock1.Close
winsock1.Accept requestID
End Sub

步骤四:这样一来就可以传送资料了,传送和接受资料的方法如下:

传送资料:mydata = "你好吗?"
winsock1.sendData mydata
这样就会把mydata给传到对方那里。

接受资料:当有资料送到的时候会引发DataArrival事件。

Privata Sub Winsock1_DtatArrival(ByVal bytesTotal As long)
Dim mydata As String
winsock1.GetData mydata　会把送到的资料给mydata
End Sub
Winsock 控制项就那么简单,只要会这些就可以写网路游戏了。

193 用Winsock实现点对点通信
Winsock控件是VB5.0的新增功能,它解决了以往应用VB编程时网络中应用程序之间无法实现点对点通信的难题。Winsock使用的TCP协议和UDP协议允许建立并保持一个到远程计算机上的连接,且可以在连接结束之前实时地进行数据交换。用户仅通过设置属性并借助事件处理就能够轻而易举地连接到一个远程的计算机上,而且只用两个命令就可以实现数据交换。

　　使用TCP协议时,如果需要创建一个客户应用程序,就必须识别服务器的名称或IP地址。应用程序的通信端口随时都将仔细监测对方发出的消息,这是系统进行可靠连接的保证。一旦连接发生,任何一方都可以通过SendData发送和接收数据,并借助GetData把自己的数据分离出来。

　　传送数据时,需要先设定客户机的LocalPort属性,服务器则只需要把RemoteHost属性设定为客户机以太网的地址,并设定与客户机LocalPort属性相同的端口地址,借助SendData方法开始发送消息。客户机则在GetData事件中通过DataArrival事件分离出发送的信息。

　　一个Winsock控件可以让本地计算机连接到远程的计算机上,同时使用UDP或TCP协议,两个协议都能创建客户机和服务器应用。

　　使用Winsock控件时,通信的双方需要选定相同的协议。TCP协议适用于传送大容量、需要安全性保证的数据文件;而UDP协议适用于需要分别与很多下属通信,或者建立的连接比较多且为时变的情况,特别是在数据量很小的时候。设定时可以使用Winsock1.Protocol = sckTCPProtocol方法,首先要找到你的计算机的名称,并把它添入Winsock的LocalHost属性中。

　　创建一个应用程序时,首先要确定你建立的是客户方应用还是服务器服务,只有建立的服务器应用开始工作,并进入监听状态时,客户应用程序才开始建立连接,进入正常的通信状态。笔者建立了一个应用程序,它的功能是当客户方的鼠标移动时,服务器应用程序上能够实时显示该鼠标的位置。下面是建立服务器应用的方法:

1.创建一个新的标准EXE文件;
2.加入一个Winsock控件;
3.加入如下代码:
Private Sub Form_Load()
tcpServer.LocalPort = 1001
tcpServer.Localhost = 〃servser〃
tcpServer.remotePort = 1002
tcpServer.Localhost = 〃klint〃
tcpServer.Listen
End Sub
′连接检查
Private Sub tcpServer_ConnectionRequest _
(ByVal requestID As Long)
If tcpServer.State <> sckClosed Then _
tcpServer.Close
tcpServer.Accept requestID
End Sub
′发送数据
Private Sub frmserver_monsemove(x,y)
tcpServer.SendData 〃x〃& str(x)
tcpServer.SendData 〃y〃& str(y)
End Sub
建立客户应用的方法为:
1.创建一个新的标准EXE文件;
2.加入一个Winsock控件;
3.加入两个TEXT框—— txt_x和 txt_y;
4.加入如下代码:
Private Sub Form_Load()
tcpServer.LocalPort = 1002
tcpServer.Localhost = 〃klint〃
tcpServer.remotePort = 1001
tcpServer.Localhost = 〃servser〃
tcpServer.Listen
End Sub
′连接检查
Private Sub tcpklint_ConnectionRequest _
(ByVal requestID As Long)
If tcpklint.State <> sckClosed Then _
tcpklint.Close
tcpklint.Accept requestID
End Sub
Private Sub tcpClient_DataArrival _
(ByVal bytesTotal As Long)
Dim strData As String
tcpklint.GetData strData
if left(strData,1)=〃X〃then
txt_x.Text = strData
else
txt_y.Text = strData
endif
End Sub

　　以上例程实现的是一个非常简单的点对点通信,在此基础上略加改造,可以形成功能复杂的实时计算机网络A-A交互通信系统,用于控制、图形仿真等。

　　使用UDP协议建立对等通信和通过TCP建立客户/服务器通信的方法略有不同,它不需要建立客户和服务器,而是建立对等通信。此过程通过以下几步实现:

1.设定Winsock的RemoteHost 属性为一个通信的计算机名称;
2.设定 RemotePort 为一个接口号;
3.调用Winsock的Bind 事件绑定本地的接口号。具体设定方法为:
Private Sub Form_Load()
With Winsock1
.RemoteHost= 〃PeerB〃
.RemotePort = 1001 ′远程连接号
.Bind 1002
′绑定的本地号
End With
End Sub

　　程序的其它部分与TCP方法类似,即通过SendData 和GetData 方法发送或提取数据。UDP和TCP协议在使用中各有特点,如果灵活使用,可以得到很好的效果。令人欣慰的是,VB5.0中Winsock给我们提供了一种简便的数据传送方法,使我们得以轻松地实现网络点对点通信。

194 可以动态注册和反注册ActiveX控件
可以动态注册和反注册ActiveX控件
--------------------------------------------------------------------------------
作者:不详　来源于:中国VB网　发布时间:2005-10-29
'这是一个可以动态注册和反注册ActiveX控件的程序,任何一个
'ActtiveX控件都有DllRegisterServer和
'DllUnregisterServer两个输出函数
'点击Command2反注册Threed32.Ocx控件,在VB菜单中选
'Project|components或按Ctrl+T,在控件列表框中可以看
'到已经没有Threed32.Ocx了。再运行程序,点击Command1
'重新注册控件。

'作者 PerFect
'E-Mail zp-perfect@163.com

Private Declare Function RegComCtl32 Lib "Threed32.OCX" _
Alias "DllRegisterServer" () As Long
Private Declare Function UnRegComCtl32 Lib "Threed32.OCX" _
Alias "DllUnregisterServer" () As Long
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" (ByVal dwFlags As Long, _
lpSource As Any, ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, ByVal lpBuffer _
As String, ByVal nSize As Long, Arguments As _
Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Const ERROR_SUCCESS = &H0

Private Sub Command1_Click()
Dim astr As String

'注册Threed32.Ocx
If RegComCtl32 = ERROR_SUCCESS Then
MsgBox "注册成功"
Else
astr = String$(256, 20)
FormatMessage FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, 0&, GetLastError, _
0&, astr, Len(astr), ByVal 0
MsgBox astr
End If
End Sub

Private Sub Command2_Click()
Dim astr As String

'反注册Threed32.Ocx
If UnRegComCtl32 = ERROR_SUCCESS Then
MsgBox "反注册成功"
Else
astr = String$(256, 20)
FormatMessage FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, 0&, GetLastError, _
0&, astr, Len(astr), ByVal 0
MsgBox astr
End If
End Sub

195 用vb.net读取INI配置文件
用vb.net读取INI配置文件的方法,使用API
因为对XML前不了解,所以对XML方式来做配置文件我都不能很好的实现
但为了应行,只有先使用INI的文来记录了
也就沿用了VB6里的INI文读取方法

'声明INI配置文件读写API函数
Private Declare Function GetPrivateProfileString()Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Int32, ByVal lpFileName As String) As Int32
Private Declare Function WritePrivateProfileString()Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Int32
'定义读取配置文件函数
Public Function GetINI()Function GetINI(ByVal Section As String, ByVal AppName As String, ByVal lpDefault As String, ByVal FileName As String) As String
Dim Str As String = LSet(Str, 256)
GetPrivateProfileString(Section, AppName, lpDefault, Str, Len(Str), FileName)
Return Microsoft.VisualBasic.Left(Str, InStr(Str, Chr(0)) - 1)
End Function
'定义写入配置文件函数
Public Function WriteINI()Function WriteINI(ByVal Section As String, ByVal AppName As String, ByVal lpDefault As String, ByVal FileName As String) As Long
WriteINI = WritePrivateProfileString(Section, AppName, lpDefault, FileName)
End Function
Private Sub Form1_Load()Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim path As String
path = Application.StartupPath + "\server.ini"
TextBox1.Text = GetINI("Server", "IP", "", path)
TextBox2.Text = GetINI("Server", "port", "", path)
End Sub

Private Sub Button1_Click()Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Try
Dim path As String
path = Application.StartupPath + "\server.ini"
WriteINI("Server", "IP", TextBox1.Text, path)
WriteINI("Server", "port", TextBox2.Text, path)
MsgBox("配置设置已经成功!!!!")
Me.Close()
Catch ex As Exception
MsgBox("错误!!!!")
End Try

End Sub

196 INI的替代品--XML配置文件读取与保存
INI的替代品--XML配置文件读取与保存
.Net中并没有提供INI读写的托管类库,如果使用INI必须调用非托管API。有一个NINI提供了托管类库。
今天我们来实现XML配置文件读取与保存。
1.集合类
首先我们需要一个集合类来保存键和键值。它必须同时提供键名和索引两种查找键值的办法。所以我们采用 System.Collections.Specialized.NameValueCollection 类。需要注意的是这个类的键值只能是String。

Imports System.Xml
Public Class SettingClass Setting
Inherits System.Collections.Specialized.NameValueCollection
End Class

2.XML配置文件格式
配置文件格式我们采用app.config的格式

<?xml version="1.0" encoding="utf-8"?>
<configuration>
<appSettings>
<add key="key1" value="value1"/>
</appSettings>
</configuration>

3.XML配置文件的读取

Sub LoadSetting()Sub LoadSetting(ByVal FilePath As String)
Dim Reader As XmlTextReader
Try
Reader = New XmlTextReader(FilePath)
Reader.WhitespaceHandling = WhitespaceHandling.None '忽略所用Whitespace
Me.Clear() '清除现有所有数据
Catch ex As Exception
MsgBox("找不到XML文件" + ex.ToString)
Exit Sub
End Try
Try
While Reader.Read
If Reader.Name = "add" Then
Dim Key, Value As String
Reader.MoveToAttribute("key")
Key = Reader.Value
Reader.MoveToAttribute("value")
Value = Reader.Value
Me.Set(Key, Value)
Reader.MoveToElement()
End If
End While
Catch ex As Exception
MsgBox("XML文件格式错误" + ex.ToString)
Exit Sub
Finally
Reader.Close()
End Try
End Sub

3.XML配置文件的写入

Sub SaveSetting()Sub SaveSetting(ByVal FilePath As String)
Dim Writer As New XmlTextWriter(FilePath, System.Text.Encoding.Default)
Writer.WriteStartDocument() '写入XML头
Dim I As Integer
Writer.WriteStartElement("configuration")
Writer.WriteStartElement("appSettings")
For I = 0 To Me.Count - 1
Writer.WriteStartElement("add")
Writer.WriteStartAttribute("key", String.Empty)
Writer.WriteRaw(Me.GetKey(I))
Writer.WriteEndAttribute()
Writer.WriteStartAttribute("value", String.Empty)
Writer.WriteRaw(Me.Item(I))
Writer.WriteEndAttribute()
Writer.WriteEndElement()
Next
Writer.WriteEndElement()
Writer.WriteEndElement()
Writer.Flush()
Writer.Close()
End Sub