注意:访问本站需要Cookie和JavaScript支持!请设置您的浏览器! 打开购物车 查看留言付款方式联系我们
初中电子 单片机教材一 单片机教材二
搜索上次看见的商品或文章:
商品名、介绍 文章名、内容
首页 电子入门 学单片机 免费资源 下载中心 商品列表 象棋在线 在线绘图 加盟五一 加入收藏 设为首页
本站推荐:
VB编程精彩杂文收集
文章长度[699777] 加入时间[2007/3/23] 更新时间[2024/5/10 9:42:12] 级别[0] [评论] [收藏]


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

 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_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

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, _
 
 
 
 作者: 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

 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)
 
 
 
 作者: 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

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
 
 
 
 作者: 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:

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
 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 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)

' 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

 
 
 作者: 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

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

' 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

 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)
 hMenuPo 
 
 
 作者: 61.142.212.*  2005-10-28 21:34   回复此发言   
 
--------------------------------------------------------------------------------
 
79 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐) 
 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)
 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

' 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)
 
 
 
 作者: 61.142.212.*  2005-10-28 21:34   回复此发言   
 
--------------------------------------------------------------------------------
 
81 回复:漂亮的VB程序窗体,打破传统的Windows窗体。(强力推荐) 
 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
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:
 
 
 
 作者: 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_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
 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
 
 
 
 作者: 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

'//////////////////
'// 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

 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

' 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 SHSpecialFolderIDs, _
 pidl As Long) As Long

' 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 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

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

Next

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/jarichttp://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 
 
 

1、 本站不保证以上观点正确,就算是本站原创作品,本站也不保证内容正确。
2、如果您拥有本文版权,并且不想在本站转载,请书面通知本站立即删除并且向您公开道歉! 以上可能是本站收集或者转载的文章,本站可能没有文章中的元件或产品,如果您需要类似的商品请 点这里查看商品列表!
本站协议 | 版权信息 |  关于我们 |  本站地图 |  营业执照 |  发票说明 |  付款方式 |  联系方式
深圳市宝安区西乡五壹电子商行——粤ICP备16073394号-1;地址:深圳西乡河西四坊183号;邮编:518102
E-mail:51dz$163.com($改为@);Tel:(0755)27947428
工作时间:9:30-12:00和13:30-17:30和18:30-20:30,无人接听时可以再打手机13537585389