五一電子閱讀：《貴賓專區》—《VB編程精彩雜文收集》

1 VB編程
〖ALT鍵+鼠標右鍵開始╱暫停;鼠標左鍵控制速度〗
啟動自動滾屏功能
VB編程的七個優良習慣
作者:木子
1、"&"替換"+" 2、變量命名大小寫,語句錯落有秩,源代碼維護方面
3、請養成以下的“對象命名約定”良好習慣 4、在簡單的選擇條件情況下,使用IIf()函數
5、盡量使用Debug.Print進行調試 6、在重復對某一對象的屬性進行修改時,盡量使用With....End With
7、MsgBox中盡量使用消息圖標,這樣程序比較有規范 8、在可能的情況下使用枚舉

1、"&"替換"+"
在很多人的編程語言中,用“+”來連接字符串,這樣容易導致歧義。良好的習慣是用“&”來連接字符串.

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

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

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

2、變量命名大小寫,語句錯落有秩,源代碼維護方面

下面大家比較一下以下兩段代碼:

讀懂難度很大的代碼:

Dim SNAME As String
Dim NTURN As Integer

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

容易讀懂的代碼:

Dim sName As String
Dim nTurn As Integer

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

[返回索引]

3、請養成以下的“對象命名約定”良好習慣

推薦使用的控件前綴

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

作者: 61.142.212.* 2005-10-28 20:38 　回復此發言

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

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

--------------------------------------------------------------------------------
推薦使用的數據訪問對象 (DAO) 的前綴
用下列前綴來指示數據訪問對象
數據庫對象前綴例子
Container con conReports
Database db dbAccounts
DBEngine dbe dbeJet
Document doc docSalesReport
Field fld fldAddress
Group grp grpFinance
Index ix idxAge
Parameter prm prmJobCode
QueryDef qry qrySalesByRegion
Recordset rec recForecast
Relation rel relEmployeeDept
TableDef tbd tbdCustomers
User usr usrNew
Workspace wsp wspMine

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

應用程序頻繁使用許多菜單控件,對于這些控件具備一組唯一的命名約定很實用。除了最前面 "mnu" 標記以外,菜單控件的前綴應該被擴展:對每一級嵌套增加一個附加前綴,將最終的菜單的標題放在名稱字符串的最后。下表列出了一些例子。

推薦使用的菜單前綴
菜單標題序列菜單處理器名稱
File Open mnuFileOpen
File Send Email mnuFileSendEmail
File Send Fax mnuFileSendFax
Format Character mnuFormatCharacter
Help Contents mnuHelpContents

當使用這種命名約定時,一個特定的菜單組的所有成員一個接一個地列在 Visual Basic 的“屬性”窗口中。而且,菜單控件的名字清楚地表示出它們所屬的菜單項。

為其它控件選擇前綴

對于上面沒有列出的控件,應該用唯一的由兩個或三個字符組成的前綴使它們標準化,以保持一致性。只有當需要澄清時,才使用多于三個字符的前綴。

常量和變量命名約定
除了對象之外,常量和變量也需要良好格式的命名約定。本節列出了 Visual Basic 支持的常量和變量的推薦約定。并且討論標識數據類型和范圍的問題。

變量應該總是被定義在盡可能小的范圍內。全局 (Public) 變量可以導致極其復雜的狀態機構,并且使一個應用程序的邏輯非常難于理解。全局變量也使代碼的重用和維護更加困難。

Visual Basic 中的變量可以有下列范圍

范圍聲明位置可見位置
過程級過程,子過程或函數過程中的 ‘Private’ 在聲明它的過程中
模塊級窗體或代碼模塊(.frm、.bas )的聲明部分中的 ‘Private’ 窗體或代碼模塊中的每一個過程
全局代碼模塊(.bas)的聲明部分中的 ‘Public’ 應用程序中的每一處

在 Visual Basic 的應用程序中,只有當沒有其它方便途徑在窗體之間共享數據時才使用全局變量。當必須使用全局變量時,在一個單一模塊中聲明它們,并按功能分組。給這個模塊取一個有意義的名稱,以指明它的作用,如 Public.bas。

較好的編碼習慣是盡可能寫模塊化的代碼。例如,如果應用程序顯示一個對話框,就把要完成這一對話任務所需要的所有控件和代碼放在單一的窗體中。這有助于將應用程序的代碼組織在有用的組件中,并減小它運行時的開銷。

除了全局變量(應該是不被傳遞的),過程和函數應該僅對傳遞給它們的對象操作。在過程中使用的全局變量應該在過程起始處的聲明部分中標識出來。此外,應該用 ByVal 將參數傳遞給 Sub 過程及 function 過程,除非明顯地需要改變已傳遞的參數值。

隨著工程大小的增長,劃分變量范圍的工作也迅速增加。在類型前綴的前面放置單字母范圍前綴標明了這種增長,但變量名的長度并沒有增加很多。

作者: 61.142.212.* 2005-10-28 20:38 　回復此發言

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

3 VB編程

變量范圍前綴

范圍前綴例子
全局 g gstrUserName
模塊級 m mblnCalcInProgress
本地到過程無 dblVelocity

如果一個變量在標準模塊或窗體模塊中被聲明為 Public,那么該變量具有全局范圍。如果一個變量在標準模塊或窗體模塊中被分別聲明為 Private,那么該變量有模塊級范圍。

注意: 一致性是卓有成效地使用這種技術的關鍵;Visual Basic 中的語法檢查器不會捕捉以 "p." 開頭的模塊級變量。

常量
常量名的主體是大小寫混合的,每個單詞的首字母大寫。盡管標準 Visual Basic 常量不包含數據類型和范圍信息,但是象 i、s、g 和 m 這樣的前綴對于理解一個常量的值和范圍還是很有用的。對于常量名,應遵循與變量相同的規則。例如:

mintUserListMax   '對用戶列表的最大限制
                  '(整數值,本地到模塊)
gstrNewLine       '新行字符
                  '(字符串,應用程序全局使用)

變量
聲明所有的變量將會節省編程時間,因為鍵入操作引起的錯誤減少了(例如,究竟是 aUserNameTmp,還是 sUserNameTmp,還是 sUserNameTemp)。在“選項”對話框的“編輯器”標簽中,復選“要求變量聲明”選項。Option Explicit 語句要求在 Visual Basic 程序中聲明所有的變量。

應該給變量加前綴來指明它們的數據類型。而且前綴可以被擴展,用來指明變量范圍,特別是對大型程序。

用下列前綴來指明一個變量的數據類型。

變量數據類型

數據類型前綴例子
String (字符串類型) str strFName
Integer (短整數類型) int intQuantity
Long (長整數類型) lng lngDistance
Single (單精度浮點數類型) sng sngAverage
Double (雙精度浮點數類型) dbl dblTolerance
Boolean (布爾類型) bln blnFound
Byte (字節類型) byt bytRasterData
Date (日期類型) dte dteNow
Currency (貨幣計算與定點計算類型) cur curRevenue
Object (對象類型) obj objCurrent
Variant (變體類型) vnt vntCheckSum

描述變量和過程名

變量或過程名的主體應該使用大小寫混合形式,并且應該足夠長以描述它的作用。而且,函數名應該以一個動詞起首,如 InitNameArray 或 CloseDialog。

對于頻繁使用的或長的項,推薦使用標準縮略語以使名稱的長度合理化。一般來說,超過 32 個字符的變量名在 VGA 顯示器上讀起來就困難了。

當使用縮略語時,要確保它們在整個應用程序中的一致性。在一個工程中,如果一會兒使用 Cnt, 一會兒使用 Count,將導致不必要的混淆。

用戶定義的類型
在一項有許多用戶定義類型的大工程中,常常有必要給每種類型一個它自己的三個字符的前綴。如果這些前綴是以 "u" 開始的,那么當用一個用戶定義類型來工作時,快速識別這些類型是很容易的。例如,ucli 可以被用來作為一個用戶定義的客戶類型變量的前綴。

[返回索引]

4、在簡單的選擇條件情況下,使用IIf()函數

羅索的代碼:
If nNum = 0 Then
sName = "sancy"
Else
sName = "Xu"
End If

簡單的代碼:
sName=IIf(nNum=0,"sancy","Xu")

5、盡量使用Debug.Print進行調試

在很多初學者的調試中,用MsgBox來跟蹤變量值.其實用Debug.Print不僅可以達到同樣的功效,而且在程序最后編譯過程中,會被忽略.而MsgBox必須手動注釋或刪除.

通常:
MsgBox nName

應該:
Debug.Print nName

6、在重復對某一對象的屬性進行修改時,盡量使用With....End With

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

應該:
With Form1
.Height = 5000
.Width = 6000
.Caption = "This is MyLabel"
End With
這種結構程序執行效率比較高,特別在循環語句里。

7、MsgBox中盡量使用消息圖標,這樣程序比較有規范

作者: 61.142.212.* 2005-10-28 20:38 　回復此發言

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

4 VB編程

一般來說

vbInformation 用來提示確認或成功操作的消息

vbExclamation 用來提示警告的消息

vbCritical 用來提示危機情況的消息

vbQuestion 用來提示詢問的消息

[返回索引]

8、在可能的情況下使用枚舉

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

Enum 語句包含下面部分:

部分描述
Public 可選的。表示該 Enum 類型在整個工程中都是可見的。Enum 類型的缺省情況是 Public。
Private 可選的。表示該 Enum 類型只在所聲明的模塊中是可見的。
name 必需的。該 Enum 類型的名稱。name 必須是一個合法的 Visual Basic 標識符,在定義該 Enum 類型的變量或參數時用該名稱來指定類型。
membername 必需的。用于指定該 Enum 類型的組成元素名稱的合法 Visual Basic 標識符。
constantexpression 可選的。元素的值(為 Long 類型)�？梢允莿e的 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操作系統上的應用程序�？梢哉f,如果你曾經學過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函數中經�？吹降臄祿愋陀小肔ong,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, "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 End Sub

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

作者: 61.142.212.* 2005-10-28 21:16 　回復此發言

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

25 拖動沒有標題欄的窗體。
Option Explicit

Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1

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

Private Sub Form_Load()
MsgBox "拖動沒有標題欄的窗體"
End Sub

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

作者: 61.142.212.* 2005-10-28 21:17 　回復此發言

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

26 自動完成字符串填寫功能(像IE的地址欄自動完成地址輸入)。
Option Explicit

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

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

'Private flag
Private m_bEditFromCode As Boolean

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

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

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

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

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

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

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

Private Sub cmdClose_Click()
Unload Me
End Sub

作者: 61.142.212.* 2005-10-28 21:18 　回復此發言

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

27 在任務條Tray右邊出現動畫圖標。
Option Explicit

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

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:20 　回復此發言

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

28 支持從文件瀏覽器里拖入文件。
Private Sub Command1_Click()

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

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

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

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

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

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

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

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

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

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

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

' Declares

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

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

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

Form1.Show

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

End Sub

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

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

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

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

If fileDropped Then

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

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

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

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

Next curFile

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

DragFinish (hDrop)
End If

' Be nice and DoEvents
DoEvents
Loop

End Sub

作者: 61.142.212.* 2005-10-28 21:21 　回復此發言

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

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

Private Sub Form_Load()
Me.WindowState = 0
'
'顯示在桌面最頂層
'
Call Fun_AlwaysOnTop(frmSplash, True)

frmSplash.Show
frmSplash.Refresh

frmWelcome.Show

frmWelcome.Refresh
'******************
'函數:延時2秒運行
Fun_SleepTest 2
'******************

frmSplash.Hide: Unload frmSplash

End Sub

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

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

'聲明變量
Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer

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

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

'----------------
'函數:延時運行
'----------------
Public Function Fun_SleepTest(X As Integer)
Dim StarTime As Single
StarTime = Timer
Do Until (Timer - StarTime) > X
' DoEvents$ '轉讓控制權,以便讓操作系統
Loop
End Function

-------------
Private Sub Command1_Click()
MsgBox "Welcome to VB編程樂園"
End Sub

作者: 61.142.212.* 2005-10-28 21:22 　回復此發言

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

30 針式石英鐘例子。
Option Explicit

DefDbl A-Z

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

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

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

End Sub

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

End Sub

作者: 61.142.212.* 2005-10-28 21:23 　回復此發言

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

31 看慣了微軟那種老氣橫秋的按紐,這里教你如何改變按紐的前景色。
Option Explicit

Private Sub Form_Load()

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

End Sub

Private Sub Form_Unload(Cancel As Integer)

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

End Sub

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

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

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

Private Declare Function GetParent Lib "user32" _
(ByVal hWnd As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:24 　回復此發言

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

32 看慣了微軟那種老氣橫秋的按紐,這里教你如何改變按紐的前景色。
rcItem As RECT
itemData As Long
End Type

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

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

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

Dim s As String
Dim va As TextVAligns

va = GetProp(hWnd, "VBTVAlign")

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

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

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

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

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

End Sub

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

Dim lOldProc As Long
Dim di As DRAWITEMSTRUCT

lOldProc = GetProp(hWnd, "ExtBtnProc")

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

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

End If

ElseIf wMsg = WM_DESTROY Then
ExtButtonUnSubclass hWnd

End If

End Function

Public Sub ExtButtonSubclass(hWndForm As Long)

Dim l As Long

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

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

End Sub

Public Sub ExtButtonUnSubclass(hWndForm As Long)

Dim l As Long

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

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

End Sub

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

Dim hWndParent As Long

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

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

End Sub

Public Sub RemoveButton(ByVal hWnd As Long)

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

End Sub

作者: 61.142.212.* 2005-10-28 21:24 　回復此發言

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

33 調色板應用例子(會把你設定的顏色放到格子里)
Option Explicit
Const DEFAULT_PALETTE As Integer = 15
Const BLACK_BRUSH As Integer = 4
Const PC_RESERVED As Integer = &H1&

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

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

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

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

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

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

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

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

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

Private Sub Colour_Scroll(index As Integer)
'顏色滾動條滾動
If Not SelectingColor Then
Call ColorChange(index)
End If

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

Private Sub Colour_Change(index As Integer)
'顏色滾動條數值變化
If Not SelectingColor Then
Call ColorChange(index)

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

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

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

Block = 16 '每行16塊
ColorSelected = -1 '未選擇顏色

作者: 61.142.212.* 2005-10-28 21:25 　回復此發言

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

34 調色板應用例子(會把你設定的顏色放到格子里)

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

'創建調色板
hCurrentPalette = CreatePalette(LogicalPalette)
Call Pic1_Paint '繪顯示區
End Sub

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

hSystemPalette = GetStockObject(DEFAULT_PALETTE) '取得系統缺省調色板
hDummyPalette = SelectPalette(Pic1.hdc, hSystemPalette, 0) '恢復缺省調色板
hDummyPalette = SelectPalette(Pic2.hdc, hSystemPalette, 0)
Dummy = DeleteObject(hCurrentPalette) '刪除自定義調色板
End Sub

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

'設置選擇顏色標志
SelectingColor = True

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

Row = Y \ BoxHeight
Column = X \ BoxWidth

If Row < Block And Column < Block Then
'選擇了顏色塊
ColorSelected = Row * Block + Column
Dummy = GetPaletteEntries(hCurrentPalette, ColorSelected, 1, _
CurrentPaletteEntry)
Colour(0).Value = CurrentPaletteEntry.peRed
Colour(1).Value = CurrentPaletteEntry.peGreen
Colour(2).Value = CurrentPaletteEntry.peBlue

Pic1_Paint '重繪顏色顯示
Pic2_Paint
End If
End Sub

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

'應用自定義調色板
hSystemPalette = SelectPalette(Pic1.hdc, hCurrentPalette, 0)
Dummy = RealizePalette(Pic1.hdc) '確認調色板

'計算各顏色塊大小
BoxWidth = Pic1.ScaleWidth \ Block
BoxHeight = Pic1.ScaleHeight \ Block

'繪制各顏色塊
For ColorIndex = 0 To Block * Block - 1
Row = ColorIndex \ Block + 1 '計算行位置(從1開始)
Column = ColorIndex Mod Block + 1 '計算列位置
hBrush = CreateSolidBrush(&H1000000 Or ColorIndex) '以指定調色板創建畫刷
Dummy = SelectObject(Pic1.hdc, hBrush) '應用畫刷
Dummy = Rectangle(Pic1.hdc, (Column - 1) * BoxWidth, (Row - 1) * BoxHeight, _
Column * BoxWidth, Row * BoxHeight) '繪制矩形
Dummy = SelectObject(Pic1.hdc, GetStockObject(BLACK_BRUSH)) '恢復缺省畫刷
Dummy = DeleteObject(hBrush) '刪除自創建畫刷
Next ColorIndex

'繪制突出顯示顏色塊
PaintSubBlock
End Sub

Private Sub PaintSubBlock()
'該函數用于繪制突出顯示顏色塊
'各函數使用同 Pic1_Paint 中
Dim Row As Integer
Dim Column As Integer
Dim BoxHeight As Integer
Dim BoxWidth As Integer
Dim Color As Long
Dim ColorIndex As Long
Dim hBrush As Long
Dim Dummy As Integer

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

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

Private Sub Pic2_Paint()
'該函數用于繪制顏色顯示塊(Pic2 控件)
Dim hBrush As Long
Dim Dummy As Long

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:25 　回復此發言

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

35 精彩萬花筒(可以生成許多美麗的藝術圖案)
Public duo As Boolean
Public icolor As Long
Private Sub cmddan_Click()
cdl1.ShowColor
icolor = cdl1.Color
duo = False
End Sub

Private Sub cmdduo_Click()
duo = True
End Sub

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

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

End Sub

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

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

End Sub

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

作者: 61.142.212.* 2005-10-28 21:26 　回復此發言

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

36 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private m_cN As cNeoCaption

Private Sub sub_Skin(fMain As Form, cN As cNeoCaption)
cN.ActiveCaptionColor = &HFFFFFF '活動窗體的標題前景色
cN.InActiveCaptionColor = &HC0FFC0 '非活動窗體的標題前景色
'cN.InActiveCaptionColor = &HC0C0C0
cN.ActiveMenuColor = &HC00000 '活動菜單前景色
'cN.ActiveMenuColor = &H0
cN.ActiveMenuColorOver = &HFF& '激活活動菜單前景色
'cN.ActiveMenuColorOver = &H0
cN.InActiveMenuColor = &H0 '非活動菜單前景色
cN.MenuBackgroundColor = &H8000000F '菜單背景顏色
'cN.MenuBackgroundColor = RGB(207, 203, 207)
cN.CaptionFont.Name = "宋體" '標題字體
cN.CaptionFont.Size = 9 '標題字號
cN.MenuFont.Name = "宋體" '菜單字體
cN.MenuFont.Size = 9 '菜單字號
cN.Attach fMain, fMain.PicCaption.Picture, fMain.PicBorder.Picture, 19, 20, 90, 140, 240, 400 '窗體外觀參數
fMain.BackColor = &H8000000F '窗體背景
'fMain.BackColor = RGB(208, 207, 192)
'fMain.BackColor = RGB(207, 203, 207)
End Sub

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

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

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

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

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

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

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

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

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

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

Public Sub AttachKeyboardHook(cN As cNCCalcSize)

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

38 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
lpFn = HookAddress(AddressOf KeyboardFilter)
m_hKeyHook = SetWindowsHookEx(WH_KEYBOARD, lpFn, 0&, GetCurrentThreadId())
Debug.Assert (m_hKeyHook <> 0)
End If

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

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

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

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

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

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

On Error GoTo ErrorHandler

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

Exit Function

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

39 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
If (m_hMsgHook <> 0) Then
UnhookWindowsHookEx m_hMsgHook
m_hMsgHook = 0
End If
End Sub

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

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

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

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

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

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

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

Private m_iCurrentMessage As Long
Private m_iProcOld As Long

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

Private Sub ErrRaise(e As Long)

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

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

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

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

41 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
' wants to subclass its container. In this case, we want
' all instances of the control on the form to receive the
' form notification message.

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

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

End If
End Sub

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

End Function

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

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

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

Const cTimerMax = 100

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

Private Sub Class_Terminate()
pDestroy
End Sub

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

45 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Const MIIM_SUBMENU = &H4&
Private Const MIIM_CHECKMARKS = &H8&
Private Const MIIM_TYPE = &H10&
Private Const MIIM_DATA = &H20&

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

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

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

47 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Declare Function HiliteMenuItem Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long, ByVal wIDHiliteItem As Long, ByVal wHilite As Long) As Long

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

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

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

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

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

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

Private Const BDR_OUTER = &H3

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

48 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

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

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

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

Private Const CLR_INVALID = -1

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

Private Const HWND_DESKTOP = 0

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

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

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

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

Private m_oMenuBackgroundColor As OLE_COLOR

Private m_lCaptionHeight As Long

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

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_fnt As StdFont
Private m_fntSymbol As StdFont

Private m_lMenuItemHeight As Long

Private WithEvents m_cTmr As CTimer

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

49 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)

Implements ISubclass

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

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

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

End If

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

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

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

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

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

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

51 漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
HitTest = iMenu
Exit Function
End If
Next iMenu
End Function
Friend Property Get Count() As Long

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

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

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

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

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

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

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

If Not bHaveSeen Then

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

lID = plAddToRestoreList(hMenu, iMenu, tMIIS)

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

Else

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

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

lID = plReplaceIndex(hMenu, iMenu)

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

pReplaceRestoreList lID, hMenu, iMenu, tMIIS

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

End If

End If

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

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

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

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

Next iMenu

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

SelectObject m_cMemDC.hdc, hFntOld

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

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

Dim i As Long

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

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

作者: 61.142.212.* 2005-10-28 21:32 　回復此發言

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

52 回復 50:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private m_cMemDC As cMemDC
Private m_cToolbarMenu As cToolbarMenu
Private m_hMenu As Long
Private m_hWnd As Long

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

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

Private m_oMenuBackgroundColor As OLE_COLOR

Private m_lCaptionHeight As Long

Private m_iHaveSeenCount As Long
Private m_hMenuSeen() As Long

Private m_fnt As StdFont
Private m_fntSymbol As StdFont

Private m_lMenuItemHeight As Long

Private WithEvents m_cTmr As CTimer

Implements ISubclass

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

53 回復 50:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
ByVal lLeft As Long, _
ByVal lTop As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal lYoffset As Long _
)
Dim iIdx As Long
Dim lC As Long
Dim lhDCC As Long
Dim tMII As MENUITEMINFO_STRINGDATA
Dim sCap As String
Dim hFntOld As Long
Dim tTR As RECT, tBR As RECT
Dim lX As Long
Dim lR As Long
Dim bPress As Boolean
Dim lID As Long

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

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

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

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

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

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

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

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

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

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

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

If Not bHaveSeen Then

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

lID = plAddToRestoreList(hMenu, iMenu, tMIIS)

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

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

Else

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

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

lID = plReplaceIndex(hMenu, iMenu)

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

pReplaceRestoreList lID, hMenu, iMenu, tMIIS

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

End If

End If

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

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

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

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

Next iMenu

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

SelectObject m_cMemDC.hdc, hFntOld

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

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

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

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

m_iRestore = m_iRestore + 1

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

56 回復 50:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
ReDim Preserve m_hMenuRestore(1 To m_iRestore) As Long
ReDim Preserve m_iMenuPosition(1 To m_iRestore) As Long
ReDim Preserve m_tMIIS(1 To m_iRestore) As MENUITEMINFO_STRINGDATA
ReDim Preserve m_sCaption(1 To m_iRestore) As String
ReDim Preserve m_sShortCut(1 To m_iRestore) As String
ReDim Preserve m_sAccelerator(1 To m_iRestore) As String
ReDim Preserve m_lMenuTextSize(1 To m_iRestore) As Long
ReDim Preserve m_lMenuShortCutSize(1 To m_iRestore) As Long
pReplaceRestoreList m_iRestore, hMenu, iMenu, tMIIS
plAddToRestoreList = m_iRestore

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

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

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

Private Sub Class_Terminate()
Set m_cMemDC = Nothing
End Sub

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

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

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

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

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

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

Case WM_MEASUREITEM
ISubclass_WindowProc = MeasureItem(wParam, lParam)

Case WM_DRAWITEM
DrawItem wParam, lParam

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

End Select

End Function
'

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

57 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Function ParseMenuChar( _
ByVal hMenu As Long, _
ByVal iChar As Integer _
) As Long
Dim sChar As String
Dim l As Long
Dim lH() As Long
Dim sItems() As String

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

End Function

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

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

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

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

CopyMemory ByVal lParam, tMIS, LenB(tMIS)

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

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

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

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

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

SetBkMode lhDC, TRANSPARENT

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

58 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
bDisabled = ((tMII.fState And MFS_DISABLED) = MFS_DISABLED)
bChecked = ((tMII.fState And MFS_CHECKED) = MFS_CHECKED)
bHighlighted = ((tMII.fState And MFS_HILITE) = MFS_HILITE)
If bHighlighted Then
SetTextColor lhDC, TranslateColor(m_oActiveMenuColorOver)
Else
SetTextColor lhDC, TranslateColor(m_oActiveMenuColor)
End If

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

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

End If

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

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

End If

SelectObject lhDC, hFntOld

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

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

59 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
If OleTranslateColor(clr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function

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

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

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

60 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long

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

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

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

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

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

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

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

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

61 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Private Const SM_CYFRAME = 33
Private Const SM_CYHSCROLL = 3
Private Const SM_CYMENU = 15
Private Const SM_CYSMSIZE = 31
Private Const SM_CXSMSIZE = 30

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

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

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

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

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

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

' Map WIndow Points
Private Const HWND_DESKTOP = 0

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

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

62 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Const WM_INITMENU = &H116
Private Const WM_INITMENUPOPUP = &H117
Private Const WM_MDIGETACTIVE = &H229

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

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

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

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

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

Implements ISubclass

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

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

作者: 61.142.212.* 2005-10-28 21:33 　回復此發言

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

63 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
' Window handles:
Private m_hWnd As Long
Private m_hWndMDIClient As Long
Private m_bIsMDIChild As Boolean

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

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

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

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

Detach

m_hWnd = iTo.hwnd
m_hMenu = GetMenu(m_hWnd)

m_bIsMDIChild = IsMDIChildForm(m_hWnd)

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

If m_bIsMDIChild Then
AttachMessage Me, m_hWnd, WM_SIZE
End If

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

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

64 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
AttachMessage Me, m_hWnd, WM_DESTROY

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

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

SetProp m_hWnd, "vbalCNCImplementation", ObjPtr(iTo)

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

DetachMessage Me, m_hWnd, WM_SETCURSOR

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

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

DetachMessage Me, m_hWnd, WM_ACTIVATEAPP

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

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

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

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

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

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

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

End Sub

Private Sub Class_Terminate()
Detach
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

65 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
'
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse

Select Case CurrentMessage
Case WM_NCPAINT, WM_NCLBUTTONDOWN, _
WM_NCLBUTTONDBLCLK, _
WM_INITMENUPOPUP, WM_INITMENU, _
WM_SETCURSOR, WM_CHILDACTIVATE, _
WM_STYLECHANGED, WM_SETTEXT, _
WM_NCHITTEST, WM_SIZE, _
WM_ENTERMENULOOP, WM_EXITMENULOOP
ISubclass_MsgResponse = emrConsume
Case Else
' ActiveApp, Destroy:
ISubclass_MsgResponse = emrPreprocess
End Select

End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tNCR As NCCALCSIZE_PARAMS
Dim tWP As WINDOWPOS
Dim tP As POINTAPI
Dim tR As RECT
Dim lhWnd As Long
Dim lpfMaximised As Long
Dim lPtr As Long
Dim hdc As Long
Dim lStyle As Long
Dim eHt As ECNCHitTestConstants
Static s_dx As Long
Static s_dy As Long
Dim bCanSize As Boolean
Dim Implementation As INCAreaModifier
Dim bHandled As Boolean
Static s_bNoStyleChangeProcessing As Boolean
Static s_bChildActivate As Boolean

Select Case iMsg

Case WM_DESTROY
' Goodbye!
Detach

Case WM_NCPAINT

' Due to processing elsewhere in this subclass, we
' might inadvertently be drawing when the window
' is being closed or invisible. Check before
' drawing:
If Not (IsWindowVisible(hwnd) = 0) Then
m_bZoomedMDIChild = (IsMDIChildForm(hwnd) And (IsZoomed(hwnd) <> 0))
If m_bZoomedMDIChild Then
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
Else
' Get the non-client DC to draw in:
hdc = GetWindowDC(m_hWnd)

GetWindowRect m_hWnd, tR
OffsetRect tR, -tR.left, -tR.top

If GetImplementation(Implementation) Then
Implementation.NCPaint hdc, tR.left, tR.top, tR.right, tR.bottom
Else
DefaultNCPaint hdc, tR.left, tR.top, tR.right, tR.bottom
End If

ReleaseDC m_hWnd, hdc
End If
End If

Case WM_NCHITTEST

If GetImplementation(Implementation) Then
eHt = pGetHitTestCode()
m_eLastHT = eHt
If eHt = HTMENU Then
' Cannot allow windows to have this; if you
' mouse down on menu or caption then windows
' redraws the caption on top...
ISubclass_WindowProc = HTCLIENT
Else
ISubclass_WindowProc = eHt
End If

Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

Case WM_NCLBUTTONDOWN
'
' a hack.
'
' Win suspends when we do a NC Button down. It also
' redraws the min/max/close buttons. We can force them
' to go away by moving the mouse
'
If s_dx = 0 Then s_dx = 1
If s_dy = 0 Then s_dy = 1
s_dx = -1 * s_dx: s_dy = -1 * s_dy
mouse_event MOUSEEVENTF_MOVE, s_dx, s_dy, 0, 0

' We cannot allow Windows to do the default HTCAPTION action,
' because it redraws the caption during the move. THerefore
' swallow HTCAPTION events and reimplement window moving
' ourselves:
wParam = pGetHitTestCode()
If GetImplementation(Implementation) Then
If m_bActive Then
If m_eLastHT = HTCAPTION Then
MyMoveWindow
Exit Function
End If
Else
If m_eLastHT = HTCAPTION Then
SetForegroundWindow m_hWnd

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

66 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
MyMoveWindow
Exit Function
End If
End If

GetCursorPos tP
GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
hdc = GetWindowDC(m_hWnd)
Implementation.NCMouseDown tP.x, tP.y, bHandled, hdc, tR.left, tR.top, tR.right, tR.bottom
ReleaseDC m_hWnd, hdc
If bHandled Then
Exit Function
End If

End If

ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_NCLBUTTONUP
If GetImplementation(Implementation) Then
GetCursorPos tP
GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
hdc = GetWindowDC(m_hWnd)
Implementation.NCMouseDown tP.x, tP.y, bHandled, hdc, tR.left, tR.top, tR.right, tR.bottom
ReleaseDC m_hWnd, hdc
Implementation.NCMouseUp tP.x, tP.y, hdc, tR.left, tR.top, tR.right, tR.bottom
End If

Case WM_SETCURSOR
'
' a Very Nasty Hack :)
' discovered by watching NeoPlanet and MSOffice
' in Spy++
'
' Without this, Win will redraw caption areas and
' min/max/close buttons whenever the mouse is released
' following a NC mouse down.
'
s_bNoStyleChangeProcessing = True
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
SetWindowLong m_hWnd, GWL_STYLE, lStyle And Not WS_VISIBLE
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
If GetMenu(m_hWnd) <> 0 Then
SetMenu m_hWnd, 0
End If
SetWindowLong m_hWnd, GWL_STYLE, lStyle
s_bNoStyleChangeProcessing = False

Case WM_INITMENU
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_CHILDACTIVATE
If Not s_bChildActivate Then
s_bChildActivate = True
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
s_bChildActivate = False
End If

Case WM_SIZE
'
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0

Case WM_INITMENUPOPUP
'
' During a WM_INITMENUPOPUP, the system redraws the
' min/max/close buttons.

' Check HiWord of lParam to see whether this is
' a SysMenu:
If Not (lParam And &HFFFF0000) = 0 Then
' Sys Menu:
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
Else
' App Menu:
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
If GetImplementation(Implementation) Then
Implementation.InitMenuPopup wParam, lParam
End If
End If

Case WM_ENTERMENULOOP, WM_EXITMENULOOP
ISubclass_MsgResponse = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
If iMsg = WM_EXITMENULOOP Then
If GetImplementation(Implementation) Then
Implementation.ExitMenuLoop
End If
End If

Case WM_SETTEXT, WM_STYLECHANGED, WM_NCLBUTTONDBLCLK
'
' The whole title bar is repainted by the defwindowproc.

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

67 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
' Therefore redraw once complete:
If Not s_bNoStyleChangeProcessing Then
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
ISubclass_WindowProc hwnd, WM_NCPAINT, 0, 0
Else
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

Case WM_NCCALCSIZE
'
' No Hacks!
'
' This simply tells windows to modify the client
' area to the appropriate size:
'

' First set the zoomed MDI Child flag:
m_bZoomedMDIChild = (IsMDIChildForm(hwnd) And (IsZoomed(hwnd) <> 0))
If wParam <> 0 Then

' Get the structure pointed to by lParam:
CopyMemory tNCR, ByVal lParam, Len(tNCR)
CopyMemory tWP, ByVal tNCR.lppos, Len(tWP)

'pDebugCalcSize tNCR
With tNCR.rgrc(0)
' Set these
.left = tWP.x
.top = tWP.y
.right = tWP.x + tWP.cx
.bottom = tWP.y + tWP.cy

' Defaults
m_lLeft = GetSystemMetrics(SM_CXFRAME)
m_lRight = m_lLeft
m_lTop = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME)
m_lBottom = GetSystemMetrics(SM_CYFRAME)

' If the window in question is an MDI child, then we
' ant to ensure that the standard settings get sent
' back to windows: to prevent drawing additional borders,
' which aren't required:
If Not m_bZoomedMDIChild Then
' If the implementation is valid then request the
' physical size of the title bar and borders:
If GetImplementation(Implementation) Then
Implementation.GetLeftMarginWidth m_lLeft
Implementation.GetTopMarginHeight m_lTop
Implementation.GetRightMarginWidth m_lRight
Implementation.GetBottomMarginHeight m_lBottom
End If
End If

' Set our physical left/top/right/bottom values:
.left = .left + m_lLeft
.top = .top + m_lTop
.right = .right - m_lRight
.bottom = .bottom - m_lBottom
End With

' Return the new client area size to windows:
LSet tNCR.rgrc(1) = tNCR.rgrc(0)
CopyMemory ByVal lParam, tNCR, Len(tNCR)
ISubclass_WindowProc = WVR_VALIDRECTS

Else
' lParam points to a rectangle
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End If

' Check for the active window:
'lPtr = VarPtr(lpfMaximised)
'If Not m_hWndMDIClient = 0 Then
' lhWnd = SendMessageLong(m_hWndMDIClient, WM_MDIGETACTIVE, 0, lPtr)
' pShowMDIButtons lhWnd, (lpfMaximised <> 0)
'End If

Case WM_NCACTIVATE
'
' When we get a NC Activate The title bar is
' being redrawn to show active or inactive states.
'
' This processing ensures the title bar is updated
' correctly following state change:
'

' We must call the defwindowproc otherwise VB goes
' funny. This draws a full titlebar:
m_bActive = Not (wParam = 0)
ISubclass_WindowProc = CallOldWindowProc(hwnd, iMsg, wParam, lParam)

' Now fix it:
ISubclass_WindowProc m_hWnd, WM_NCPAINT, 0, 0

Case WM_ACTIVATEAPP
'
' This is for detecting which app is active
'
m_bAppActive = Not (wParam = 0)

End Select

End Function
Private Function IsMDIChildForm(ByVal hwnd As Long) As Boolean
Dim hWndP As Long
Dim sBuf As String
Dim iPos As Long
hWndP = GetParent(hwnd)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

68 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
sBuf = String$(260, 0)
GetClassName hWndP, sBuf, 259
iPos = InStr(sBuf, vbNullChar)
If iPos > 1 Then
If left$(sBuf, iPos - 1) = "MDIClient" Then
IsMDIChildForm = True
End If
End If
End Function
Private Function pGetHitTestCode() As ECNCHitTestConstants
Dim lStyle As Long
Dim bCanSize As Boolean
Dim Implementation As INCAreaModifier
Dim eHt As ECNCHitTestConstants
Dim tP As POINTAPI
Dim tR As RECT

If GetImplementation(Implementation) Then
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
bCanSize = ((lStyle And WS_SIZEBOX) = WS_SIZEBOX)
eHt = HTCLIENT
GetCursorPos tP

GetWindowRect m_hWnd, tR
tP.x = tP.x - tR.left: tP.y = tP.y - tR.top
OffsetRect tR, -tR.left, -tR.top
eHt = HTCLIENT
If Not (PtInRect(tR, tP.x, tP.y) = 0) Then
' Left
If tP.x <= m_lLeft Then
If tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOPLEFT
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOMLEFT
End If
Else
If bCanSize Then
eHt = HTLEFT
End If
End If
' Right
ElseIf tP.x >= tR.right - m_lRight Then
If tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOPRIGHT
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOMRIGHT
End If
Else
If bCanSize Then
eHt = HTRIGHT
End If
End If
' Top/Bottom?
ElseIf tP.y <= m_lBottom Then
If bCanSize Then
eHt = HTTOP
End If
ElseIf tP.y >= tR.bottom - m_lBottom Then
If bCanSize Then
eHt = HTBOTTOM
End If
' Caption/Menu
ElseIf tP.y <= m_lTop Then
' We assume for default that the caption
' is the same as the system caption etc:
If tP.y <= m_lBottom + GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTCAPTION
If tP.x <= GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTSYSMENU
Else
' todo min/max/close btns
End If
ElseIf tP.y > m_lBottom + GetSystemMetrics(SM_CYCAPTION) Then
eHt = HTCLIENT
End If
End If
End If
Implementation.HitTest tP.x, tP.y, eHt
End If
pGetHitTestCode = eHt

End Function
Public Sub DefaultNCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim tR As RECT, tTR As RECT, tSR As RECT, tBR As RECT
Dim lFlag As Long
Dim hBr As Long, hBrButton As Long

tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom
LSet tBR = tR

If m_bActive Then
lFlag = DC_ACTIVE
hBrButton = GetSysColorBrush(COLOR_ACTIVECAPTION)
hBr = GetSysColorBrush(COLOR_ACTIVEBORDER)
Else
hBrButton = GetSysColorBrush(COLOR_INACTIVECAPTION)
hBr = GetSysColorBrush(COLOR_INACTIVEBORDER)
End If

' Titlebar area:
' Draw the part between the edge & the client:
LSet tTR = tR
' left edge
tTR.top = GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.bottom - GetSystemMetrics(SM_CYFRAME)
tTR.right = GetSystemMetrics(SM_CXFRAME)
FillRect hdc, tTR, hBr
' top
LSet tTR = tR
tTR.bottom = GetSystemMetrics(SM_CYFRAME)
FillRect hdc, tTR, hBr
' right
LSet tTR = tR
tTR.top = GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.bottom - GetSystemMetrics(SM_CYFRAME)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

69 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
tTR.left = tTR.right - GetSystemMetrics(SM_CXFRAME)
FillRect hdc, tTR, hBr
' bottom
LSet tTR = tR
tTR.top = tTR.bottom - GetSystemMetrics(SM_CYFRAME)
FillRect hdc, tTR, hBr

' Draw the caption into the caption area:

' top bit under titlebar:
LSet tTR = tR
tTR.top = GetSystemMetrics(SM_CXFRAME) + GetSystemMetrics(SM_CYCAPTION) - 1
tTR.bottom = tTR.top + 1
FillRect hdc, tTR, hBr
DeleteObject hBr

' Draw the titlebar into a work DC to prevent flicker:
lFlag = lFlag Or DC_ICON Or DC_TEXT
LSet tTR = tR
tTR.left = tTR.left + GetSystemMetrics(SM_CXFRAME)
tTR.right = tTR.right - GetSystemMetrics(SM_CXFRAME)
tTR.top = tTR.top + GetSystemMetrics(SM_CYFRAME)
tTR.bottom = tTR.top + GetSystemMetrics(SM_CYCAPTION) - 1
LSet tR = tTR
OffsetRect tR, -tR.left, -tR.top
LSet tSR = tR
tSR.right = tSR.right - (tR.bottom - tR.top) * 3 - 2
DrawCaptionAPI m_hWnd, m_hDC, tSR, lFlag

' Draw the titlebar buttons:
tSR.left = tSR.right
tSR.right = tR.right
FillRect m_hDC, tSR, hBrButton
DeleteObject hBrButton

InflateRect tR, 0, -2
tR.right = tR.right - 2
tR.left = tR.right - (tR.bottom - tR.top) - 2
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONCLOSE
OffsetRect tR, -(tR.right - tR.left + 2), 0
If IsZoomed(m_hWnd) Then
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONRESTORE
Else
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONMAX
End If
OffsetRect tR, -(tR.right - tR.left), 0
DrawFrameControl m_hDC, tR, DFC_CAPTION, DFCS_CAPTIONMIN

' Finished drawing the NC area:
BitBlt hdc, tTR.left, tTR.top, tTR.right - tTR.left, tTR.bottom - tTR.top, m_hDC, 0, 0, vbSrcCopy

' Edge 3d
DrawEdge hdc, tBR, EDGE_RAISED, BF_RECT

End Sub

Public Function GetImplementation(iTo As INCAreaModifier) As Boolean
Dim lPtr As Long
lPtr = GetProp(m_hWnd, "vbalCNCImplementation")
If Not lPtr = 0 Then
Dim iToTemp As INCAreaModifier
CopyMemory iToTemp, lPtr, 4
Set iTo = iToTemp
CopyMemory iToTemp, 0&, 4
GetImplementation = True
End If
End Function

#If 0 = 1 Then
Private Sub pDebugCalcSize(ByRef tNCR As NCCALCSIZE_PARAMS)
Dim i As Long
Dim tWP As WINDOWPOS
' Use to show what is happening:
With tNCR
For i = 1 To 3
With .rgrc(i - 1)
Debug.Print .left, .top, .right, .bottom
End With
Next i
CopyMemory tWP, ByVal .lppos, Len(tWP)
With tWP
Debug.Print .x, .y, .x + .cx, .y + .cy
End With

End With
End Sub
#End If

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

' APIs
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

70 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const CLR_INVALID = -1

Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

' Font:
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

71 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Private Const LOGPIXELSY = 90

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

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_CHILD = &H40000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_SYSCOMMAND = &H112

' Implementation
Implements INCAreaModifier

Private Enum ECNCButtonStates
up
Down
End Enum

Private m_cNCS As cNCCalcSize
Private m_hWnd As Long

' MemDCs for storing GFX
Private m_cBorder As cMemDC
Private m_cCaption As cMemDC

' MemDC for building caption:
Private m_cFF As cMemDC
' and l/r borders
Private m_cFFB As cMemDC
' Menu bar:
Private m_cMenu As cMenuBar

Private m_oActiveCaptionColor As OLE_COLOR
Private m_oInActiveCaptionColor As OLE_COLOR
Private m_fnt As IFont

Private m_oActiveMenuColor As OLE_COLOR
Private m_oActiveMenuColorOver As OLE_COLOR
Private m_oInActiveMenuColor As OLE_COLOR
Private m_oMenuBackgroundColor As OLE_COLOR
Private m_fntMenu As IFont

Private m_lButtonWidth As Long
Private m_lButtonHeight As Long
Private m_lActiveLeftEnd As Long
Private m_lActiveRightStart As Long
Private m_lActiveRightEnd As Long
Private m_lInactiveOffset As Long

Private m_tBtn(0 To 2) As RECT
Private m_bMaximise As Boolean
Private m_bMinimise As Boolean
Private m_bClose As Boolean
Private m_bMouseDownMinimise As Boolean
Private m_bMouseDownMaximise As Boolean
Private m_bMouseDownClose As Boolean

Public Sub Detach()
Dim lMenu As Long
If Not m_cNCS Is Nothing Then
m_cNCS.Detach
End If
If Not m_cMenu Is Nothing Then
lMenu = m_cMenu.hMenu
m_cMenu.Detach
End If
If Not (lMenu = 0) Then
SetMenu m_hWnd, lMenu
End If

End Sub

Public Sub Attach( _
f As Object, _
PicCaption As StdPicture, _
PicBorder As StdPicture, _
lButtonWidth As Long, _
lButtonHeight As Long, _
lActiveLeftEnd As Long, _
lActiveRightStart As Long, _
lActiveRightEnd As Long, _
lInactiveOffset As Long _
)
LockWindowUpdate f.hwnd
Detach

' Store the pictures:
Set m_cCaption = New cMemDC

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

72 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
m_cCaption.CreateFromPicture PicCaption
Set m_cBorder = New cMemDC
m_cBorder.CreateFromPicture PicBorder

' FF drawing
Set m_cFF = New cMemDC
Set m_cFFB = New cMemDC

' Store passed in vars:
m_lButtonWidth = lButtonWidth
m_lButtonHeight = lButtonHeight

m_lActiveLeftEnd = lActiveLeftEnd
m_lActiveRightStart = lActiveRightStart
m_lActiveRightEnd = lActiveRightEnd
m_lInactiveOffset = lInactiveOffset

' Store hWNd:
m_hWnd = f.hwnd

' Menu:
Set m_cMenu = New cMenuBar
m_cMenu.Attach m_hWnd
m_cMenu.Font = m_fntMenu
m_cMenu.SetColors m_oActiveMenuColor, m_oActiveMenuColorOver, m_oInActiveMenuColor, m_oMenuBackgroundColor
m_cMenu.CaptionHeight = m_cCaption.Height

' Start non-client modification:
Set m_cNCS = New cNCCalcSize
m_cNCS.Attach Me
m_cNCS.Display f

If IsWindowVisible(m_hWnd) <> 0 Then
SetForegroundWindow m_hWnd
SetFocusAPI m_hWnd
SendMessageLong m_hWnd, WM_NCACTIVATE, 1, 0
End If

LockWindowUpdate 0

End Sub
Public Property Get MenuBackgroundColor() As OLE_COLOR
MenuBackgroundColor = m_oMenuBackgroundColor
End Property
Public Property Let MenuBackgroundColor(ByVal oColor As OLE_COLOR)
m_oMenuBackgroundColor = oColor
End Property
Public Property Get ActiveCaptionColor() As OLE_COLOR
ActiveCaptionColor = m_oActiveCaptionColor
End Property
Public Property Let ActiveCaptionColor(ByVal oColor As OLE_COLOR)
m_oActiveCaptionColor = oColor
End Property
Public Property Get InActiveCaptionColor() As OLE_COLOR
InActiveCaptionColor = m_oInActiveCaptionColor
End Property
Public Property Let InActiveCaptionColor(ByVal oColor As OLE_COLOR)
m_oInActiveCaptionColor = oColor
End Property
Public Property Get CaptionFont() As IFont
Set CaptionFont = m_fnt
End Property
Public Property Let CaptionFont(iFnt As IFont)
Set m_fnt = iFnt
End Property
Public Property Get MenuFont() As IFont
Set MenuFont = m_fntMenu
End Property
Public Property Let MenuFont(iFnt As IFont)
Set m_fntMenu = iFnt
End Property
Public Property Get ActiveMenuColor() As OLE_COLOR
ActiveMenuColor = m_oActiveMenuColor
End Property
Public Property Get ActiveMenuColorOver() As OLE_COLOR
ActiveMenuColorOver = m_oActiveMenuColorOver
End Property
Public Property Get InActiveMenuColor() As OLE_COLOR
InActiveMenuColor = m_oInActiveMenuColor
End Property
Public Property Let ActiveMenuColor(oColor As OLE_COLOR)
m_oActiveMenuColor = oColor
End Property
Public Property Let ActiveMenuColorOver(oColor As OLE_COLOR)
m_oActiveMenuColorOver = oColor
End Property
Public Property Let InActiveMenuColor(oColor As OLE_COLOR)
m_oInActiveMenuColor = oColor
End Property
Private Sub Class_Initialize()
m_oActiveCaptionColor = &HCCCCCC
m_oInActiveCaptionColor = &H999999
m_oActiveMenuColor = &H0&
m_oActiveMenuColorOver = &H0&
m_oInActiveMenuColor = &H808080
m_oMenuBackgroundColor = &HFFFFFF
Set m_fnt = New StdFont
m_fnt.Name = "MS Sans Serif"
Set m_fntMenu = New StdFont
m_fntMenu.Name = "MS Sans Serif"
End Sub

Private Sub Class_Terminate()

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

73 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
'
End Sub

Private Function INCAreaModifier_AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long
INCAreaModifier_AltKeyAccelerator = m_cMenu.AltKeyAccelerator(vKey)
End Function

Private Sub INCAreaModifier_ExitMenuLoop()
m_cMenu.pRestoreList
End Sub

Private Sub INCAreaModifier_HitTest(ByVal x As Long, ByVal y As Long, eHitTest As ECNCHitTestConstants)
Dim bMouseOverClose As Boolean
Dim bMouseOverMaximise As Boolean
Dim bMouseOverMinimise As Boolean
Dim bBtnMouseDown As Boolean
Dim hdc As Long

'
Dim tR As RECT
tR.left = 12: tR.top = 11: tR.right = 42: tR.bottom = 43
If PtInRect(tR, x, y) <> 0 Then
eHitTest = HTSYSMENU
Exit Sub
End If

' Code for working out whether in the buttons or not:
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverClose = True
Else
bMouseOverClose = False
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverMaximise = True
Else
bMouseOverMaximise = False
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
eHitTest = HTSYSMENU
bMouseOverMinimise = True
Else
bMouseOverMinimise = False
End If
End If

hdc = GetWindowDC(m_hWnd)

bBtnMouseDown = GetAsyncKeyState(vbLeftButton)
If m_bClose Then
If Not (m_bMouseDownClose = bMouseOverClose) Then
If bMouseOverClose And bBtnMouseDown And m_bMouseDownClose Then
DrawButton hdc, 0, Down
Else
DrawButton hdc, 0, up
End If
End If
End If
If m_bMaximise Then
If Not (m_bMouseDownMaximise = bMouseOverMaximise) Then
If bMouseOverMaximise And bBtnMouseDown And m_bMouseDownMaximise Then
DrawButton hdc, 1, Down
Else
DrawButton hdc, 1, up
End If
End If
End If
If m_bMinimise Then
If Not (m_bMouseDownMinimise = bMouseOverMinimise) Then
If bMouseOverMinimise And bBtnMouseDown And m_bMouseDownMinimise Then
DrawButton hdc, 2, Down
Else
DrawButton hdc, 2, up
End If
End If
End If
ReleaseDC m_hWnd, hdc

End Sub

Private Property Get INCAreaModifier_hWnd() As Long
INCAreaModifier_hWnd = m_hWnd
End Property

Private Sub INCAreaModifier_InitMenuPopup(ByVal wParam As Long, ByVal lParam As Long)
' Set all the menu items to Owner-Draw:
' wParam = hMenu
m_cMenu.OwnerDrawMenu wParam
End Sub

Private Sub INCAreaModifier_NCMouseDown(ByVal x As Long, ByVal y As Long, bHandled As Boolean, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
' Redraw close button pressed:
DrawButton hdc, 0, Down
m_bMouseDownClose = True
bHandled = True
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
' Redraw maximise button pressed:
DrawButton hdc, 1, Down
m_bMouseDownMaximise = True
bHandled = True
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
' Redraw minimise button pressed:
DrawButton hdc, 2, Down
m_bMouseDownMinimise = True

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

74 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
bHandled = True
End If
End If

End Sub

Private Sub INCAreaModifier_NCMouseUp(ByVal x As Long, ByVal y As Long, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim lStyle As Long
If m_bClose Then
If PtInRect(m_tBtn(0), x, y) <> 0 Then
If m_bMouseDownClose Then
m_cNCS.SysCommand SC_CLOSE
End If
End If
End If
If m_bMaximise Then
If PtInRect(m_tBtn(1), x, y) <> 0 Then
If m_bMouseDownMaximise Then
' Redraw maximise button pressed:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
If ((lStyle And WS_MAXIMIZE) = WS_MAXIMIZE) Then
m_cNCS.SysCommand SC_RESTORE
Else
m_cNCS.SysCommand SC_MAXIMIZE
End If
End If
End If
End If
If m_bMinimise Then
If PtInRect(m_tBtn(2), x, y) <> 0 Then
If m_bMouseDownMinimise Then
m_cNCS.SysCommand SC_MINIMIZE
End If
End If
End If
DrawButton hdc, 0, up
DrawButton hdc, 1, up
DrawButton hdc, 2, up

m_bMouseDownMinimise = False
m_bMouseDownMaximise = False
m_bMouseDownClose = False

End Sub
Private Sub DrawButton(ByVal hdc As Long, ByVal iIndex As Long, ByVal eState As ECNCButtonStates)
Dim lY As Long
Dim lStyle As Long
If eState = Down Then
lY = m_lButtonHeight
Else
lY = 0
End If
Select Case iIndex
Case 0
If m_bClose Then
BitBlt hdc, m_tBtn(0).left, m_tBtn(0).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 241, lY, vbSrcCopy
End If
Case 1
If m_bMaximise Then
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
If ((lStyle And WS_MAXIMIZE) = WS_MAXIMIZE) Then
BitBlt hdc, m_tBtn(1).left, m_tBtn(1).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth, lY, vbSrcCopy
Else
BitBlt hdc, m_tBtn(1).left, m_tBtn(1).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth * 2, lY, vbSrcCopy
End If
End If
Case 2
If m_bMinimise Then
BitBlt hdc, m_tBtn(2).left, m_tBtn(2).top, m_lButtonWidth, m_lButtonHeight, m_cCaption.hdc, 240 + m_lButtonWidth * 3, lY, vbSrcCopy
End If
End Select
End Sub

Private Sub INCAreaModifier_NCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim lX As Long, lXE As Long
Dim lY As Long
Dim lW As Long, lH As Long, lRW As Long
Dim lT As Long
Dim lSrcDC As Long, lSrcX As Long, lSrcY As Long
Dim lOrgX As Long
Dim bNoMiddle As Boolean
Dim tR As RECT
Dim sCaption As String
Dim lLen As Long
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lStyle As Long
Dim lhDC As Long, lhDCB As Long
Dim hFntMenu As Long

LockWindowUpdate hdc
' Here we do the work!
tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom

' Ensure mem DCs are big enough to draw into:
m_cFF.Width = tR.right - tR.left + 1
m_cFF.Height = m_cCaption.Height
lhDC = m_cFF.hdc

m_cFFB.Width = m_cBorder.Width * 2
m_cFFB.Height = tR.bottom - tR.top + 1
lhDCB = m_cFFB.hdc

pOLEFontToLogFont m_fnt, hdc, tLF
If m_cNCS.WindowActive Then
tLF.lfWeight = FW_BOLD
End If
hFnt = CreateFontIndirect(tLF)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

75 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
hFntOld = SelectObject(lhDC, hFnt)

If m_cNCS.WindowActive Then
lOrgX = 0
Else
lOrgX = m_lInactiveOffset
End If
' Draw the caption
BitBlt lhDC, lLeft, lTop, lLeft + m_lActiveLeftEnd, m_cCaption.Height, m_cCaption.hdc, lOrgX, 0, vbSrcCopy
lRW = (m_lActiveRightEnd - m_lActiveRightStart + 1)
lXE = lRight - lRW + 1
If lXE < lLeft + lRW Then
lXE = lLeft + lRW
bNoMiddle = True
End If
BitBlt lhDC, lXE, lTop, lRW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveRightStart, 0, vbSrcCopy

' Buttons:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
m_bMaximise = ((lStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX)
m_bMinimise = ((lStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX)
m_bClose = ((lStyle And WS_SYSMENU) = WS_SYSMENU)
m_tBtn(0).left = lXE + lRW - m_cBorder.Height + 4
If m_bClose Then
m_tBtn(0).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(0).top = lTop + 5
m_tBtn(0).right = m_tBtn(0).left + m_lButtonWidth + 1
m_tBtn(0).bottom = m_tBtn(0).top + m_lButtonHeight
DrawButton lhDC, 0, up
End If
If m_bMaximise Then
m_tBtn(1).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(1).top = lTop + 5
m_tBtn(1).right = m_tBtn(1).left + m_lButtonWidth + 1
m_tBtn(1).bottom = m_tBtn(1).top + m_lButtonHeight
DrawButton lhDC, 1, up
Else
m_tBtn(1).left = m_tBtn(0).left
End If
If m_bMinimise Then
m_tBtn(2).left = m_tBtn(1).left - (m_lButtonWidth + 1)
m_tBtn(2).top = lTop + 5
m_tBtn(2).right = m_tBtn(2).left + (m_lButtonWidth + 1)
m_tBtn(2).bottom = m_tBtn(2).top + m_lButtonHeight
DrawButton lhDC, 2, up
End If

' Fill in:
lX = lLeft + 90
Do
lW = 52
If lX + 52 > lXE Then
lW = lXE - lX
End If
BitBlt lhDC, lX, 0, lW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveLeftEnd + 1, 0, vbSrcCopy
lX = lX + 52
Loop While lX < lXE

If Not bNoMiddle Then

' Draw the caption:
SetBkMode lhDC, TRANSPARENT
If m_cNCS.WindowActive Then
SetTextColor lhDC, TranslateColor(m_oActiveCaptionColor)
Else
SetTextColor lhDC, TranslateColor(m_oInActiveCaptionColor)
End If
lLen = GetWindowTextLength(m_hWnd)
If lLen > 0 Then
tR.left = lLeft + 92
tR.right = lRight - 96
tR.top = m_cBorder.Height + 1
tR.bottom = tR.top + (m_cCaption.Height - m_cBorder.Height - 2) \ 2
sCaption = String$(lLen + 1, 0)
GetWindowText m_hWnd, sCaption, lLen + 1
DrawText lhDC, sCaption, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_NOPREFIX
End If

End If

' Menu:
m_cMenu.hMenu = m_cNCS.hMenu
lW = lXE - m_lActiveLeftEnd
tLF.lfWeight = FW_NORMAL
hFntMenu = CreateFontIndirect(tLF)
m_cMenu.Render hFntMenu, lhDC, m_lActiveLeftEnd, m_cCaption.Height \ 2, lW, m_cCaption.Height \ 2, -m_cCaption.Height \ 2 + 2
DeleteObject hFntMenu

BitBlt hdc, 0, 0, m_cFF.Width, m_cFF.Height, lhDC, 0, 0, vbSrcCopy

' Draw the border:
lY = m_cCaption.Height
lH = m_cBorder.Height
lW = lH
lSrcDC = m_cBorder.hdc
lSrcX = lW * 4
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
' Draw to lhs:
BitBlt lhDCB, 0, lY + lTop, lW, lH, lSrcDC, 0, lSrcY, vbSrcCopy

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

76 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
' Draw to right:
BitBlt lhDCB, lW, lY + lTop, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
'Exit Do
If lSrcY = 0 Then
lSrcDC = lhDCB
lSrcY = lY + lTop
lSrcX = lW
lY = lY + lH
Else
lY = lY + lH
lH = lH * 2
End If
Loop While lY < lBottom - lW
lT = m_cCaption.Height + lTop
lH = lBottom - lT
BitBlt hdc, lLeft, lT, lW, lH, lhDCB, 0, lT, vbSrcCopy
BitBlt hdc, lRight - lW, lT, lW, lH, lhDCB, lW, lT, vbSrcCopy

lT = lBottom - lW
If lT < m_cCaption.Height Then
lT = m_cCaption.Height
End If

' Bottom - we draw into the caption mem dc for flicker free
lX = lLeft + lW
lH = m_cBorder.Height
lSrcDC = m_cBorder.hdc
lSrcX = lW * 3
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
BitBlt lhDC, lX, 0, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
If lSrcY = 0 Then
lSrcDC = lhDC
lSrcX = lX
lX = lX + lW
Else
lX = lX + lW
lW = lW * 2
End If
Loop While lX < lRight - lH
' Bottom corners
BitBlt lhDC, lLeft, 0, lH, lH, m_cBorder.hdc, lH * 2, 0, vbSrcCopy
BitBlt lhDC, lRight - lH, 0, lH, lH, m_cBorder.hdc, lH * 6, 0, vbSrcCopy

' Swap out to display:
BitBlt hdc, lLeft, lT, m_cFF.Width, lH, lhDC, 0, 0, vbSrcCopy

SelectObject lhDC, hFntOld
DeleteObject hFnt
LockWindowUpdate 0
End Sub

Private Sub INCAreaModifier_GetBottomMarginHeight(cy As Long)
'
cy = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetLeftMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetRightMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetTopMarginHeight(cy As Long)
'
cy = m_cCaption.Height
End Sub

' Convert Automation color to Windows color
Private Function TranslateColor(ByVal clr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
If OleTranslateColor(clr, hPal, TranslateColor) Then
TranslateColor = CLR_INVALID
End If
End Function

Private Sub pOLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer
Dim b() As Byte

' Convert an OLE StdFont to a LOGFONT structure:
With tLF
sFont = fntThis.Name
b = StrConv(sFont, vbFromUnicode)
For iChar = 1 To Len(sFont)
.lfFaceName(iChar - 1) = b(iChar - 1)
Next iChar
' Based on the Win32SDK documentation:
.lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
.lfItalic = fntThis.Italic
If (fntThis.Bold) Then
.lfWeight = FW_BOLD
Else
.lfWeight = FW_NORMAL
End If
.lfUnderline = fntThis.Underline
.lfStrikeOut = fntThis.Strikethrough
.lfCharSet = fntThis.Charset
End With

End Sub

--------------
Option Explicit
Private iInterval As Long
Private id As Long

' User can attach any Variant data they want to the timer
Public Item As Variant

Public Event ThatTime()

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

Public Enum EErrorTimer
eeBaseTimer = 13650 ' CTimer
eeTooManyTimers ' No more than 10 timers allowed per class
eeCantCreateTimer ' Can't create system timer

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

77 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
End Enum

Friend Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.EXEName & ".WindowProc"
Select Case e
Case eeTooManyTimers
sText = "No more than 10 timers allowed per class"
Case eeCantCreateTimer
sText = "Can't create system timer"
End Select
Err.Raise e Or vbObjectError, sSource, sText
Else
' Raise standard Visual Basic error
Err.Raise e, sSource
End If
End Sub

Property Get Interval() As Long
Interval = iInterval
End Property

' Can't just change interval--you must kill timer and start a new one
Property Let Interval(iIntervalA As Long)
Dim f As Boolean
If iIntervalA > 0 Then
' Don't mess with it if interval is the same
If iInterval = iIntervalA Then Exit Property
' Must destroy any existing timer to change interval
If iInterval Then
f = TimerDestroy(Me)
Debug.Assert f ' Shouldn't fail
End If
' Create new timer with new interval
iInterval = iIntervalA
If TimerCreate(Me) = False Then ErrRaise eeCantCreateTimer
Else
If (iInterval > 0) Then
iInterval = 0
f = TimerDestroy(Me)
Debug.Assert f ' Shouldn't fail
End If
End If
End Property

' Must be public so that Timer object can't terminate while client's ThatTime
' event is being processed--Friend wouldn't prevent this disaster
Public Sub PulseTimer()
RaiseEvent ThatTime
End Sub

Friend Property Get TimerID() As Long
TimerID = id
End Property

Friend Property Let TimerID(idA As Long)
id = idA
End Property

Private Sub Class_Terminate()
Interval = 0
End Sub

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

' =======================================================================
' FileName: cToolbarMenu
' Author: Steve McMahon
' Date: 8 Feb 2000
'
' Allows menus to pop up and cancel as the user hovers
' over toolbar buttons.
'
'
' Copyright ?2000 Steve McMahon
' =======================================================================

Private Enum TRACKINGSTATE '{ // menubar has three states:
TRACK_NONE = 0 ', // * normal, not tracking anything
TRACK_BUTTON ', // * tracking buttons (F10/Alt mode)
TRACK_POPUP '// * tracking popups
End Enum

' Track popup menu constants:

Private m_iTrackingState As TRACKINGSTATE
Private m_bProcessRightArrow As Boolean
Private m_bProcessLeftArrow As Boolean
Private m_hMenuTracking As Long
Private m_iPopupTracking As Long
Private m_bEscapeWasPressed As Boolean
Private m_tPMouse As POINTAPI
Private m_iNewPopup As Long
Private m_bIn As Boolean

Private m_hWnd As Long
Private m_lPtr As Long

Private m_iExit As Integer

Implements ISubclass

Friend Sub CoolMenuAttach(ByRef hWndA As Long, ByVal cBar As cMenuBar)
Dim lPtr As Long

m_iExit = 0
CoolMenuDetach
m_hWnd = hWndA
SendMessageLong m_hWnd, WM_ENTERMENULOOP, 0, 0
AttachMessage Me, m_hWnd, WM_MENUSELECT
m_lPtr = ObjPtr(cBar)

End Sub
Friend Sub CoolMenuDetach()
If (m_hWnd <> 0) Then
SendMessageLong m_hWnd, WM_EXITMENULOOP, 0, 0
DetachMessage Me, m_hWnd, WM_MENUSELECT
m_hWnd = 0
End If
m_hWnd = 0

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

78 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
m_lPtr = 0
End Sub

'/////////////////
'// When user selects a new menu item, note whether it has a submenu
'// and/or parent menu, so I know whether right/left arrow should
'// move to the next popup.
'//
Private Sub MenuSelect(ByVal hMenu As Long, ByVal iItem As Long)
If (m_iTrackingState > 0) Then
'// process right-arrow if item is NOT a submenu
m_bProcessRightArrow = (GetSubMenu(hMenu, iItem) = 0)
'// process left-arrow if curent menu is one I'm tracking
m_bProcessLeftArrow = (hMenu = m_hMenuTracking)
End If
End Sub

'//////////////////
'// Handle menu input event: Look for left/right to change popup menu,
'// mouse movement over over a different menu button for "hot" popup effect.
'// Returns TRUE if message handled (to eat it).
'//
Friend Function MenuInput(m As Msg) As Boolean
Dim iMsg As Long
Dim vKey As Long
Dim tP As POINTAPI
Dim iButton As Long

'ASSERT_VALID(this);
Debug.Assert m_iTrackingState = TRACK_POPUP '; // sanity check
iMsg = m.message

If (iMsg = WM_KEYDOWN) Then

'// handle left/right-arow.
vKey = m.wParam
If ((vKey = vbKeyLeft And m_bProcessLeftArrow) Or _
(vKey = vbKeyRight And m_bProcessRightArrow)) Then

'MBTRACE(_T("CMenuBar::OnMenuInput: handle VK_LEFT/RIGHT\n"));
CancelMenuAndTrackNewOne _
GetNextOrPrevButton(m_iPopupTracking, vKey = vbKeyLeft)
MenuInput = True ' // eat it

' // escape:
ElseIf (vKey = vbKeyEscape) Then
m_bEscapeWasPressed = True '; // (menu will abort itself)
End If

ElseIf (iMsg = WM_MOUSEMOVE Or iMsg = WM_LBUTTONDOWN) Then
'// handle mouse move or click
LSet tP = m.pt
'ScreenToClient m_hWndBand, tP

If (iMsg = WM_MOUSEMOVE) Then
'If (tP.X <> m_tPMouse.X) And (tP.Y <> m_tPMouse.Y) Then
iButton = HitTest(tP)
If IsValidButton(iButton) Then
If iButton <> m_iPopupTracking Then
'// user moved mouse over a different button: track its popup
CancelMenuAndTrackNewOne iButton
End If
End If
LSet m_tPMouse = tP
'End If
ElseIf iMsg = WM_LBUTTONDOWN Then
If (HitTest(tP) = m_iPopupTracking) Then
'// user clicked on same button I am tracking: cancel menu
'MBTRACE(_T("CMenuBar:OnMenuInput: handle mouse click to exit popup\n"));
CancelMenuAndTrackNewOne -1
MenuInput = True ' // eat it
End If
End If

ElseIf iMsg = WM_LBUTTONUP Or iMsg = WM_RBUTTONUP Then

End If

End Function

Private Function HitTest(pt As POINTAPI) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
HitTest = cBar.HitTest(pt)
End If

End Function
Private Property Get IsValidButton(ByVal iButton As Long) As Boolean
If (iButton > 0) Then
IsValidButton = True
End If
End Property

'//////////////////
'// Cancel the current popup menu by posting WM_CANCELMODE, and track a new
'// menu. iNewPopup is which new popup to track (-1 to quit).
'//
Private Sub CancelMenuAndTrackNewOne(ByVal iNewPopup As Long)
Dim cBar As cMenuBar
Dim hMenuPopup As Long
'MBTRACE(_T("CMenuBar::CancelMenuAndTrackNewOne: %d\n"), iNewPopup);
'ASSERT_VALID(this);
If iNewPopup > 0 Then
If (iNewPopup <> m_iPopupTracking) Then
If GetBar(cBar) Then
hMenuPopup = cBar.GetMenuHandle(iNewPopup)
If hMenuPopup <> 0 Then
'PostMessage m_hWndOwner, WM_CANCELMODE, 0, 0 ' // quit menu loop
PostMessage m_hWnd, WM_CANCELMODE, 0, 0
m_iNewPopup = iNewPopup '// go to this popup (-1 = quit)
End If
End If
End If
End If
End Sub

'//////////////////
'// Track the popup submenu associated with the i'th button in the menu bar.
'// This fn actually goes into a loop, tracking different menus until the user
'// selects a command or exits the menu.
'//
Friend Function TrackPopup(ByVal iButton As Long) As Long
Dim nMenuItems As Long
Dim tPM As TPMPARAMS
Dim rcButton As RECT
Dim pt As POINTAPI
Dim hMenuPopup As Long
Dim lR As Long
Dim hwnd As Long
Dim lRtnID As Long
Dim cBar As cMenuBar

LockWindowUpdate hdc
' Here we do the work!
tR.left = lLeft
tR.top = lTop
tR.right = lRight
tR.bottom = lBottom

' Ensure mem DCs are big enough to draw into:
m_cFF.Width = tR.right - tR.left + 1
m_cFF.Height = m_cCaption.Height
lhDC = m_cFF.hdc

m_cFFB.Width = m_cBorder.Width * 2
m_cFFB.Height = tR.bottom - tR.top + 1
lhDCB = m_cFFB.hdc

pOLEFontToLogFont m_fnt, hdc, tLF
If m_cNCS.WindowActive Then
tLF.lfWeight = FW_BOLD
End If
hFnt = CreateFontIndirect(tLF)
hFntOld = SelectObject(lhDC, hFnt)

If m_cNCS.WindowActive Then
lOrgX = 0
Else
lOrgX = m_lInactiveOffset
End If
' Draw the caption
BitBlt lhDC, lLeft, lTop, lLeft + m_lActiveLeftEnd, m_cCaption.Height, m_cCaption.hdc, lOrgX, 0, vbSrcCopy
lRW = (m_lActiveRightEnd - m_lActiveRightStart + 1)
lXE = lRight - lRW + 1
If lXE < lLeft + lRW Then
lXE = lLeft + lRW
bNoMiddle = True
End If
BitBlt lhDC, lXE, lTop, lRW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveRightStart, 0, vbSrcCopy

' Buttons:
lStyle = GetWindowLong(m_hWnd, GWL_STYLE)
m_bMaximise = ((lStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX)
m_bMinimise = ((lStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX)
m_bClose = ((lStyle And WS_SYSMENU) = WS_SYSMENU)
m_tBtn(0).left = lXE + lRW - m_cBorder.Height + 4
If m_bClose Then
m_tBtn(0).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(0).top = lTop + 5
m_tBtn(0).right = m_tBtn(0).left + m_lButtonWidth + 1
m_tBtn(0).bottom = m_tBtn(0).top + m_lButtonHeight
DrawButton lhDC, 0, up
End If
If m_bMaximise Then
m_tBtn(1).left = m_tBtn(0).left - (m_lButtonWidth + 1)
m_tBtn(1).top = lTop + 5
m_tBtn(1).right = m_tBtn(1).left + m_lButtonWidth + 1
m_tBtn(1).bottom = m_tBtn(1).top + m_lButtonHeight
DrawButton lhDC, 1, up
Else
m_tBtn(1).left = m_tBtn(0).left
End If
If m_bMinimise Then
m_tBtn(2).left = m_tBtn(1).left - (m_lButtonWidth + 1)
m_tBtn(2).top = lTop + 5
m_tBtn(2).right = m_tBtn(2).left + (m_lButtonWidth + 1)
m_tBtn(2).bottom = m_tBtn(2).top + m_lButtonHeight
DrawButton lhDC, 2, up
End If

' Fill in:
lX = lLeft + 90
Do
lW = 52
If lX + 52 > lXE Then
lW = lXE - lX
End If
BitBlt lhDC, lX, 0, lW, m_cCaption.Height, m_cCaption.hdc, lOrgX + m_lActiveLeftEnd + 1, 0, vbSrcCopy
lX = lX + 52
Loop While lX < lXE

If Not bNoMiddle Then

' Draw the caption:
SetBkMode lhDC, TRANSPARENT
If m_cNCS.WindowActive Then
SetTextColor lhDC, TranslateColor(m_oActiveCaptionColor)
Else
SetTextColor lhDC, TranslateColor(m_oInActiveCaptionColor)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

80 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
End If
lLen = GetWindowTextLength(m_hWnd)
If lLen > 0 Then
tR.left = lLeft + 92
tR.right = lRight - 96
tR.top = m_cBorder.Height + 1
tR.bottom = tR.top + (m_cCaption.Height - m_cBorder.Height - 2) \ 2
sCaption = String$(lLen + 1, 0)
GetWindowText m_hWnd, sCaption, lLen + 1
DrawText lhDC, sCaption, -1, tR, DT_LEFT Or DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_NOPREFIX
End If

End If

' Menu:
m_cMenu.hMenu = m_cNCS.hMenu
lW = lXE - m_lActiveLeftEnd
tLF.lfWeight = FW_NORMAL
hFntMenu = CreateFontIndirect(tLF)
m_cMenu.Render hFntMenu, lhDC, m_lActiveLeftEnd, m_cCaption.Height \ 2, lW, m_cCaption.Height \ 2, -m_cCaption.Height \ 2 + 2
DeleteObject hFntMenu

BitBlt hdc, 0, 0, m_cFF.Width, m_cFF.Height, lhDC, 0, 0, vbSrcCopy

' Draw the border:
lY = m_cCaption.Height
lH = m_cBorder.Height
lW = lH
lSrcDC = m_cBorder.hdc
lSrcX = lW * 4
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
' Draw to lhs:
BitBlt lhDCB, 0, lY + lTop, lW, lH, lSrcDC, 0, lSrcY, vbSrcCopy
' Draw to right:
BitBlt lhDCB, lW, lY + lTop, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
'Exit Do
If lSrcY = 0 Then
lSrcDC = lhDCB
lSrcY = lY + lTop
lSrcX = lW
lY = lY + lH
Else
lY = lY + lH
lH = lH * 2
End If
Loop While lY < lBottom - lW
lT = m_cCaption.Height + lTop
lH = lBottom - lT
BitBlt hdc, lLeft, lT, lW, lH, lhDCB, 0, lT, vbSrcCopy
BitBlt hdc, lRight - lW, lT, lW, lH, lhDCB, lW, lT, vbSrcCopy

lT = lBottom - lW
If lT < m_cCaption.Height Then
lT = m_cCaption.Height
End If

' Bottom - we draw into the caption mem dc for flicker free
lX = lLeft + lW
lH = m_cBorder.Height
lSrcDC = m_cBorder.hdc
lSrcX = lW * 3
lSrcY = 0
' We draw double the amount each time for a quick finish:
Do
BitBlt lhDC, lX, 0, lW, lH, lSrcDC, lSrcX, lSrcY, vbSrcCopy
If lSrcY = 0 Then
lSrcDC = lhDC
lSrcX = lX
lX = lX + lW
Else
lX = lX + lW
lW = lW * 2
End If
Loop While lX < lRight - lH
' Bottom corners
BitBlt lhDC, lLeft, 0, lH, lH, m_cBorder.hdc, lH * 2, 0, vbSrcCopy
BitBlt lhDC, lRight - lH, 0, lH, lH, m_cBorder.hdc, lH * 6, 0, vbSrcCopy

' Swap out to display:
BitBlt hdc, lLeft, lT, m_cFF.Width, lH, lhDC, 0, 0, vbSrcCopy

SelectObject lhDC, hFntOld
DeleteObject hFnt
LockWindowUpdate 0
End Sub

Private Sub INCAreaModifier_GetBottomMarginHeight(cy As Long)
'
cy = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetLeftMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetRightMarginWidth(cx As Long)
'
cx = m_cBorder.Height
End Sub

Private Sub INCAreaModifier_GetTopMarginHeight(cy As Long)
'
cy = m_cCaption.Height
End Sub

Private Sub pOLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

81 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
Dim sFont As String
Dim iChar As Integer
Dim b() As Byte

End Sub

--------------
Option Explicit
Private iInterval As Long
Private id As Long

' User can attach any Variant data they want to the timer
Public Item As Variant

Public Event ThatTime()

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

Public Enum EErrorTimer
eeBaseTimer = 13650 ' CTimer
eeTooManyTimers ' No more than 10 timers allowed per class
eeCantCreateTimer ' Can't create system timer
End Enum

Property Get Interval() As Long
Interval = iInterval
End Property

' Must be public so that Timer object can't terminate while client's ThatTime
' event is being processed--Friend wouldn't prevent this disaster
Public Sub PulseTimer()
RaiseEvent ThatTime
End Sub

Friend Property Get TimerID() As Long
TimerID = id
End Property

Friend Property Let TimerID(idA As Long)
id = idA
End Property

Private Sub Class_Terminate()
Interval = 0
End Sub

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

Private Enum TRACKINGSTATE '{ // menubar has three states:

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

82 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
TRACK_NONE = 0 ', // * normal, not tracking anything
TRACK_BUTTON ', // * tracking buttons (F10/Alt mode)
TRACK_POPUP '// * tracking popups
End Enum

' Track popup menu constants:

Private m_hWnd As Long
Private m_lPtr As Long

Private m_iExit As Integer

Implements ISubclass

Friend Sub CoolMenuAttach(ByRef hWndA As Long, ByVal cBar As cMenuBar)
Dim lPtr As Long

'ASSERT_VALID(this);
Debug.Assert m_iTrackingState = TRACK_POPUP '; // sanity check
iMsg = m.message

If (iMsg = WM_KEYDOWN) Then

'// handle left/right-arow.
vKey = m.wParam
If ((vKey = vbKeyLeft And m_bProcessLeftArrow) Or _
(vKey = vbKeyRight And m_bProcessRightArrow)) Then

If (iMsg = WM_MOUSEMOVE) Then
'If (tP.X <> m_tPMouse.X) And (tP.Y <> m_tPMouse.Y) Then
iButton = HitTest(tP)
If IsValidButton(iButton) Then
If iButton <> m_iPopupTracking Then
'// user moved mouse over a different button: track its popup
CancelMenuAndTrackNewOne iButton
End If
End If
LSet m_tPMouse = tP
'End If
ElseIf iMsg = WM_LBUTTONDOWN Then

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

83 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
If (HitTest(tP) = m_iPopupTracking) Then
'// user clicked on same button I am tracking: cancel menu
'MBTRACE(_T("CMenuBar:OnMenuInput: handle mouse click to exit popup\n"));
CancelMenuAndTrackNewOne -1
MenuInput = True ' // eat it
End If
End If

ElseIf iMsg = WM_LBUTTONUP Or iMsg = WM_RBUTTONUP Then

End If

End Function

Private Function HitTest(pt As POINTAPI) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
HitTest = cBar.HitTest(pt)
End If

End Function
Private Property Get IsValidButton(ByVal iButton As Long) As Boolean
If (iButton > 0) Then
IsValidButton = True
End If
End Property

If Not m_bIn Then
m_bIn = True
m_iNewPopup = iButton
'Debug.Assert m_hMenu <> 0
If GetBar(cBar) Then

nMenuItems = cBar.Count 'GetMenuItemCount(m_hMenu)

Do While (m_iNewPopup > -1) '// while user selects another menu

lRtnID = 0

m_iNewPopup = -1 '// assume quit after this
PressButton iButton, True '// press the button
'UpdateWindow ToolbarhWnd(m_hWnd) '// and force repaint now

SetTrackingState TRACK_POPUP, iButton '// enter tracking state

'// Need to install a hook to trap menu input in order to make
'// left/right-arrow keys and "hot" mouse tracking work.
'//
AttachMsgHook Me

'// get submenu and display it beneath button
GetRect iButton, rcButton
'ClientRectToScreen m_hWndBand, rcButton
tPM.cbSize = Len(tPM)
ComputeMenuTrackPoint rcButton, tPM, pt

'hMenuPopup = GetSubMenu(m_hMenu, iButton)
hMenuPopup = cBar.GetMenuHandle(iButton)

If hMenuPopup <> 0 Then
' Show the menu:
m_hMenuTracking = hMenuPopup
lR = TrackPopupMenuEx(hMenuPopup, _
TPM_LEFTALIGN Or TPM_LEFTBUTTON Or TPM_VERTICAL, _
pt.x, pt.y, m_hWnd, tPM)
'lR is the ID of the menu
lRtnID = lR
End If

'// uninstall hook.
DetachMsgHook

PressButton iButton, False '; // un-press button

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

84 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
'UpdateWindow ToolbarhWNd(m_hWnd) '// and force repaint now

'// If the user exited the menu loop by pressing Escape,
'// return to track-button state; otherwise normal non-tracking state.
If (m_bEscapeWasPressed) Then
SetTrackingState TRACK_NONE, iButton
Else
SetTrackingState TRACK_NONE, iButton
End If

'// If the user moved mouse to a new top-level popup (eg from File to
'// Edit button), I will have posted a WM_CANCELMODE to quit
'// the first popup, and set m_iNewPopup to the new menu to show.
'// Otherwise, m_iNewPopup will be -1 as set above.
'// So just set iButton to the next popup menu and keep looping...
iButton = m_iNewPopup

Loop

' Set hot button if mouse is over, otherwise not:

' The ID of the selected menu
TrackPopup = lRtnID
End If
m_bIn = False
End If
End Function
Private Sub ComputeMenuTrackPoint(ByRef rc As RECT, tPM As TPMPARAMS, tP As POINTAPI)
tP.x = rc.left
tP.y = rc.bottom
LSet tPM.rcExclude = rc
End Sub

Private Function GetBar(ByRef cBar As cMenuBar) As Boolean
If Not m_lPtr = 0 Then
Set cBar = ObjectFromPtr(m_lPtr)
'Debug.Print "GetBar:OK"
GetBar = True
End If
End Function

Private Sub PressButton(ByVal iButton As Long, ByVal bState As Boolean)
Dim fState As Long
Dim cBar As cMenuBar

If GetBar(cBar) Then
If iButton > 0 And iButton <= cBar.Count Then
cBar.PressButton iButton, bState
End If
End If

End Sub

Private Sub GetRect(ByVal iButton As Long, ByRef tR As RECT)
Dim cBar As cMenuBar
tR.left = 0: tR.top = 0: tR.bottom = 0: tR.right = 0
If GetBar(cBar) Then
If iButton > 0 And iButton <= cBar.Count Then
cBar.GetRect iButton, tR
End If
End If
End Sub
Private Function GetHotItem() As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
GetHotItem = cBar.HotItem
End If
End Function
Private Function SetHotItem(ByVal iButton As Long) As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
'Debug.Print "Setting hot item: " & iButton
cBar.HotItem = iButton
End If
End Function
Private Function GetButtonVisible(ByVal iButton As Long) As Boolean
GetButtonVisible = True
End Function
Private Function GetButtonCount() As Long
Dim cBar As cMenuBar
If GetBar(cBar) Then
GetButtonCount = cBar.Count
End If
End Function

Private Sub SetTrackingState(ByVal iState As TRACKINGSTATE, ByVal iButton As Long)
If (iState <> m_iTrackingState) Then
If (iState = TRACK_NONE) Then
iButton = -1
End If
'#ifdef _DEBUG
' static LPCTSTR StateName[] = { _T("NONE"), _T("BUTTON"), _T("POPUP") };
' MBTRACE(_T("CMenuBar::SetTrackingState to %s, button=%d\n"),
' StateName[iState], iButton);
'#End If

SetHotItem iButton '// could be none (-1)

If (iState = TRACK_POPUP) Then
'// set related state stuff
m_bEscapeWasPressed = False 'FALSE; // assume Esc key not pressed
m_bProcessRightArrow = True '// assume left/right arrow..
m_bProcessLeftArrow = True '; // ..will move to prev/next popup
m_iPopupTracking = iButton '// which popup I'm tracking
End If
m_iTrackingState = iState

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

85 回復:漂亮的VB程序窗體,打破傳統的Windows窗體。(強力推薦)
End If
End Sub

Private Function GetNextOrPrevButton(ByVal iButton As Long, ByVal bPrev As Boolean) As Long
Dim iSB As Long
Dim bfound As Boolean

If (bPrev) Then
iSB = iButton
Do While Not bfound

iButton = iButton - 1
If iButton < 1 Then
iButton = GetButtonCount()
End If

If Not (GetButtonVisible(iButton)) Then
If iButton = iSB Then
iButton = -1
Exit Do
End If
Else
bfound = True
End If

Loop

Else
iSB = iButton
Do While Not bfound
iButton = iButton + 1
If (iButton > GetButtonCount()) Then
iButton = 1
End If

If Not GetButtonVisible(iButton) Then
If iButton = iSB Then
iButton = -1
Exit Do
End If
Else
bfound = True
End If

Loop

End If
GetNextOrPrevButton = iButton
End Function
'//////////////////
'// Toggle state from home state to button-tracking and back
'//
Private Sub ToggleTrackButtonMode()
If (m_iTrackingState = TRACK_NONE Or m_iTrackingState = TRACK_BUTTON) Then
If m_iTrackingState = TRACK_NONE Then
SetTrackingState TRACK_BUTTON, 1
Else
SetTrackingState TRACK_NONE, 1
End If
End If
End Sub

Private Property Get ISubclass_MsgResponse() As EMsgResponse
If CurrentMessage = WM_MENUSELECT Then
ISubclass_MsgResponse = emrPreprocess
End If
End Property

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

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case iMsg
Case WM_MENUSELECT
MenuSelect lParam, (wParam And &HFFFF&)
End Select
End Function

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

Sub AttachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
MSubclass.AttachMessage iwp, hwnd, iMsg
End Sub

Sub DetachMessage(iwp As ISubclass, ByVal hwnd As Long, _
ByVal iMsg As Long)
MSubclass.DetachMessage iwp, hwnd, iMsg
End Sub

Public Property Get CurrentMessage() As Long
CurrentMessage = MSubclass.CurrentMessage
End Property
Public Function CallOldWindowProc( _
ByVal hwnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
CallOldWindowProc = MSubclass.CallOldWindowProc(hwnd, iMsg, wParam, lParam)
End Function

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

Public Property Get hwnd() As Long

End Property
Public Sub GetTopMarginHeight(cy As Long)

End Sub
Public Sub GetLeftMarginWidth(cx As Long)

End Sub
Public Sub GetRightMarginWidth(cx As Long)

End Sub
Public Sub GetBottomMarginHeight(cy As Long)

End Sub
Public Sub NCPaint(ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub HitTest(ByVal x As Long, ByVal y As Long, ByRef eHitTest As ECNCHitTestConstants)

End Sub
Public Sub NCMouseDown(ByVal x As Long, ByVal y As Long, ByRef bHandled As Boolean, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub NCMouseUp(ByVal x As Long, ByVal y As Long, ByVal hdc As Long, ByVal lLeft As Long, ByVal lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)

End Sub
Public Sub InitMenuPopup(ByVal wParam As Long, ByVal lParam As Long)

End Sub
Public Sub ExitMenuLoop()

End Sub
Public Function AltKeyAccelerator(ByVal vKey As KeyCodeConstants) As Long

End Function

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

Public Enum EMsgResponse
emrConsume ' Process instead of original WindowProc
emrPostProcess ' Process after original WindowProc
emrPreprocess ' Process before original WindowProc
End Enum

Public MsgResponse As EMsgResponse

Function WindowProc(ByVal hwnd As Long, _
ByVal iMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
End Functio

作者: 61.142.212.* 2005-10-28 21:34 　回復此發言

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

86 調用 API 實現 Ani 窗體。
Option Explicit

Private Sub Form_Load()
Load frmAnim
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload frmAnim
End Sub

Private Sub cmdSlide_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_HOR_POSITIVE + AW_VER_POSITIVE + AW_SLIDE + AW_ACTIVATE

End Sub

Private Sub cmdExpand_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_CENTER + AW_SLIDE + AW_ACTIVATE

End Sub

Private Sub cmdFade_Click()

frmAnim.Move 300, 300

AnimateWindow frmAnim.hWnd, 300, _
AW_BLEND + AW_ACTIVATE

End Sub

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

Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
lpRect As RECT, ByVal hBrush As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Friend Sub PrintClient(ByVal hDC As Long, ByVal lParam As Long)

Dim rct As RECT
Dim hBr As Long

'Fill in the hDC with the form's
'background color. Otherwise the form
'may appear strangely.
rct.Left = 0
rct.Top = 0
rct.Right = ScaleX(ScaleWidth, ScaleMode, vbPixels)
rct.Bottom = ScaleY(ScaleHeight, ScaleMode, vbPixels)
hBr = CreateSolidBrush(TranslateColor(Me.BackColor))
FillRect hDC, rct, hBr
DeleteObject hBr

End Sub

Private Sub Form_Load()
SubclassAnim Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
UnSubclassAnim Me
End Sub

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

Public Const AW_HOR_POSITIVE = &H1
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_VER_NEGATIVE = &H8
Public Const AW_CENTER = &H10
Public Const AW_HIDE = &H10000
Public Const AW_ACTIVATE = &H20000
Public Const AW_SLIDE = &H40000
Public Const AW_BLEND = &H80000
Public Declare Function AnimateWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal dwTime As Long, ByVal dwFlags As Long) As Long

Public Const WM_PRINTCLIENT = &H318

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

Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)

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

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

Public Declare Function OleTranslateColor _
Lib "oleaut32.dll" _
(ByVal lOleColor As Long, _
ByVal lHPalette As Long, _
lColorRef As Long) As Long

Public Function TranslateColor(inCol As Long) As Long

Dim retCol As Long
OleTranslateColor inCol, 0&, retCol
TranslateColor = retCol
End Function

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

Dim lProc As Long
Dim lPtr As Long
Dim frm As frmAnim

lProc = GetProp(hWnd, "ExAnimWndProc")
lPtr = GetProp(hWnd, "ExAnimWndPtr")

'Catch the WM_PRINTCLIENT message so the form
'won't look like garbage when it appears.
If wMsg = WM_PRINTCLIENT Then
CopyMemory frm, lPtr, 4
frm.PrintClient wParam, lParam
CopyMemory frm, 0&, 4
End If

AnimWndProc = CallWindowProc(lProc, hWnd, wMsg, wParam, lParam)

End Function

Public Sub SubclassAnim(frm As frmAnim)

Dim l As Long

If GetProp(frm.hWnd, "ExAnimWndProc") <> 0 Then
'Already subclassed
Exit Sub
End If

l = GetWindowLong(frm.hWnd, GWL_WNDPROC)
SetProp frm.hWnd, "ExAnimWndProc", l
SetProp frm.hWnd, "ExAnimWndPtr", ObjPtr(frm)

SetWindowLong frm.hWnd, GWL_WNDPROC, AddressOf AnimWndProc

End Sub

Public Sub UnSubclassAnim(frm As frmAnim)

Dim l As Long

l = GetProp(frm.hWnd, "ExAnimWndProc")
If l = 0 Then
'Isn't subclassed anyway
Exit Sub
End If

SetWindowLong frm.hWnd, GWL_WNDPROC, l
RemoveProp frm.hWnd, "ExAnimWndProc"
RemoveProp frm.hWnd, "ExAnimWndPtr"

End Sub

作者: 61.142.212.* 2005-10-28 21:35 　回復此發言

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

87 API的“瀏覽”對話框。
Option Explicit

Dim nFolder& ' system folder to begin browse in
Dim CurOptIdx% ' currently selected option button

Private Sub Form_Load()

Dim idx&, item&
Dim rtn&, path$
Dim idl As ITEMIDLIST

For idx& = 1 To 17

' see BrowsDlg.bas for the system folder flag values
' The Desktop
If idx& = 1 Then
item& = 0

' Programs Folder -> Start Menu Folder
ElseIf idx& > 1 And idx& < 12 Then
item& = idx&

' Desktop Folder -> ShellNew Folder
ElseIf idx& >= 12 Then
item& = idx& + 4&
End If

' fill the idl structure with the specified folder item
rtn& = SHGetSpecialFolderLocation(Me.hWnd, item&, idl)
If rtn& = NOERROR Then

' if the structure is filled, initialize the var & get the path from the id list
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal idl.mkid.cb, ByVal path$)

' if a path was found in the structure, display it in the respective text box
If rtn& Then Text1(idx&) = path$
End If
Next

End Sub

Private Sub Option1_Click(Index As Integer)

' see the "bi.lpszTitle=..." line in Command1_Click

' save the current option btn for dialog banner display
CurOptIdx% = Index

' save the value of the system folder to begin dialog display from
If Index = 1 Then
nFolder& = 0
ElseIf Index < 12 Then
nFolder& = Index
Else
nFolder& = Index + 4
End If

End Sub

Private Sub Command1_Click()

Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, path$, pos%

' the calling app
bi.hOwner = Me.hWnd

' set the folder to limit the browse to in the dialog
' if CurOptIdx% = 0 (Default Browse), bi.pidlRoot would then be Null
If CurOptIdx% Then
rtn& = SHGetSpecialFolderLocation(ByVal Me.hWnd, ByVal nFolder&, idl)
bi.pidlRoot = idl.mkid.cb
End If

' set the banner text
bi.lpszTitle = "Browsing is limited to: " & Option1(CurOptIdx%).Caption

' set the type of folder to return
' play with these option constants to see what can be returned
bi.ulFlags = BIF_RETURNONLYFSDIRS 'BIF_RETURNFSANCESTORS 'BIF_BROWSEFORPRINTER + BIF_DONTGOBELOWDOMAIN

' show the browse folder dialog
pidl& = SHBrowseForFolder(bi)

' if displaying the return value, get the selected folder
If Check1 Then
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
If rtn& Then

' parce & display the folder selection
pos% = InStr(path$, Chr$(0))
MsgBox "Folder selection was:" & Chr$(10) & Chr$(10) & Left(path$, pos - 1), vbInformation
Else
MsgBox "Dialog was cancelled", vbInformation
End If
End If

End Sub

Private Sub Command2_Click()

Dim msg$, lf$
lf$ = Chr$(10)

msg$ = "If an item has no folder location displayed, then it has no Registry entry under:" & lf$ & lf$
msg$ = msg$ & "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders" & lf$ ' & lf$
'msg$ = msg$ & "If one of these items is selected from the Browse dialog, it will return 0 (cancelled) to the calling proc."
MsgBox msg$

End Sub

Private Sub Command3_Click()

Unload Me

作者: 61.142.212.* 2005-10-28 21:36 　回復此發言

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

88 API的“瀏覽”對話框。

End Sub

Private Sub Form_Unload(Cancel As Integer)

Set Form1 = Nothing

End Sub

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

' This code module & it's accompanying form module, BrowsDlg.frm,
' demonstrate how to display the "Browse for Folder" dialog box and
' return a user selected folder. The Win32 API structures, functions &
' constants used below are not documented for use with VB 4.0 (32 bit)
' in any conventional sense. The structures & functions were translated
' from the information available in the MSDN/VB Starter Kit. The constant
' values were extracted from the VC++ 4.0 Shlobg.h header file.
'
' For more information, in the MSDN/VB Starter Kit see the following:
' Product Documentation
' SDKs
' Win32 SDK
' Guides
' Programmer's Guide to Windows 95
' Extending the Windows 95 Shell

' Hope it comes in handy,
' Brad Martiez

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' A little info...
' Objects in the shell抯 namespace are assigned item identifiers and item
' identifier lists. An item identifier uniquely identifies an item within its parent
' folder. An item identifier list uniquely identifies an item within the shell抯
' namespace by tracing a path to the item from the desktop.

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' An item identifier is defined by the variable-length SHITEMID structure.
' The first two bytes of this structure specify its size, and the format of
' the remaining bytes depends on the parent folder, or more precisely
' on the software that implements the parent folder抯 IShellFolder interface.
' Except for the first two bytes, item identifiers are not strictly defined, and
' applications should make no assumptions about their format.
Type SHITEMID 'mkid
cb As Long 'Size of the ID (including cb itself)
abID As Byte 'The item ID (variable length)
End Type

' The ITEMIDLIST structure defines an element in an item identifier list
' (the only member of this structure is an SHITEMID structure). An item
' identifier list consists of one or more consecutive ITEMIDLIST structures
' packed on byte boundaries, followed by a 16-bit zero value. An application
' can walk a list of item identifiers by examining the size specified in each
' SHITEMID structure and stopping when it finds a size of zero. A pointer
' to an item identifier list, is sometimes called a PIDL (pronounced piddle)
Type ITEMIDLIST 'idl
mkid As SHITEMID
End Type

' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs ?for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

' Retrieves the location of a special (system) folder.
' Returns NOERROR if successful or an OLE-defined error result otherwise.
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

作者: 61.142.212.* 2005-10-28 21:36 　回復此發言

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

89 API的“瀏覽”對話框。

Public Const NOERROR = 0

' SHGetSpecialFolderLocation "nFolder" param:
' Value specifying the folder to retrieve the location of. This parameter
' can be one of the following values: Most folder locations are stored in:
' HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders

' Windows desktop ?virtual folder at the root of the name space.
Public Const CSIDL_DESKTOP = &H0

' File system directory that contains the user's program groups
' (which are also file system directories).
Public Const CSIDL_PROGRAMS = &H2

' Control Panel ?virtual folder containing icons for the control panel applications.
Public Const CSIDL_CONTROLS = &H3

' Printers folder ?virtual folder containing installed printers.
Public Const CSIDL_PRINTERS = &H4

' File system directory that serves as a common respository for documents.
Public Const CSIDL_PERSONAL = &H5 ' (Documents folder)

' File system directory that contains the user's favorite Internet Explorer URLs.
Public Const CSIDL_FAVORITES = &H6

' File system directory that corresponds to the user's Startup program group.
Public Const CSIDL_STARTUP = &H7

' File system directory that contains the user's most recently used documents.
Public Const CSIDL_RECENT = &H8 ' (Recent folder)

' File system directory that contains Send To menu items.
Public Const CSIDL_SENDTO = &H9

' Recycle bin ?file system directory containing file objects in the user's recycle bin.
' The location of this directory is not in the registry; it is marked with the hidden and
' system attributes to prevent the user from moving or deleting it.
Public Const CSIDL_BITBUCKET = &HA

' File system directory containing Start menu items.
Public Const CSIDL_STARTMENU = &HB

' File system directory used to physically store file objects on the desktop
' (not to be confused with the desktop folder itself).
Public Const CSIDL_DESKTOPDIRECTORY = &H10

' My Computer ?virtual folder containing everything on the local computer: storage
' devices, printers, and Control Panel. The folder may also contain mapped network drives.
Public Const CSIDL_DRIVES = &H11

' Network Neighborhood ?virtual folder representing the top level of the network hierarchy.
Public Const CSIDL_NETWORK = &H12

' File system directory containing objects that appear in the network neighborhood.
Public Const CSIDL_NETHOOD = &H13

' Virtual folder containing fonts.
Public Const CSIDL_FONTS = &H14

' File system directory that serves as a common repository for document templates.
Public Const CSIDL_TEMPLATES = &H15 ' (ShellNew folder)

'///////////////////////////////////////////////////////////////////////////////////////////////////////////

' Displays a dialog box that enables the user to select a shell folder.
' Returns a pointer to an item identifier list that specifies the location
' of the selected folder relative to the root of the name space. If the user
' chooses the Cancel button in the dialog box, the return value is NULL.
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST

作者: 61.142.212.* 2005-10-28 21:36 　回復此發言

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

90 API的“瀏覽”對話框。

' Contains parameters for the the SHBrowseForFolder function and receives
' information about the folder selected by the user.
Public Type BROWSEINFO 'bi

' Handle of the owner window for the dialog box.
hOwner As Long

' Pointer to an item identifier list (an ITEMIDLIST structure) specifying the location
' of the "root" folder to browse from. Only the specified folder and its subfolders
' appear in the dialog box. This member can be NULL, and in that case, the
' name space root (the desktop folder) is used.
pidlRoot As Long

' Pointer to a buffer that receives the display name of the folder selected by the
' user. The size of this buffer is assumed to be MAX_PATH bytes.
pszDisplayName As String

' Pointer to a null-terminated string that is displayed above the tree view control
' in the dialog box. This string can be used to specify instructions to the user.
lpszTitle As String

' Value specifying the types of folders to be listed in the dialog box as well as
' other options. This member can include zero or more of the following values below.
ulFlags As Long

' Address an application-defined function that the dialog box calls when events
' occur. For more information, see the description of the BrowseCallbackProc
' function. This member can be NULL.
lpfn As Long

' Application-defined value that the dialog box passes to the callback function
' (if one is specified).
lParam As Long

' Variable that receives the image associated with the selected folder. The image
' is specified as an index to the system image list.
iImage As Long

End Type

' BROWSEINFO.ulFlags values:
' Value specifying the types of folders to be listed in the dialog box as well as
' other options. This member can include zero or more of the following values:

' Only returns file system directories. If the user selects folders
' that are not part of the file system, the OK button is grayed.
Public Const BIF_RETURNONLYFSDIRS = &H1

' Does not include network folders below the domain level in the tree view control.
' For starting the Find Computer
Public Const BIF_DONTGOBELOWDOMAIN = &H2

' Includes a status area in the dialog box. The callback function can set
' the status text by sending messages to the dialog box.
Public Const BIF_STATUSTEXT = &H4

' Only returns file system ancestors. If the user selects anything other
' than a file system ancestor, the OK button is grayed.
Public Const BIF_RETURNFSANCESTORS = &H8

' Only returns computers. If the user selects anything other
' than a computer, the OK button is grayed.
Public Const BIF_BROWSEFORCOMPUTER = &H1000

' Only returns (network) printers. If the user selects anything other
' than a printer, the OK button is grayed.
Public Const BIF_BROWSEFORPRINTER = &H2000

作者: 61.142.212.* 2005-10-28 21:36 　回復此發言

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

91 把外部程序作為MDI窗口打開。
Option Explicit

Private Const GW_HWNDNEXT = 2

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private old_parent As Long
Private child_hwnd As Long

' Return the window handle for an instance handle.
Private Function InstanceToWnd(ByVal target_pid As Long) As Long
Dim test_hwnd As Long
Dim test_pid As Long
Dim test_thread_id As Long

' Get the first window handle.
test_hwnd = FindWindow(ByVal 0&, ByVal 0&)

' Loop until we find the target or we run out
' of windows.
Do While test_hwnd <> 0
' See if this window has a parent. If not,
' it is a top-level window.
If GetParent(test_hwnd) = 0 Then
' This is a top-level window. See if
' it has the target instance handle.
test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)

If test_pid = target_pid Then
' This is the target.
InstanceToWnd = test_hwnd
Exit Do
End If
End If

' Examine the next window.
test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
Loop
End Function

Private Sub cmdFree_Click()
SetParent child_hwnd, old_parent

cmdRun.Enabled = True
cmdFree.Enabled = False
End Sub

Private Sub cmdRun_Click()
Dim pid As Long
Dim buf As String
Dim buf_len As Long
Dim styles As Long

' Start the program.
pid = Shell(txtProgram.Text, vbNormalFocus)
If pid = 0 Then
MsgBox "Error starting program"
Exit Sub
End If

' Get the window handle.
child_hwnd = InstanceToWnd(pid)

' Reparent the program so it lies inside
' the PictureBox.
old_parent = SetParent(child_hwnd, MDIForm1.hwnd)

cmdRun.Enabled = False
cmdFree.Enabled = True
End Sub
---------
Option Explicit

作者: 61.142.212.* 2005-10-28 21:38 　回復此發言

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

92 API的“瀏覽”對話框。
Private Sub cmdBrowse_Click()
Dim strResFolder As String

strResFolder = BrowseForFolder(hWnd, "Please select a folder.")

If strResFolder = "" Then
Call MsgBox("The Cancel button was pressed.", vbExclamation)
Else
Call MsgBox("The folder " & strResFolder & " was selected.", vbExclamation)
End If

End Sub
-----------
'This module contains all the declarations to use the
'Windows 95 Shell API to use the browse for folders
'dialog box. To use the browse for folders dialog box,
'please call the BrowseForFolders function using the
'syntax: stringFolderPath=BrowseForFolders(Hwnd,TitleOfDialog)
'
'For more demo projects, please visit out web site at
'http://www.btinternet.com/~jelsoft/
'
'To contact us, please send an email to jelsoft@btinternet.com

Option Explicit

Public Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String

'declare variables to be used
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo

'initialise variables
With udtBI
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With

'Call the browse for folder API
lpIDList = SHBrowseForFolder(udtBI)

'get the resulting string path
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If

'If cancel was pressed, sPath = ""
BrowseForFolder = sPath

End Function

作者: 61.142.212.* 2005-10-28 21:39 　回復此發言

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

93 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
'//
'// Common Dialogs Module
'//
'// Description:
'// Provides wrapper functions into the various Windows OS common dialog boxes
'//
'// ***************************************************************
'// * Go to Dragon's VB Code Corner for more useful sourcecode: *
'// * http://personal.inet.fi/cool/dragon/vb/ *
'// ***************************************************************
'//
'// Author of this module: Unknown
'//

Option Explicit

'//
'// Structures
'//

Private Type OPENFILENAME
lStructSize As Long
hWnd As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Type COLORSTRUC
lStructSize As Long
hWnd As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Const LF_FACESIZE = 32

Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type FONTSTRUC
lStructSize As Long
hWnd As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
Flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type

Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFreq As Long
End Type

Private Type PRINTDLGSTRUC
lStructSize As Long
hWnd As Long
hDevMode As Long
hDevNames As Long
hDC As Long
Flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

94 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
End Type

Public Type PRINTPROPS
Cancel As Boolean
Device As String
Copies As Integer
Collate As Boolean
File As Boolean
All As Boolean
Pages As Boolean
Selection As Boolean
FromPage As Integer
ToPage As Integer
DM As DEVMODE
End Type

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'//
'// Win32s (Private Functions for Wrappers Below)
'//

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGSTRUC) As Long
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As Long
Private Declare Function GlobalAlloc Lib "Kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "Kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SHGetPathFromIDList Lib "SHELL32.DLL" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "SHELL32.DLL" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHBrowseForFolder Lib "SHELL32.DLL" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLIST
Private Declare Function WriteProfileString Lib "Kernel32" Alias "WriteProfileStringA" (ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long
Private Declare Function GetProfileString Lib "Kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long

'//
'// Win32s (Public)
'//

Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Any) As Long
Declare Function HTMLHelp Lib "hhctrl.ocx" Alias "HtmlHelpA" (ByVal hWnd As Long, ByVal szFilename As String, ByVal dwCommand As Long, ByVal dwData As Any) As Long

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

95 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽

'//
'// Constants (Public for Print Dialog Box)
'//

Public Const PD_NOSELECTION = &H4
Public Const PD_DISABLEPRINTTOFILE = &H80000
Public Const PD_PRINTTOFILE = &H20
Public Const PD_RETURNDC = &H100
Public Const PD_RETURNDEFAULT = &H400
Public Const PD_RETURNIC = &H200
Public Const PD_SELECTION = &H1
Public Const PD_SHOWHELP = &H800
Public Const PD_NOPAGENUMS = &H8
Public Const PD_PAGENUMS = &H2
Public Const PD_ALLPAGES = &H0
Public Const PD_COLLATE = &H10
Public Const PD_HIDEPRINTTOFILE = &H100000

'//
'// Constants (Public for WinHelp)
'//

Public Const HELP_COMMAND = &H102&
Public Const HELP_CONTENTS = &H3&
Public Const HELP_CONTEXT = &H1
Public Const HELP_CONTEXTPOPUP = &H8&
Public Const HELP_FORCEFILE = &H9&
Public Const HELP_HELPONHELP = &H4
Public Const HELP_INDEX = &H3
Public Const HELP_KEY = &H101
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&
Public Const HELP_QUIT = &H2
Public Const HELP_SETCONTENTS = &H5&
Public Const HELP_SETINDEX = &H5
Public Const HELP_SETWINPOS = &H203&

'//
'// Constants (Public for HTMLHelp)
'//

Public Const HH_DISPLAY_TOPIC = &H0&
Public Const HH_HELP_FINDER = &H0&
Public Const HH_DISPLAY_TOC = &H1& '// Currently Not Implemented
Public Const HH_DISPLAY_INDEX = &H2& '// Currently Not Implemented
Public Const HH_DISPLAY_SEARCH = &H3& '// Currently Not Implemented
Public Const HH_SET_WIN_TYPE = &H4&
Public Const HH_GET_WIN_TYPE = &H5&
Public Const HH_GET_WIN_HANDLE = &H6&
Public Const HH_ENUM_INFO_TYPE = &H7&
Public Const HH_SET_INFO_TYPE = &H8&
Public Const HH_SYNC = &H9&
Public Const HH_ADD_NAV_UI = &H10& '// Currently Not Implemented
Public Const HH_ADD_BUTTON = &H11& '// Currently Not Implemented
Public Const HH_GETBROWSER_APP = &H12& '// Currently Not Implemented
Public Const HH_KEYWORD_LOOKUP = &H13&
Public Const HH_DISPLAY_TEXT_POPUP = &H14&
Public Const HH_HELP_CONTEXT = &H15&
Public Const HH_TP_HELP_CONTEXTMENU = &H16&
Public Const HH_TP_HELP_WM_HELP = &H17&
Public Const HH_CLOSE_ALL = &H18&
Public Const HH_ALINK_LOOKUP = &H19&
Public Const HH_GET_LAST_ERROR = &H20& '// Currently Not Implemented
Public Const HH_ENUM_CATEGORY = &H21&
Public Const HH_ENUM_CATEGORY_IT = &H22&
Public Const HH_RESET_IT_FILTER = &H23&
Public Const HH_SET_INCLUSIVE_FILTER = &H24&
Public Const HH_SET_EXCLUSIVE_FILTER = &H25&
Public Const HH_SET_GUID = &H26&
Public Const HH_INTERNAL = &H255&

'//
'// Constants (Private)
'//

Private Const FW_BOLD = 700
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

96 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10
Private Const PD_ENABLEPRINTHOOK = &H1000
Private Const PD_ENABLEPRINTTEMPLATE = &H4000
Private Const PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
Private Const PD_ENABLESETUPHOOK = &H2000
Private Const PD_ENABLESETUPTEMPLATE = &H8000
Private Const PD_ENABLESETUPTEMPLATEHANDLE = &H20000
Private Const PD_NONETWORKBUTTON = &H200000
Private Const PD_PRINTSETUP = &H40
Private Const PD_USEDEVMODECOPIES = &H40000
Private Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000
Private Const PD_NOWARNING = &H80
Private Const CF_ANSIONLY = &H400&
Private Const CF_APPLY = &H200&
Private Const CF_BITMAP = 2
Private Const CF_PRINTERFONTS = &H2
Private Const CF_PRIVATEFIRST = &H200
Private Const CF_PRIVATELAST = &H2FF
Private Const CF_RIFF = 11
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_SCREENFONTS = &H1
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_DIB = 8
Private Const CF_DIF = 5
Private Const CF_DSPBITMAP = &H82
Private Const CF_DSPENHMETAFILE = &H8E
Private Const CF_DSPMETAFILEPICT = &H83
Private Const CF_DSPTEXT = &H81
Private Const CF_EFFECTS = &H100&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_ENHMETAFILE = 14
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_GDIOBJFIRST = &H300
Private Const CF_GDIOBJLAST = &H3FF
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_METAFILEPICT = 3
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOVERTFONTS = &H1000000
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_NOSIZESEL = &H200000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_OEMTEXT = 7
Private Const CF_OWNERDISPLAY = &H80
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_SHOWHELP = &H4&
Private Const CF_SYLK = 4
Private Const CF_TEXT = 1
Private Const CF_TIFF = 6
Private Const CF_TTONLY = &H40000
Private Const CF_UNICODETEXT = 13
Private Const CF_USESTYLE = &H80&
Private Const CF_WAVE = 12
Private Const CF_WYSIWYG = &H8000
Private Const CFERR_CHOOSEFONTCODES = &H2000
Private Const CFERR_MAXLESSTHANMIN = &H2002
Private Const CFERR_NOFONTS = &H2001

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

97 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
Private Const CC_ANYCOLOR = &H100
Private Const CC_CHORD = 4
Private Const CC_CIRCLES = 1
Private Const CC_ELLIPSES = 8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_INTERIORS = 128
Private Const CC_NONE = 0
Private Const CC_PIE = 2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const CC_ROUNDRECT = 256 '
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_STYLED = 32
Private Const CC_WIDE = 16
Private Const CC_WIDESTYLED = 64
Private Const CCERR_CHOOSECOLORCODES = &H5000
Private Const LOGPIXELSY = 90
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SIMULATED_FONTTYPE = &H8000
Private Const PRINTER_FONTTYPE = &H4000
Private Const SCREEN_FONTTYPE = &H2000
Private Const BOLD_FONTTYPE = &H100
Private Const ITALIC_FONTTYPE = &H200
Private Const REGULAR_FONTTYPE = &H400
Private Const WM_CHOOSEFONT_GETLOGFONT = (&H400 + 1)
Private Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"
Private Const SHAREVISTRING = "commdlg_ShareViolation"
Private Const FILEOKSTRING = "commdlg_FileNameOK"
Private Const COLOROKSTRING = "commdlg_ColorOK"
Private Const SETRGBSTRING = "commdlg_SetRGBColor"
Private Const FINDMSGSTRING = "commdlg_FindReplace"
Private Const HELPMSGSTRING = "commdlg_help"
Private Const CD_LBSELNOITEMS = -1
Private Const CD_LBSELCHANGE = 0
Private Const CD_LBSELSUB = 1
Private Const CD_LBSELADD = 2
Private Const NOERROR = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_WININICHANGE = &H1A

'//
'// SetDefaultPrinter Function
'//
'// Description:
'// Sets the user's default printer to the printer represented by the passed printer object.
'//
'// Syntax:
'// BOOL = SetDefaultPrinter(object)
'//
'// Example:
'// Dim objNewPrinter As Printer
'// Set objNewPrinter = Printers(2)
'// SetDefaultPrinter objNewPrinter
'//

Public Function SetDefaultPrinter(objPrn As Printer) As Boolean

Dim x As Long, szTmp As String

szTmp = objPrn.DeviceName & "," & objPrn.DriverName & "," & objPrn.Port
x = WriteProfileString("windows", "device", szTmp)

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

98 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
x = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Function

'//
'// GetDefaultPrinter Function
'//
'// Description:
'// Retuns the device name of the default printer.
'//
'// Syntax:
'// StrVar = GetDefaultPrinter()
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter
'//

Public Function GetDefaultPrinter() As String

Dim x As Long, szTmp As String, dwBuf As Long

dwBuf = 1024
szTmp = Space(dwBuf + 1)
x = GetProfileString("windows", "device", "", szTmp, dwBuf)
GetDefaultPrinter = Trim(Left(szTmp, x))

End Function

'//
'// ResetDefaultPrinter Function
'//
'// Description:
'// Resets the default printer to the passed device name.
'//
'// Syntax:
'// BOOL = ResetDefaultPrinter(StrVar)
'//
'// Example:
'// szDefPrinter = GetDefaultPrinter()
'// If Not ResetDefaultPrinter(szDefPrinter) Then
'// MsgBox "Could not reset default printer.", vbExclamation
'// End If
'//

Public Function ResetDefaultPrinter(szBuf As String) As Boolean

Dim x As Long

x = WriteProfileString("windows", "device", szBuf)
x = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Function

'//
'// BrowseFolder Function
'//
'// Description:
'// Allows the user to interactively browse and select a folder found in the file system.
'//
'// Syntax:
'// StrVar = BrowseFolder(hWnd, StrVar)
'//
'// Example:
'// szFilename = BrowseFolder(Me.hWnd, "Browse for application folder:")
'//

Public Function BrowseFolder(hWnd As Long, szDialogTitle As String) As String

Dim x As Long, BI As BROWSEINFO, dwIList As Long, szPath As String, wPos As Integer

BI.hOwner = hWnd
BI.lpszTitle = szDialogTitle
BI.ulFlags = BIF_RETURNONLYFSDIRS
dwIList = SHBrowseForFolder(BI)
szPath = Space$(512)
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = ""
End If

End Function

'//
'// DialogConnectToPrinter Function
'//
'// Description:
'// Allows users to interactively selection and connect to local and network printers.
'//
'// Syntax:
'// DialogConnectToPrinter
'//
'// Example:
'// DialogConnectToPrinter
'//

Public Function DialogConnectToPrinter() As Boolean

Shell "rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus

End Function

'//
'// ByteToString Function
'//
'// Description:
'// Converts an array of bytes into a string
'//
'// Syntax:
'// StrVar = ByteToString(ARRAY)
'//
'// Example:
'// szBuf = BytesToString(aChars(10))
'//

Private Function ByteToString(aBytes() As Byte) As String

Dim dwBytePoint As Long, dwByteVal As Long, szOut As String

dwBytePoint = LBound(aBytes)

While dwBytePoint <= UBound(aBytes)

dwByteVal = aBytes(dwBytePoint)

If dwByteVal = 0 Then
ByteToString = szOut
Exit Function
Else
szOut = szOut & Chr$(dwByteVal)
End If

dwBytePoint = dwBytePoint + 1

Wend

ByteToString = szOut

End Function

'//
'// DialogColor Function

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

99 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
'//
'// Description:
'// Displays the Color common dialog box and sets a passed controls foreground color.
'//
'// Syntax:
'// BOOL = DialogColor(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogColor(Me.hWnd, txtEditor)
'//

Public Function DialogColor(hWnd As Long, c As Control) As Boolean

Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long

CS.lStructSize = Len(CS)
CS.hWnd = hWnd
CS.hInstance = App.hInstance
CS.Flags = CC_SOLIDCOLOR
CS.lpCustColors = String$(16 * 4, 0)
x = ChooseColor(CS)
If x = 0 Then
DialogColor = False
Else
DialogColor = True
c.ForeColor = CS.rgbResult
End If

End Function

'//
'// DialogFile Function
'//
'// Description:
'// Displays the File Open/Save As common dialog boxes.
'//
'// Syntax:
'// StrVar = DialogFile(hWnd, IntVar, StrVar, StrVar, StrVar, StrVar, StrVar)
'//
'// Example:
'// szFilename = DialogFile(Me.hWnd, 1, "Open", "MyFileName.doc", "Documents" & Chr(0) & "*.doc" & Chr(0) & "All files" & Chr(0) & "*.*", App.Path, "doc")
'//
'// Please note that the szFilter var works a bit differently
'// from the filter property associated with the common dialog
'// control. Instead of separating the differents parts of the
'// string with pipe chars, |, you should use null chars, Chr(0),
'// as separators.

Public Function DialogFile(hWnd As Long, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String) As String

Dim x As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String

OFN.lStructSize = Len(OFN)
OFN.hWnd = hWnd
OFN.lpstrTitle = szDialogTitle
OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
OFN.nMaxFile = 255
OFN.lpstrFileTitle = String$(255, 0)
OFN.nMaxFileTitle = 255
OFN.lpstrFilter = szFilter
OFN.nFilterIndex = 1
OFN.lpstrInitialDir = szDefDir
OFN.lpstrDefExt = szDefExt

If wMode = 1 Then
OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
x = GetOpenFileName(OFN)
Else
OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
x = GetSaveFileName(OFN)
End If

If x <> 0 Then

'// If InStr(OFN.lpstrFileTitle, Chr$(0)) > 0 Then
'// szFileTitle = Left$(OFN.lpstrFileTitle, InStr(OFN.lpstrFileTitle, Chr$(0)) - 1)
'// End If
If InStr(OFN.lpstrFile, Chr$(0)) > 0 Then
szFile = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr$(0)) - 1)
End If
'// OFN.nFileOffset is the number of characters from the beginning of the
'// full path to the start of the file name
'// OFN.nFileExtension is the number of characters from the beginning of the
'// full path to the file's extention, including the (.)
'// MsgBox "File Name is " & szFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & szFile, , "Open"

'// DialogFile = szFile & "|" & szFileTitle
DialogFile = szFile

Else

DialogFile = ""

End If

End Function

'//
'// DialogFont Function
'//
'// Description:
'// Displays the Font common dialog box and sets a passed controls font properties.

作者: 61.142.212.* 2005-10-28 21:40 　回復此發言

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

100 Windows 公共對話框的源代碼,包含文件、打印機、顏色、字體、游覽
'//
'// Syntax:
'// BOOL = DialogFont(hWnd, CONTROL)
'//
'// Example:
'// Dim yn as Boolean
'// yn = DialogFont(Me.hWnd, txtEditor)
'//

Public Function DialogFont(hWnd As Long, c As Control) As Boolean

Dim LF As LOGFONT, FS As FONTSTRUC
Dim lLogFontAddress As Long, lMemHandle As Long

If c.Font.Bold Then LF.lfWeight = FW_BOLD
If c.Font.Italic = True Then LF.lfItalic = 1
If c.Font.Underline = True Then LF.lfUnderline = 1

FS.lStructSize = Len(FS)

lMemHandle = GlobalAlloc(GHND, Len(LF))
If lMemHandle = 0 Then
DialogFont = False
Exit Function
End If

lLogFontAddress = GlobalLock(lMemHandle)
If lLogFontAddress = 0 Then
DialogFont = False
Exit Function
End If

CopyMemory ByVal lLogFontAddress, LF, Len(LF)
FS.lpLogFont = lLogFontAddress
FS.iPointSize = c.Font.Size * 10
FS.Flags = CF_SCREENFONTS Or CF_EFFECTS

If ChooseFont(FS) = 1 Then

CopyMemory LF, ByVal lLogFontAddress, Len(LF)

If LF.lfWeight >= FW_BOLD Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If

If LF.lfItalic = 1 Then
c.Font.Italic = True
Else
c.Font.Italic = False
End If

If LF.lfUnderline = 1 Then
c.Font.Underline = True
Else
c.Font.Underline = False
End If

c.Font.Name = ByteToString(LF.lfFaceName())
c.Font.Size = CLng(FS.iPointSize / 10)

DialogFont = True

Else

DialogFont = False

End If

End Function

'//
'// DialogPrint Function
'//
'// Description:
'// Displays the Print common dialog box and returns a structure containing user entered
'// information from the common dialog box.
'//
'// Syntax:
'// PRINTPROPS = DialogPrint(hWnd, BOOL, DWORD)
'//
'// Example:
'// Dim PP As PRINTPROPS
'// PP = DialogPrint(Me.hWnd, True, PD_PAGENUMS or PD_SELECTION or PD_SHOWHELP)
'//

Public Function DialogPrint(hWnd As Long, bPages As Boolean, Flags As Long) As PRINTPROPS

Dim DM As DEVMODE, PD As PRINTDLGSTRUC
Dim lpDM As Long, wNull As Integer, szDevName As String

PD.lStructSize = Len(PD)
PD.hWnd = hWnd
PD.hDevMode = 0
PD.hDevNames = 0
PD.hDC = 0
PD.Flags = Flags
PD.nFromPage = 0
PD.nToPage = 0
PD.nMinPage = 0
If bPages Then PD.nMaxPage = bPages - 1
PD.nCopies = 0
DialogPrint.Cancel = True

If PrintDlg(PD) Then

lpDM = GlobalLock(PD.hDevMode)
CopyMemory DM, ByVal lpDM, Len(DM)
lpDM = GlobalUnlock(PD.hDevMode)

DialogPrint.Cancel = False
DialogPrint.Device = Left$(DM.dmDeviceName, InStr(DM.dmDeviceName, Chr(0)) - 1)
DialogPrint.FromPage = 0
DialogPrint.ToPage = 0
DialogPrint.All = True
If PD.Flags And PD_PRINTTOFILE Then DialogPrint.File = True Else DialogPrint.File = False
If PD.Flags And PD_COLLATE Then DialogPrint.Collate = True Else DialogPrint.Collate = False
If PD.Flags And PD_PAGENUMS Then
DialogPrint.Pages = True
DialogPrint.All = False
DialogPrint.FromPage = PD.nFromPage
DialogPrint.ToPage = PD.nToPage
Else
DialogPrint.Pages = False
End If
If PD.Flags And PD_SELECTION Then
DialogPrint.Selection = True
DialogPrint.All = False
Else
DialogPrint.Pages = False
End If

If PD.nCopies = 1 Then
DialogPrint.Copies = DM.dmCopies
End If

DialogPrint.DM = DM

End If

End Function

'//
'// DialogPrintSetup Function
'//
'// Description:
'// Displays the Print Setup common dialog box.
'//
'// Syntax:
'// BOOL = DialogPrintSetup(hWnd)
'//
'// Example:
'// If DialogPrintSetup(Me.hWnd) Then
'// End If
'//

Public Function DialogPrintSetup(hWnd As Long) As Boolean

Dim x As Long, PD As PRINTDLGSTRUC

PD.lStructSize = Len(PD)
PD.hWnd = hWnd
PD.Flags = PD_PRINTSETUP
x = PrintDlg(PD)

End Function

101 把焦點定位到任何已運行的窗口。
' *********************************************************************
' Copyright ?995-97 Karl E. Peterson, All Rights Reserved
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' *********************************************************************
Option Explicit

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Sub cmdActivate_Click()
Dim nRet As Long
Dim Title As String
'
' Search using method user chose.
'
nRet = AppActivatePartial(Trim(txtTitle.Text), _
Val(frmMethod.Tag), CBool(chkCase.Value))
If nRet Then
lblResults.Caption = "Found: &&H" & Hex$(nRet)
Title = Space$(256)
nRet = GetWindowText(nRet, Title, Len(Title))
If nRet Then
lblResults.Caption = lblResults.Caption & _
", """ & Left$(Title, nRet) & """"
End If
Else
lblResults.Caption = "Search Failed"
End If
End Sub

Private Sub Form_Load()
'
' Setup controls.
'
txtTitle.Text = ""
lblResults.Caption = ""
optMethod(0).Value = True
End Sub

Private Sub optMethod_Click(Index As Integer)
'
' Store selected Index, which just happens to
' coincide with method Enum, into frame's Tag.
'
frmMethod.Tag = Index
End Sub
---------------
' *********************************************************************
' Copyright ?995-98 Karl E. Peterson, All Rights Reserved
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' *********************************************************************
Option Explicit
'
' Required Win32 API Declarations
'
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
'
' Constants used with APIs
'
Private Const SW_RESTORE = 9
'
' Private variables needed to support enumeration
'
Private m_hWnd As Long
Private m_Method As FindWindowPartialTypes
Private m_CaseSens As Boolean
Private m_Visible As Boolean
Private m_AppTitle As String
'
' Constants used by FindWindowPartial

作者: 61.142.212.* 2005-10-28 21:41 　回復此發言

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

102 把焦點定位到任何已運行的窗口。
'
Public Enum FindWindowPartialTypes
FwpStartsWith = 0
FwpContains = 1
FwpMatches = 2
End Enum

Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWindowPartialTypes = FwpStartsWith, Optional CaseSensitive As Boolean = False) As Long
Dim hWndApp As Long
'
' Retrieve window handle for first top-level window
' that starts with or contains the passed string.
'
hWndApp = FindWindowPartial(AppTitle, Method, CaseSensitive, True)
If hWndApp Then
'
' Switch to it, restoring if need be.
'
If IsIconic(hWndApp) Then
Call ShowWindow(hWndApp, SW_RESTORE)
End If
Call SetForegroundWindow(hWndApp)
AppActivatePartial = hWndApp
End If
End Function

Public Function FindWindowPartial(AppTitle As String, _
Optional Method As FindWindowPartialTypes = FwpStartsWith, _
Optional CaseSensitive As Boolean = False, _
Optional MustBeVisible As Boolean = False) As Long
'
' Reset all search parameters.
'
m_hWnd = 0
m_Method = Method
m_CaseSens = CaseSensitive
m_AppTitle = AppTitle
'
' Upper-case search string if case-insensitive.
'
If m_CaseSens = False Then
m_AppTitle = UCase$(m_AppTitle)
End If
'
' Fire off enumeration, and return m_hWnd when done.
'
Call EnumWindows(AddressOf EnumWindowsProc, MustBeVisible)
FindWindowPartial = m_hWnd
End Function

Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Static WindowText As String
Static nRet As Long
'
' Make sure we meet visibility requirements.
'
If lParam Then 'window must be visible
If IsWindowVisible(hWnd) = False Then
EnumWindowsProc = True
End If
End If
'
' Retrieve windowtext (caption)
'
WindowText = Space$(256)
nRet = GetWindowText(hWnd, WindowText, Len(WindowText))
If nRet Then
'
' Clean up window text and prepare for comparison.
'
WindowText = Left$(WindowText, nRet)
If m_CaseSens = False Then
WindowText = UCase$(WindowText)
End If
'
' Use appropriate method to determine if
' current window's caption either starts
' with, contains, or matches passed string.
'
Select Case m_Method
Case FwpStartsWith
If InStr(WindowText, m_AppTitle) = 1 Then
m_hWnd = hWnd
End If
Case FwpContains
If InStr(WindowText, m_AppTitle) <> 0 Then
m_hWnd = hWnd
End If
Case FwpMatches
If WindowText = m_AppTitle Then
m_hWnd = hWnd
End If
End Select
End If
'
' Return True to continue enumeration if we haven't
' found what we're looking for.
'
EnumWindowsProc = (m_hWnd = 0)
End Function

作者: 61.142.212.* 2005-10-28 21:41 　回復此發言

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

103 另一個實現窗口背景的漸變。
Option Explicit
Dim fadeStyle As Integer
Private Sub FadeForm(frmIn As Form, fadeStyle As Integer)
'fadeStyle = 0 produces diagonal gradient
'fadeStyle = 1 produces vertical gradient
'fadeStyle = 2 produces horizontal gradient
'any other value produces solid medium-blue background
Static ColorBits As Long
Static RgnCnt As Integer
Dim NbrPlanes As Long
Dim BitsPerPixel As Long
Dim AreaHeight As Long
Dim AreaWidth As Long
Dim BlueLevel As Long
Dim prevScaleMode As Integer
Dim IntervalY As Long
Dim IntervalX As Long
Dim i As Integer
Dim r As Long
Dim ColorVal As Long
Dim FillArea As RECT
Dim hBrush As Long
'init code - performed only on the first pass through this routine.
If ColorBits = 0 Then
'determine number of color bits supported.
BitsPerPixel = GetDeviceCaps(frmIn.hDC, BITSPIXEL)
NbrPlanes = GetDeviceCaps(frmIn.hDC, PLANES)
ColorBits = (BitsPerPixel * NbrPlanes)
'Calculate the number of regions that the screen will be divided o.
'This is optimized for the current display's color depth. Why waste
'time rendering 256 shades if you can only discern 32 or 64 of them?
Select Case ColorBits
Case 32: RgnCnt = 256 '16M colors: 8 bits for blue
Case 24: RgnCnt = 256 '16M colors: 8 bits for blue
Case 16: RgnCnt = 256 '64K colors: 5 bits for blue
Case 15: RgnCnt = 32 '32K colors: 5 bits for blue
Case 8: RgnCnt = 64 '256 colors: 64 dithered blues
Case 4: RgnCnt = 64 '16 colors : 64 dithered blues
Case Else: ColorBits = 4
RgnCnt = 64 '16 colors assumed: 64 dithered blues
End Select
End If 'if solid then set and bail out

If fadeStyle = 3 Then
frmIn.BackColor = &H7F0000 ' med blue
Exit Sub
End If

prevScaleMode = frmIn.ScaleMode 'save the current scalemode
frmIn.ScaleMode = 3 'set to pixel
AreaHeight = frmIn.ScaleHeight 'calculate sizes
AreaWidth = frmIn.ScaleWidth
frmIn.ScaleMode = prevScaleMode 'reset to saved value
ColorVal = 256 / RgnCnt 'color diff between regions
IntervalY = AreaHeight / RgnCnt '# vert pixels per region
IntervalX = AreaWidth / RgnCnt '# horz pixels per region
'fill the client area from bottom/right
'to top/left except for top/left region
FillArea.Left = 0
FillArea.Top = 0
FillArea.Right = AreaWidth
FillArea.Bottom = AreaHeight
BlueLevel = 0
For i = 0 To RgnCnt - 1
'create a brush of the appropriate blue colour
hBrush = CreateSolidBrush(RGB(0, 0, BlueLevel))
If fadeStyle = 0 Then 'diagonal gradient
FillArea.Top = FillArea.Bottom - IntervalY
FillArea.Left = 0
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Top = 0
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
FillArea.Right = FillArea.Right - IntervalX
ElseIf fadeStyle = 1 Then 'horizontal gradient
FillArea.Top = FillArea.Bottom - IntervalY
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Bottom = FillArea.Bottom - IntervalY
Else
'vertical gradient
FillArea.Left = FillArea.Right - IntervalX
r = FillRect(frmIn.hDC, FillArea, hBrush)
FillArea.Right = FillArea.Right - IntervalX
End If
'done with that brush, so delete
r = DeleteObject(hBrush)
'increment the value by the appropriate
'steps for the display colour depth
BlueLevel = BlueLevel + ColorVal
Next 'Fill any the remaining top/left holes of the client area with solid blue
FillArea.Top = 0
FillArea.Left = 0
hBrush = CreateSolidBrush(RGB(0, 0, 255))
r = FillRect(frmIn.hDC, FillArea, hBrush)
r = DeleteObject(hBrush)
Me.Refresh
End Sub
Private Sub Form_Load()
fadeStyle = 0
mnuStyle(fadeStyle).Checked = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then PopupMenu zmnuStyle
End Sub

Private Sub Form_Resize()
If WindowState <> 1 Then
FadeForm Me, fadeStyle
End If
End Sub

Private Sub mnuStyle_Click(Index As Integer)
'track the current selection
Static prevStyle As Integer
'uncheck the last selection
mnuStyle(prevStyle).Checked = False
'set the variable indicating the style
fadeStyle = Index
'draw the new style
FadeForm Me, fadeStyle
'update the current selection
mnuStyle(fadeStyle).Checked = True
prevStyle = fadeStyle
End Sub
--------------
Option Explicit
Public Const PLANES = 14 ' Number of planes
Public Const BITSPIXEL = 12 ' Number of bits per pixel
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long

Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Declare Function FillRect Lib "user32" _
(ByVal hDC As Long, lpRect As RECT, _
ByVal hBrush As Long) As Long

作者: 61.142.212.* 2005-10-28 21:42 　回復此發言

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

104 檢測當前按鍵狀態(非常不錯)
Option Explicit

Private Sub Command1_Click()
Picture1.Picture = Image1.Picture
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Command3_Click()
Picture1.Picture = LoadPicture("")
End Sub

Private Sub Command4_Click()
Dim dl As Long
Form2.Show
End Sub

Private Sub Form_Load()
Dim i As Integer

Move (Screen.Width - Form1.Width) \ 2, (Screen.Height - Form1.Height) \ 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub Timer1_Timer()
Dim i As Integer
Dim Key(0 To 255) As Byte
Dim dl As Long
Dim KeyCode As Long
Dim KeyName As String * 256
List1.Clear
dl& = GetKeyboardState(Key(0)) '獲取當前按鍵狀態
For i = 0 To 254
If Key(i) And &H80 Then
KeyCode& = MapVirtualKey(i, 0)
dl& = GetKeyNameText(KeyCode * &H10000, KeyName, 255)
List1.AddItem "[ " & Left(KeyName, dl&) & " ]鍵,虛擬鍵碼為(十進制)∶" & CStr(i) & Chr(13) & Chr(10)
End If
Next
End Sub

Private Sub Timer2_Timer()
Dim Key As Integer
Dim NowKey As Long

NowKey = 0
If HotKey = 0 Then Exit Sub
Key% = GetKeyState(VK_SHIFT)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_SHIFT
Key% = GetKeyState(VK_CONTROL)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_CONTROL
Key% = GetKeyState(VK_MENU)
If Key And &H4000 Then NowKey = NowKey Or HOTKEYF_ALT
Key% = GetKeyState(HotKey_Cild)
If Key And &H4000 And HotKey = NowKey Then
Command1_Click
End If
End Sub
-----------
Option Explicit
Private isALT As Byte
Private isCONTROL As Byte
Private isSHIFT As Byte
Private Sub Command1_Click(Index As Integer)
If Index = 0 Then
If Check2.Value = 1 Then
HotKey = 0
If Check1(0).Value = 1 Then HotKey = HotKey Or HOTKEYF_CONTROL
If Check1(1).Value = 1 Then HotKey = HotKey Or HOTKEYF_ALT
If Check1(2).Value = 1 Then HotKey = HotKey Or HOTKEYF_SHIFT
HotKey_Cild = Asc(Combo1.Text)
Else
HotKey = 0
End If
End If
Unload Me
End Sub

Private Sub Form_Load()
Dim i As Integer
Move (Screen.Width - Form2.Width) \ 2, (Screen.Height - Form2.Height) \ 2

Combo1.Clear
For i = 48 To 57
Combo1.AddItem Chr(i)
Next
For i = 65 To 90
Combo1.AddItem Chr(i)
Next

If HotKey = 0 Then
Combo1.ListIndex = 0
Else
Check2.Value = 1
Combo1.Text = Chr(HotKey_Cild)
If HotKey And HOTKEYF_CONTROL Then Check1(0).Value = 1
If HotKey And HOTKEYF_ALT Then Check1(1).Value = 1
If HotKey And HOTKEYF_SHIFT Then Check1(2).Value = 1
End If

Call SetWindowWord(hwnd, GWL_HWNDPARENT, Form1.hwnd)
Form1.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)

Form1.Enabled = True
End Sub
--------------
Option Explicit

Public Declare Function GetKeyboardState& Lib "user32" (pbKeyState As Byte)
Public Declare Function GetKeyNameText& Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long)
Public Declare Function MapVirtualKey& Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long)
Public Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey As Long)
Public Declare Function SetWindowWord& Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long)
Public Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)

Public Const GWL_HWNDPARENT& = (-8)

Public Const HOTKEYF_SHIFT = &H1
Public Const HOTKEYF_CONTROL = &H2
Public Const HOTKEYF_ALT = &H4

Public Const VK_CONTROL& = &H11
Public Const VK_SHIFT& = &H10
Public Const VK_MENU& = &H12

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

作者: 61.142.212.* 2005-10-28 21:44 　回復此發言

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

105 利用Windows的未公開函數SHChangeNotifyRegister實現文件目錄操作
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")

' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================

Private m_hSHNotify As Long ' the one and only shell change notification handle for the desktop folder
Private m_pidlDesktop As Long ' the desktop's pidl

' User defined notiication message sent to the specified window's window proc.
Public Const WM_SHNOTIFY = &H401

' ====================================================================

Public Type PIDLSTRUCT
' Fully qualified pidl (relative to the desktop folder) of the folder to monitor changes in.
' 0 can also be specifed for the desktop folder.
pidl As Long
' Value specifying whether changes in the folder's subfolders trigger a change notification
' event (it's actually a Boolean, but we'll go Long because of VB's DWORD struct alignment).
bWatchSubFolders As Long
End Type

Declare Function SHChangeNotifyRegister Lib "shell32" Alias "#2" _
(ByVal hWnd As Long, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwEventID As SHCN_EventIDs, _
ByVal uMsg As Long, _
ByVal cItems As Long, _
lpps As PIDLSTRUCT) As Long

' hWnd - Handle of the window to receive the window message specified in uMsg.

' uFlags - Flag that indicates the meaning of the dwItem1 and dwItem2 members of the
' SHNOTIFYSTRUCT (which is pointed to by the window procedure's wParam
' value when the specifed window message is received). This parameter can
' be one of the SHCN_ItemFlags enum values below.
' This interpretaion may be inaccurate as it appears pdils are almost alway returned
' in the SHNOTIFYSTRUCT. See James' site for more info...

' dwEventId - Combination of SHCN_EventIDs enum values that specifies what events the
' specified window will be notified of. See below.

' uMsg - Window message to be used to identify receipt of a shell change notification.
' The message should *not* be a value that lies within the specifed window's
' message range ( i.e. BM_ messages for a button window) or that window may
' not receive all (if not any) notifications sent by the shell!!!

' cItems - Count of PIDLSTRUCT structures in the array pointed to by the lpps param.

' lpps - Pointer to an array of PIDLSTRUCT structures indicating what folder(s) to monitor
' changes in, and whether to watch the specified folder's subfolder.

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

106 利用Windows的未公開函數SHChangeNotifyRegister實現文件目錄操作

' If successful, returns a notification handle which must be passed to SHChangeNotifyDeregister
' when no longer used. Returns 0 otherwise.

' Once the specified message is registered with SHChangeNotifyRegister, the specified
' window's function proc will be notified by the shell of the specified event in (and under)
' the folder(s) speciifed in apidl. On message receipt, wParam points to a SHNOTIFYSTRUCT
' and lParam contains the event's ID value.

' The values in dwItem1 and dwItem2 are event specific. See the description of the values
' for the wEventId parameter of the documented SHChangeNotify API function.
Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type

' ...?
'Declare Function SHChangeNotifyUpdateEntryList Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal Unknown As Long, _
' ByVal cItem As Long, _
' lpps As PIDLSTRUCT) As Boolean
'
'Declare Function SHChangeNotifyReceive Lib "shell32" Alias "#5" _
' (ByVal hNotify As Long, _
' ByVal uFlags As SHCN_ItemFlags, _
' ByVal dwItem1 As Long, _
' ByVal dwItem2 As Long) As Long

' Closes the notification handle returned from a call to SHChangeNotifyRegister.
' Returns True if succeful, False otherwise.
Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean

' ====================================================================

' This function should be called by any app that changes anything in the shell.
' The shell will then notify each "notification registered" window of this action.
Declare Sub SHChangeNotify Lib "shell32" _
(ByVal wEventId As SHCN_EventIDs, _
ByVal uFlags As SHCN_ItemFlags, _
ByVal dwItem1 As Long, _
ByVal dwItem2 As Long)

' Shell notification event IDs

Public Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1 ' (D) A nonfolder item has been renamed.
SHCNE_CREATE = &H2 ' (D) A nonfolder item has been created.
SHCNE_DELETE = &H4 ' (D) A nonfolder item has been deleted.
SHCNE_MKDIR = &H8 ' (D) A folder item has been created.
SHCNE_RMDIR = &H10 ' (D) A folder item has been removed.
SHCNE_MEDIAINSERTED = &H20 ' (G) Storage media has been inserted into a drive.
SHCNE_MEDIAREMOVED = &H40 ' (G) Storage media has been removed from a drive.
SHCNE_DRIVEREMOVED = &H80 ' (G) A drive has been removed.
SHCNE_DRIVEADD = &H100 ' (G) A drive has been added.
SHCNE_NETSHARE = &H200 ' A folder on the local computer is being shared via the network.
SHCNE_NETUNSHARE = &H400 ' A folder on the local computer is no longer being shared via the network.
SHCNE_ATTRIBUTES = &H800 ' (D) The attributes of an item or folder have changed.
SHCNE_UPDATEDIR = &H1000 ' (D) The contents of an existing folder have changed, but the folder still exists and has not been renamed.
SHCNE_UPDATEITEM = &H2000 ' (D) An existing nonfolder item has changed, but the item still exists and has not been renamed.
SHCNE_SERVERDISCONNECT = &H4000 ' The computer has disconnected from a server.
SHCNE_UPDATEIMAGE = &H8000& ' (G) An image in the system image list has changed.

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

107 利用Windows的未公開函數SHChangeNotifyRegister實現文件目錄操作
SHCNE_DRIVEADDGUI = &H10000 ' (G) A drive has been added and the shell should create a new window for the drive.
SHCNE_RENAMEFOLDER = &H20000 ' (D) The name of a folder has changed.
SHCNE_FREESPACE = &H40000 ' (G) The amount of free space on a drive has changed.

#If (WIN32_IE >= &H400) Then
SHCNE_EXTENDED_EVENT = &H4000000 ' (G) Not currently used.
#End If ' WIN32_IE >= &H0400

SHCNE_ASSOCCHANGED = &H8000000 ' (G) A file type association has changed.

SHCNE_DISKEVENTS = &H2381F ' Specifies a combination of all of the disk event identifiers. (D)
SHCNE_GLOBALEVENTS = &HC0581E0 ' Specifies a combination of all of the global event identifiers. (G)
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000 ' The specified event occurred as a result of a system interrupt.
' It is stripped out before the clients of SHCNNotify_ see it.
End Enum

#If (WIN32_IE >= &H400) Then ' ???
Public Const SHCNEE_ORDERCHANGED = &H2 ' dwItem2 is the pidl of the changed folder
#End If

' Notification flags

' uFlags & SHCNF_TYPE is an ID which indicates what dwItem1 and dwItem2 mean
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0 ' LPITEMIDLIST
SHCNF_PATHA = &H1 ' path name
SHCNF_PRINTERA = &H2 ' printer friendly name
SHCNF_DWORD = &H3 ' DWORD
SHCNF_PATHW = &H5 ' path name
SHCNF_PRINTERW = &H6 ' printer friendly name
SHCNF_TYPE = &HFF
' Flushes the system event buffer. The function does not return until the system is
' finished processing the given event.
SHCNF_FLUSH = &H1000
' Flushes the system event buffer. The function returns immediately regardless of
' whether the system is finished processing the given event.
SHCNF_FLUSHNOWAIT = &H2000

#If UNICODE Then
SHCNF_PATH = SHCNF_PATHW
SHCNF_PRINTER = SHCNF_PRINTERW
#Else
SHCNF_PATH = SHCNF_PATHA
SHCNF_PRINTER = SHCNF_PRINTERA
#End If
End Enum
'

' Registers the one and only shell change notification.

Public Function SHNotify_Register(hWnd As Long) As Boolean
Dim ps As PIDLSTRUCT

' If we don't already have a notification going...
If (m_hSHNotify = 0) Then

' Get the pidl for the desktop folder.
m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)
If m_pidlDesktop Then

' Fill the one and only PIDLSTRUCT, we're watching
' desktop and all of the it's subfolders, everything...
ps.pidl = m_pidlDesktop
ps.bWatchSubFolders = True

' Register the notification, specifying that we want the dwItem1 and dwItem2
' members of the SHNOTIFYSTRUCT to be pidls. We're watching all events.
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, _
SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, _
WM_SHNOTIFY, 1, ps)
Debug.Print Hex(SHCNF_TYPE Or SHCNF_IDLIST)
Debug.Print Hex(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT)
Debug.Print m_hSHNotify
SHNotify_Register = CBool(m_hSHNotify)

Else
' If something went wrong...
Call CoTaskMemFree(m_pidlDesktop)

End If ' m_pidlDesktop
End If ' (m_hSHNotify = 0)

End Function

' Unregisters the one and only shell change notification.

Public Function SHNotify_Unregister() As Boolean

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

108 利用Windows的未公開函數SHChangeNotifyRegister實現文件目錄操作

' If we have a registered notification handle.
If m_hSHNotify Then
' Unregister it. If the call is successful, zero the handle's variable,
' free and zero the the desktop's pidl.
If SHChangeNotifyDeregister(m_hSHNotify) Then
m_hSHNotify = 0
Call CoTaskMemFree(m_pidlDesktop)
m_pidlDesktop = 0
SHNotify_Unregister = True
End If
End If

End Function

' Returns the event string associated with the specified event ID value.

Public Function SHNotify_GetEventStr(dwEventID As Long) As String
Dim sEvent As String

Select Case dwEventID
Case SHCNE_RENAMEITEM: sEvent = "SHCNE_RENAMEITEM" ' = &H1"
Case SHCNE_CREATE: sEvent = "SHCNE_CREATE" ' = &H2"
Case SHCNE_DELETE: sEvent = "SHCNE_DELETE" ' = &H4"
Case SHCNE_MKDIR: sEvent = "SHCNE_MKDIR" ' = &H8"
Case SHCNE_RMDIR: sEvent = "SHCNE_RMDIR" ' = &H10"
Case SHCNE_MEDIAINSERTED: sEvent = "SHCNE_MEDIAINSERTED" ' = &H20"
Case SHCNE_MEDIAREMOVED: sEvent = "SHCNE_MEDIAREMOVED" ' = &H40"
Case SHCNE_DRIVEREMOVED: sEvent = "SHCNE_DRIVEREMOVED" ' = &H80"
Case SHCNE_DRIVEADD: sEvent = "SHCNE_DRIVEADD" ' = &H100"
Case SHCNE_NETSHARE: sEvent = "SHCNE_NETSHARE" ' = &H200"
Case SHCNE_NETUNSHARE: sEvent = "SHCNE_NETUNSHARE" ' = &H400"
Case SHCNE_ATTRIBUTES: sEvent = "SHCNE_ATTRIBUTES" ' = &H800"
Case SHCNE_UPDATEDIR: sEvent = "SHCNE_UPDATEDIR" ' = &H1000"
Case SHCNE_UPDATEITEM: sEvent = "SHCNE_UPDATEITEM" ' = &H2000"
Case SHCNE_SERVERDISCONNECT: sEvent = "SHCNE_SERVERDISCONNECT" ' = &H4000"
Case SHCNE_UPDATEIMAGE: sEvent = "SHCNE_UPDATEIMAGE" ' = &H8000&"
Case SHCNE_DRIVEADDGUI: sEvent = "SHCNE_DRIVEADDGUI" ' = &H10000"
Case SHCNE_RENAMEFOLDER: sEvent = "SHCNE_RENAMEFOLDER" ' = &H20000"
Case SHCNE_FREESPACE: sEvent = "SHCNE_FREESPACE" ' = &H40000"

#If (WIN32_IE >= &H400) Then
Case SHCNE_EXTENDED_EVENT: sEvent = "SHCNE_EXTENDED_EVENT" ' = &H4000000"
#End If ' WIN32_IE >= &H0400

Case SHCNE_ASSOCCHANGED: sEvent = "SHCNE_ASSOCCHANGED" ' = &H8000000"

Case SHCNE_DISKEVENTS: sEvent = "SHCNE_DISKEVENTS" ' = &H2381F"
Case SHCNE_GLOBALEVENTS: sEvent = "SHCNE_GLOBALEVENTS" ' = &HC0581E0"
Case SHCNE_ALLEVENTS: sEvent = "SHCNE_ALLEVENTS" ' = &H7FFFFFFF"
Case SHCNE_INTERRUPT: sEvent = "SHCNE_INTERRUPT" ' = &H80000000"
End Select

SHNotify_GetEventStr = sEvent

End Function
--------------------

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

109 回復 107:利用Windows的未公開函數SHChangeNotifyRegister實現文
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

' ====================================================================

Declare Function FlashWindow Lib "user32" (ByVal hWnd As Long, ByVal bInvert As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

' Frees memory allocated by the shell (pidls)
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Const MAX_PATH = 260

' Defined as an HRESULT that corresponds to S_OK.
Public Const NOERROR = 0

' Special folder values for SHGetSpecialFolderLocation and
' SHGetSpecialFolderPath (Shell32.dll v4.71)
Public Enum SHSpecialFolderIDs
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D ' ' DBCS
CSIDL_COMMON_ALTSTARTUP = &H1E ' ' DBCS
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum

' Converts an item identifier list to a file system path.
' Returns TRUE if successful or FALSE if an error occurs, for example,
' if the location specified by the pidl parameter is not part of the file system.
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long

' Retrieves information about an object in the file system, such as a file,
' a folder, a directory, or a drive root.
Declare Function SHGetFileInfoPidl Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pidl As Long, _
ByVal dwFileAttributes As Long, _
psfib As SHFILEINFOBYTE, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long

' If pidl is invalid, SHGetFileInfoPidl can very easily blow up when filling the
' szDisplayName and szTypeName string members of the SHFILEINFO struct
Public Type SHFILEINFOBYTE ' sfib
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName(1 To MAX_PATH) As Byte
szTypeName(1 To 80) As Byte
End Type

Declare Function SHGetFileInfo Lib "shell32" Alias "SHGetFileInfoA" _
(ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

110 回復 107:利用Windows的未公開函數SHChangeNotifyRegister實現文
psfi As SHFILEINFO, _
ByVal cbFileInfo As Long, _
ByVal uFlags As SHGFI_flags) As Long

Public Type SHFILEINFO ' shfi
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Enum SHGFI_flags
SHGFI_LARGEICON = &H0 ' sfi.hIcon is large icon
SHGFI_SMALLICON = &H1 ' sfi.hIcon is small icon
SHGFI_OPENICON = &H2 ' sfi.hIcon is open icon
SHGFI_SHELLICONSIZE = &H4 ' sfi.hIcon is shell size (not system size), rtns BOOL
SHGFI_PIDL = &H8 ' pszPath is pidl, rtns BOOL
SHGFI_USEFILEATTRIBUTES = &H10 ' pretent pszPath exists, rtns BOOL
SHGFI_ICON = &H100 ' fills sfi.hIcon, rtns BOOL, use DestroyIcon
SHGFI_DISPLAYNAME = &H200 ' isf.szDisplayName is filled, rtns BOOL
SHGFI_TYPENAME = &H400 ' isf.szTypeName is filled, rtns BOOL
SHGFI_ATTRIBUTES = &H800 ' rtns IShellFolder::GetAttributesOf SFGAO_* flags
SHGFI_ICONLOCATION = &H1000 ' fills sfi.szDisplayName with filename
' containing the icon, rtns BOOL
SHGFI_EXETYPE = &H2000 ' rtns two ASCII chars of exe type
SHGFI_SYSICONINDEX = &H4000 ' sfi.iIcon is sys il icon index, rtns hImagelist
SHGFI_LINKOVERLAY = &H8000 ' add shortcut overlay to sfi.hIcon
SHGFI_SELECTED = &H10000 ' sfi.hIcon is selected icon
End Enum
'

' Returns an absolute pidl (realtive to the desktop) from a special folder's ID.
' (calling proc is responsible for freeing the pidl)

' hOwner - handle of window that will own any displayed msg boxes
' nFolder - special folder ID

Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long
Dim pidl As Long
If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then
GetPIDLFromFolderID = pidl
End If
End Function

' If successful returns the specified absolute pidl's displayname,
' returns an empty string otherwise.

Public Function GetDisplayNameFromPIDL(pidl As Long) As String
Dim sfib As SHFILEINFOBYTE
If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then
GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))
End If
End Function

' Returns a path from only an absolute pidl (relative to the desktop)

Public Function GetPathFromPIDL(pidl As Long) As String
Dim sPath As String * MAX_PATH
If SHGetPathFromIDList(pidl, sPath) Then ' rtns TRUE (1) if successful, FALSE (0) if not
GetPathFromPIDL = GetStrFromBufferA(sPath)
End If
End Function

' Returns the string before first null char encountered (if any) from an ANSII string.

Public Function GetStrFromBufferA(sz As String) As String
If InStr(sz, vbNullChar) Then
GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)
Else
' If sz had no null char, the Left$ function
' above would return a zero length string ("").
GetStrFromBufferA = sz
End If
End Function

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

111 回復 110:利用Windows的未公開函數SHChangeNotifyRegister實現文
Option Explicit

' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp

' Code was written in and formatted for 8pt MS San Serif

Private Const WM_NCDESTROY = &H82

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

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)

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

Private Const OLDWNDPROC = "OldWndProc"
'

Public Function SubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean

If (GetProp(hWnd, OLDWNDPROC) = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
End If
End If

If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call UnSubClass(hWnd)
MsgBox "Unable to successfully subclass &H" & Hex(hWnd), vbCritical
End If

End Function

Public Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long

lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If RemoveProp(hWnd, OLDWNDPROC) Then
UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
End If
End If

End Function

Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Select Case uMsg
Case WM_SHNOTIFY
Call Form1.NotificationReceipt(wParam, lParam)

Case WM_NCDESTROY
Call UnSubClass(hWnd)
MsgBox "Unubclassed &H" & Hex(hWnd), vbCritical, "WndProc Error"

End Select

WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)

End Function

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

112 回復 111:利用Windows的未公開函數SHChangeNotifyRegister實現文
Option Explicit
'
' Brought to you by Brad Martinez
' http://members.aol.com/btmtz/vb
' http://www.mvps.org/ccrp
'
' Code was written in and formatted for 8pt MS San Serif
'
' ====================================================================
' Demonstrates how to receive shell change notifications (ala "what happens when the
' SHChangeNotify API is called?")
'
' Interpretation of the shell's undocumented functions SHChangeNotifyRegister (ordinal 2)
' and SHChangeNotifyDeregister (ordinal 4) would not have been possible without the
' assistance of James Holderness. For a complete (and probably more accurate) overview
' of shell change notifcations, please refer to James' "Shell Notifications" page at
' http://www.geocities.com/SiliconValley/4942/
' ====================================================================
'

Private Sub Form_Load()
If SubClass(hWnd) Then
If IsIDE Then
Text1.Text = vbCrLf & _
"一個 Windows的文件目錄操作即時監視程序," & vbCrLf & "可以監視在Explore中的重命名、新建、刪除文" & _
vbCrLf & "件或目錄;改變文件關聯;插入、取出CD和添加" & vbCrLf & "刪除網絡共享都可以被該程序記錄下來。"
End If
Call SHNotify_Register(hWnd)
'Else
' Text1 = "Uh..., it's supposed to work... :-)"
End If
Move Screen.Width - Width, Screen.Height - Height
End Sub

Private Function IsIDE() As Boolean
On Error GoTo Out
Debug.Print 1 / 0
Out:
IsIDE = Err
End Function

Private Sub Form_Unload(Cancel As Integer)
Call SHNotify_Unregister
Call UnSubClass(hWnd)
End Sub

Private Sub Form_Resize()
On Error GoTo Out
Text1.Move 0, 0, ScaleWidth, ScaleHeight
Out:
End Sub

Public Sub NotificationReceipt(wParam As Long, lParam As Long)
Dim sOut As String
Dim shns As SHNOTIFYSTRUCT

sOut = SHNotify_GetEventStr(lParam) & vbCrLf

' Fill the SHNOTIFYSTRUCT from it's pointer.
MoveMemory shns, ByVal wParam, Len(shns)

' lParam is the ID of the notication event, one of the SHCN_EventIDs.
Select Case lParam

' ================================================================
' For the SHCNE_FREESPACE event, dwItem1 points to what looks like a 10 byte
' struct. The first two bytes are the size of the struct, and the next two members
' equate to SHChangeNotify's dwItem1 and dwItem2 params. The dwItem1 member
' is a bitfield indicating which drive(s) had it's (their) free space changed. The bitfield
' is identical to the bitfield returned from a GetLogicalDrives call, i.e, bit 0 = A:\, bit
' 1 = B:\, 2, = C:\, etc. Since VB does DWORD alignment when MoveMemory'ing
' to a struct, we'll extract the bitfield directly from it's memory location.
Case SHCNE_FREESPACE
Dim dwDriveBits As Long
Dim wHighBit As Integer
Dim wBit As Integer

MoveMemory dwDriveBits, ByVal shns.dwItem1 + 2, 4

' Get the zero based position of the highest bit set in the bitmask
' (essentially determining the value's highest complete power of 2).
' Use floating point division (we want the exact values from the Logs)
' and remove the fractional value (the fraction indicates the value of

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

113 回復 111:利用Windows的未公開函數SHChangeNotifyRegister實現文
' the last incomplete power of 2, which means the bit isn't set).
wHighBit = Int(Log(dwDriveBits) / Log(2))

For wBit = 0 To wHighBit
' If the bit is set...
If (2 ^ wBit) And dwDriveBits Then

' The bit is set, get it's drive string
sOut = sOut & Chr$(vbKeyA + wBit) & ":\" & vbCrLf

End If
Next

' ================================================================
' shns.dwItem1 also points to a 10 byte struct. The struct's second member (after the
' struct's first WORD size member) points to the system imagelist index of the image
' that was updated.
Case SHCNE_UPDATEIMAGE
Dim iImage As Long

MoveMemory iImage, ByVal shns.dwItem1 + 2, 4
sOut = sOut & "Index of image in system imagelist: " & iImage & vbCrLf

' ================================================================
' Everything else except SHCNE_ATTRIBUTES is the pidl(s) of the changed item(s).
' For SHCNE_ATTRIBUTES, neither item is used. See the description of the values
' for the wEventId parameter of the SHChangeNotify API function for more info.
Case Else
Dim sDisplayname As String

If shns.dwItem1 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem1)
If Len(sDisplayname) Then
sOut = sOut & "first item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "first item path: " & GetPathFromPIDL(shns.dwItem1) & vbCrLf
Else
sOut = sOut & "first item is invalid" & vbCrLf
End If
End If

If shns.dwItem2 Then
sDisplayname = GetDisplayNameFromPIDL(shns.dwItem2)
If Len(sDisplayname) Then
sOut = sOut & "second item displayname: " & sDisplayname & vbCrLf
sOut = sOut & "second item path: " & GetPathFromPIDL(shns.dwItem2) & vbCrLf
Else
sOut = sOut & "second item is invalid" & vbCrLf
End If
End If

End Select

Text1 = Text1 & sOut & vbCrLf
Text1.SelStart = Len(Text1)
tmrFlashMe = True

End Sub

Private Sub tmrFlashMe_Timer() ' initial settings: Interval = 1, Enabled = False
Static nCount As Integer

If nCount = 0 Then tmrFlashMe.Interval = 200
nCount = nCount + 1
Call FlashWindow(hWnd, True)

' Reset everything after 3 flash cycles
If nCount = 6 Then
nCount = 0
tmrFlashMe.Interval = 1
tmrFlashMe = False
End If

End Sub

作者: 61.142.212.* 2005-10-28 21:46 　回復此發言

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

114 外殼程序的例子
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Sub cmdOpen_Click()

'check that the file in the text box exists
If Dir(txtFile) = "" Then
Call MsgBox("The file in the text box does not exist.", vbExclamation)
Exit Sub
End If

'open the file with the default program
Call ShellExecute(hwnd, "Open", txtFile, "", App.Path, 1)

'Note: This is the equivalent of
'right clicking on a file in Windows95
'and selecting "Open"
'
'If you would like to do something
'else to the file rather than opening
'it, right click on a file and see
'what options are in the menu. Then
'change the "Open" in the code above to
'read what the menu item says.
'
'Note: This code is great for opening
'web document into the default
'browser. To open http://www.jelsoft.com
'into the default browser the following
'code would be used:
'
'Call ShellExecute(hwnd,"Open",")
'
'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", "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 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", "End Sub

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

Private Sub Label4_Click()
Call ShellExecute(hwnd, "Open", "mailto:lhxie@126.com", "", App.Path, 1)
End Sub

Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label4.ForeColor = vbRed

End Sub

作者: 61.142.212.* 2005-10-28 22:00 　回復此發言

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

131 看著超級瑪莉不停的追趕著你的鼠標,是不是很有意思呢？(推薦)
Option Explicit
Public Pic As New cut_Pic

Private Sub Form_Load()
Pic.Ini Form1, P(0), P2, 5, 10
Pic.Sound = True
End Sub

Private Sub P2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'突出式功能表
If Button = 2 Then Form1.PopupMenu Form2.A, 2
End Sub

Private Sub Timer1_Timer()
Pic.cutPic
End Sub
---------
Option Explicit

Private Sub A1_Click()
A1.Checked = Not A1.Checked
Form1.Pic.Auto = Not Form1.Pic.Auto
End Sub

Private Sub A2_Click()
A2.Checked = Not A2.Checked
Form1.Pic.Sound = Not Form1.Pic.Sound
End Sub

Private Sub A33_Click(Index As Integer)
Form1.Pic.Ini Form1, Form1.P(Index), Form1.P2, 5, 10
End Sub

Private Sub A4_Click()
Copyright.Show
End Sub

Private Sub A5_Click()
Dim I As Integer
For I = Forms.Count - 1 To 0 Step -1
Unload Forms(I)
Next I
End
End Sub

Private Sub Form_Load()
Dim hMenu As Long
Dim hSubMenu As Long
Dim lngID As Long
Dim I As Integer

hMenu = GetMenu(Form2.hwnd)
hSubMenu = GetSubMenu(hMenu, 0) '
hSubMenu = GetSubMenu(hSubMenu, 2) 'Ω
For I = 0 To 7
lngID = GetMenuItemID(hSubMenu, I)

' ノImage妮┦肚紇鉤絏
Pic(I).Picture = Pic(I).Image
Call ModifyMenu(hMenu, lngID, 4, lngID, CLng(Pic(I).Picture))
Next I
End Sub
----------
Option Explicit

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetWindowPos Lib "user32" (ByVal H%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long

Type POINTAPI
X As Long
Y As Long
End Type

Option Explicit

Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function StretchBlt Lib "GDI32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

作者: 61.142.212.* 2005-10-28 22:02 　回復此發言

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

132 看著超級瑪莉不停的追趕著你的鼠標,是不是很有意思呢？(推薦)

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long
Declare Function SetWindowPos Lib "user32" (ByVal H%, ByVal hb%, ByVal X%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long

Type POINTAPI
X As Long
Y As Long
End Type

-------
'************************************************
'** 程式設計:饒明惠(蛇夫) **
'** 職業:阿兵哥 **
'** E-Mail :snakes@ms8.url.com.tw **
'************************************************
Option Explicit
Private in_Form As Form
Private in_srcPic As PictureBox, in_desPic As PictureBox
Private in_Piece As Integer
Private Gini_Width As Integer, Gini_Height As Integer
Private in_FormX As Integer, in_FormY As Integer
Private in_MoveDistance As Integer
Private GiniX As Integer, GiniY As Integer, GiniY1 As Integer
Private Direct As Integer
Private scrpixelX As Integer, scrpixelY As Integer
Private Wav() As Byte
Private in_Auto As Boolean
Private in_Sound As Boolean
Private CheckGoal As Boolean '檢查是否已到了目的
Private CheckMove As Boolean '檢查是否有移動

'**********************************本類別為切割Gini圖用**************************

Sub Ini(out_Form As Form, out_srcPic As PictureBox, out_desPic As PictureBox, out_Piece As Integer, out_MoveDistance As Integer)
Set in_Form = out_Form
Set in_srcPic = out_srcPic
Set in_desPic = out_desPic
'in_Form.ScaleMode = vbPixels
in_srcPic.ScaleMode = vbPixels
in_desPic.ScaleMode = vbPixels

'計算Gini圖的寬、高
in_Piece = out_Piece
Gini_Width = in_srcPic.ScaleWidth / in_Piece
Gini_Height = in_srcPic.ScaleHeight / 2 '輸入圖片為兩倍Gini圖高

'表單的寬、高與Gini圖相同,但轉成twips
in_Form.Width = Gini_Width * Screen.TwipsPerPixelX
in_Form.Height = Gini_Height * Screen.TwipsPerPixelY
in_desPic.Width = in_Form.Width
in_desPic.Height = in_Form.Height
in_MoveDistance = out_MoveDistance
scrpixelX = Screen.TwipsPerPixelX
scrpixelY = Screen.TwipsPerPixelY

'置于最頂層
Call SetWindowPos(in_Form.hwnd, -1, 0, 0, 0, 0, 3)

'載入資源
Wav = LoadResData(111, "WAVE")

Randomize Timer
End Sub
Sub cutPic()
Dim Index As Integer
Static Mouse As POINTAPI

If in_Auto = False Then
'取得滑鼠位置
Call GetCursorPos(Mouse)
Else
If CheckGoal = True Then '隨機取得新目標
With Screen
Mouse.X = Int((.Width / .TwipsPerPixelX) * Rnd)
Mouse.Y = Int((.Height / .TwipsPerPixelY) * Rnd)

作者: 61.142.212.* 2005-10-28 22:02 　回復此發言

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

133 看著超級瑪莉不停的追趕著你的鼠標,是不是很有意思呢？(推薦)
End With
CheckGoal = False
End If
End If

'運算后給予相對的Gini圖和方向
If Mouse.X > ((in_Form.Left / scrpixelX) + Gini_Width) Then
If Mouse.Y < (in_Form.Top / scrpixelY) Then '右上
Direct = 0: Index = 1
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '右下
Direct = 0: Index = 3
Else '右
Direct = 0: Index = 2
End If
CheckMove = True
ElseIf Mouse.X < (in_Form.Left / scrpixelX) Then
If Mouse.Y < (in_Form.Top / scrpixelY) Then '左上
Direct = 1: Index = 1
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '左下
Direct = 1: Index = 3
Else '左
Direct = 1: Index = 2
End If
CheckMove = True
Else
If Mouse.Y < (in_Form.Top / scrpixelY) Then '上
Direct = 0: Index = 0
ElseIf Mouse.Y > ((in_Form.Top / scrpixelY) + (Gini_Height)) Then '下
Direct = 0: Index = 4
Else
'到了目的地
CheckGoal = True
If CheckMove = True Then
If in_Sound = True Then Call sndPlaySound(Wav(0), 5) '音效
CheckMove = False
End If
Exit Sub
End If
CheckMove = True
End If

'輸入圖片第一列為 Gini 遮罩圖
' 第二列為 Gini 圖

'計算Gini圖位置
GiniX = Gini_Width * (Index Mod in_Piece)
GiniY = Gini_Height * (Index \ in_Piece)
GiniY1 = Gini_Height * ((in_Piece + Index) \ in_Piece)

'轉換表單與螢幕的單位為 pixel 關系
If ((in_Form.Left / scrpixelX) + (Gini_Width / 2)) < Mouse.X Then
in_FormX = in_FormX + in_MoveDistance '往右走
ElseIf ((in_Form.Left / scrpixelX)) > Mouse.X Then
in_FormX = in_FormX - in_MoveDistance '往左走
End If
If ((in_Form.Top / scrpixelY) + (Gini_Height / 2)) < Mouse.Y Then
in_FormY = in_FormY + in_MoveDistance '往下走
ElseIf ((in_Form.Top / scrpixelY)) > Mouse.Y Then
in_FormY = in_FormY - in_MoveDistance '往上走
End If

in_srcPic.AutoRedraw = True
in_desPic.AutoRedraw = True
in_Form.AutoRedraw = True

'還原螢幕背景 = in_Form的內容
in_desPic.Visible = False
DoEvents

Dim ScrhDC As Long
'取得螢幕資源
ScrhDC = GetDC(0)
'備份螢幕背景
Call BitBlt(in_Form.hdc, 0, 0, Gini_Width, Gini_Height, ScrhDC, in_FormX, in_FormY, vbSrcCopy)
'copy螢幕背景作為 in_desPic的背景
Call BitBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, ScrhDC, in_FormX, in_FormY, vbSrcCopy)
'釋放螢幕資源
Call ReleaseDC(0, ScrhDC)

'正常copy Gini圖
If Direct = 0 Then
Call StretchBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY, Gini_Width, Gini_Height, vbSrcAnd)
Call StretchBlt(in_desPic.hdc, 0, 0, Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY1, Gini_Width, Gini_Height, vbSrcPaint)
'水平反轉Gini圖
ElseIf Direct = 1 Then
Call StretchBlt(in_desPic.hdc, Gini_Width, 0, -Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY, Gini_Width, Gini_Height, vbSrcAnd)
Call StretchBlt(in_desPic.hdc, Gini_Width, 0, -Gini_Width, Gini_Height, in_srcPic.hdc, GiniX, GiniY1, Gini_Width, Gini_Height, vbSrcPaint)
End If
in_desPic.Visible = True

'移動表單
in_Form.Move in_FormX * scrpixelX, in_FormY * scrpixelY

in_srcPic.AutoRedraw = False
in_desPic.AutoRedraw = False
in_Form.AutoRedraw = False
End Sub

Public Property Get Auto() As Boolean
Auto = in_Auto
End Property

Public Property Let Auto(ByVal out_Auto As Boolean)
in_Auto = out_Auto
End Property

Public Property Get Sound() As Boolean
Sound = in_Sound
End Property

Public Property Let Sound(ByVal out_Sound As Boolean)
in_Sound = out_Sound
End Property

Private Sub Class_Initialize()
CheckGoal = True
End Sub
-------

作者: 61.142.212.* 2005-10-28 22:02 　回復此發言

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

134 回復:把焦點定位到任何已運行的窗口。
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ej@bantz.com
'* Web: http://ej.bantz.com/video

'// ------------------------------------------------------------------
'// Windows API Constants / Types / Declarations
'// ------------------------------------------------------------------
Public Const WM_USER = &H400
Type POINTAPI
x As Long
y As Long
End Type
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Declare Function SendMessageS Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As Long

'// ------------------------------------------------------------------
'// Window Messages WM_CAP... which can be sent to an AVICAP window
'// ------------------------------------------------------------------

'// Defines start of the message range
Public Const WM_CAP_START = WM_USER

Public Const WM_CAP_GET_CAPSTREAMPTR = WM_CAP_START + 1

Public Const WM_CAP_SET_CALLBACK_ERROR = WM_CAP_START + 2
Public Const WM_CAP_SET_CALLBACK_STATUS = WM_CAP_START + 3
Public Const WM_CAP_SET_CALLBACK_YIELD = WM_CAP_START + 4
Public Const WM_CAP_SET_CALLBACK_FRAME = WM_CAP_START + 5
Public Const WM_CAP_SET_CALLBACK_VIDEOSTREAM = WM_CAP_START + 6
Public Const WM_CAP_SET_CALLBACK_WAVESTREAM = WM_CAP_START + 7
Public Const WM_CAP_GET_USER_DATA = WM_CAP_START + 8
Public Const WM_CAP_SET_USER_DATA = WM_CAP_START + 9

Public Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
Public Const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11
Public Const WM_CAP_DRIVER_GET_NAME = WM_CAP_START + 12
Public Const WM_CAP_DRIVER_GET_VERSION = WM_CAP_START + 13
Public Const WM_CAP_DRIVER_GET_CAPS = WM_CAP_START + 14

Public Const WM_CAP_FILE_SET_CAPTURE_FILE = WM_CAP_START + 20
Public Const WM_CAP_FILE_GET_CAPTURE_FILE = WM_CAP_START + 21
Public Const WM_CAP_FILE_ALLOCATE = WM_CAP_START + 22
Public Const WM_CAP_FILE_SAVEAS = WM_CAP_START + 23
Public Const WM_CAP_FILE_SET_INFOCHUNK = WM_CAP_START + 24
Public Const WM_CAP_FILE_SAVEDIB = WM_CAP_START + 25

Public Const WM_CAP_EDIT_COPY = WM_CAP_START + 30

Public Const WM_CAP_SET_AUDIOFORMAT = WM_CAP_START + 35
Public Const WM_CAP_GET_AUDIOFORMAT = WM_CAP_START + 36

Public Const WM_CAP_DLG_VIDEOFORMAT = WM_CAP_START + 41
Public Const WM_CAP_DLG_VIDEOSOURCE = WM_CAP_START + 42
Public Const WM_CAP_DLG_VIDEODISPLAY = WM_CAP_START + 43
Public Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Public Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Public Const WM_CAP_DLG_VIDEOCOMPRESSION = WM_CAP_START + 46

Public Const WM_CAP_SET_PREVIEW = WM_CAP_START + 50
Public Const WM_CAP_SET_OVERLAY = WM_CAP_START + 51
Public Const WM_CAP_SET_PREVIEWRATE = WM_CAP_START + 52
Public Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Public Const WM_CAP_GET_STATUS = WM_CAP_START + 54
Public Const WM_CAP_SET_SCROLL = WM_CAP_START + 55

Public Const WM_CAP_GRAB_FRAME = WM_CAP_START + 60

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

135 回復:把焦點定位到任何已運行的窗口。
Public Const WM_CAP_GRAB_FRAME_NOSTOP = WM_CAP_START + 61

Public Const WM_CAP_SEQUENCE = WM_CAP_START + 62
Public Const WM_CAP_SEQUENCE_NOFILE = WM_CAP_START + 63
Public Const WM_CAP_SET_SEQUENCE_SETUP = WM_CAP_START + 64
Public Const WM_CAP_GET_SEQUENCE_SETUP = WM_CAP_START + 65
Public Const WM_CAP_SET_MCI_DEVICE = WM_CAP_START + 66
Public Const WM_CAP_GET_MCI_DEVICE = WM_CAP_START + 67
Public Const WM_CAP_STOP = WM_CAP_START + 68
Public Const WM_CAP_ABORT = WM_CAP_START + 69

Public Const WM_CAP_SINGLE_FRAME_OPEN = WM_CAP_START + 70
Public Const WM_CAP_SINGLE_FRAME_CLOSE = WM_CAP_START + 71
Public Const WM_CAP_SINGLE_FRAME = WM_CAP_START + 72

Public Const WM_CAP_PAL_OPEN = WM_CAP_START + 80
Public Const WM_CAP_PAL_SAVE = WM_CAP_START + 81
Public Const WM_CAP_PAL_PASTE = WM_CAP_START + 82
Public Const WM_CAP_PAL_AUTOCREATE = WM_CAP_START + 83
Public Const WM_CAP_PAL_MANUALCREATE = WM_CAP_START + 84

'// Following added post VFW 1.1
Public Const WM_CAP_SET_CALLBACK_CAPCONTROL = WM_CAP_START + 85

'// Defines end of the message range
Public Const WM_CAP_END = WM_CAP_SET_CALLBACK_CAPCONTROL

'// ------------------------------------------------------------------
'// Structures
'// ------------------------------------------------------------------
Type CAPDRIVERCAPS
wDeviceIndex As Long ' // Driver index in system.ini
fHasOverlay As Long ' // Can device overlay?
fHasDlgVideoSource As Long ' // Has Video source dlg?
fHasDlgVideoFormat As Long ' // Has Format dlg?
fHasDlgVideoDisplay As Long ' // Has External out dlg?
fCaptureInitialized As Long ' // Driver ready to capture?
fDriverSuppliesPalettes As Long ' // Can driver make palettes?
hVideoIn As Long ' // Driver In channel
hVideoOut As Long ' // Driver Out channel
hVideoExtIn As Long ' // Driver Ext In channel
hVideoExtOut As Long ' // Driver Ext Out channel
End Type

Type CAPSTATUS
uiImageWidth As Long '// Width of the image
uiImageHeight As Long '// Height of the image
fLiveWindow As Long '// Now Previewing video?
fOverlayWindow As Long '// Now Overlaying video?
fScale As Long '// Scale image to client?
ptScroll As POINTAPI '// Scroll position
fUsingDefaultPalette As Long '// Using default driver palette?
fAudioHardware As Long '// Audio hardware present?
fCapFileExists As Long '// Does capture file exist?
dwCurrentVideoFrame As Long '// # of video frames cap'td
dwCurrentVideoFramesDropped As Long '// # of video frames dropped
dwCurrentWaveSamples As Long '// # of wave samples cap'td
dwCurrentTimeElapsedMS As Long '// Elapsed capture duration
hPalCurrent As Long '// Current palette in use
fCapturingNow As Long '// Capture in progress?
dwReturn As Long '// Error value after any operation
wNumVideoAllocated As Long '// Actual number of video buffers
wNumAudioAllocated As Long '// Actual number of audio buffers
End Type

Type CAPTUREPARMS
dwRequestMicroSecPerFrame As Long '// Requested capture rate
fMakeUserHitOKToCapture As Long '// Show "Hit OK to cap" dlg?
wPercentDropForError As Long '// Give error msg if > (10%)

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

136 回復:把焦點定位到任何已運行的窗口。
fYield As Long '// Capture via background task?
dwIndexSize As Long '// Max index size in frames (32K)
wChunkGranularity As Long '// Junk chunk granularity (2K)
fUsingDOSMemory As Long '// Use DOS buffers?
wNumVideoRequested As Long '// # video buffers, If 0, autocalc
fCaptureAudio As Long '// Capture audio?
wNumAudioRequested As Long '// # audio buffers, If 0, autocalc
vKeyAbort As Long '// Virtual key causing abort
fAbortLeftMouse As Long '// Abort on left mouse?
fAbortRightMouse As Long '// Abort on right mouse?
fLimitEnabled As Long '// Use wTimeLimit?
wTimeLimit As Long '// Seconds to capture
fMCIControl As Long '// Use MCI video source?
fStepMCIDevice As Long '// Step MCI device?
dwMCIStartTime As Long '// Time to start in MS
dwMCIStopTime As Long '// Time to stop in MS
fStepCaptureAt2x As Long '// Perform spatial averaging 2x
wStepCaptureAverageFrames As Long '// Temporal average n Frames
dwAudioBufferSize As Long '// Size of audio bufs (0 = default)
fDisableWriteCache As Long '// Attempt to disable write cache
End Type

Type CAPINFOCHUNK
fccInfoID As Long '// Chunk ID, "ICOP" for copyright
lpData As Long '// pointer to data
cbData As Long '// size of lpData
End Type

Type VIDEOHDR
lpData As Long '// address of video buffer
dwBufferLength As Long '// size, in bytes, of the Data buffer
dwBytesUsed As Long '// see below
dwTimeCaptured As Long '// see below
dwUser As Long '// user-specific data
dwFlags As Long '// see below
dwReserved(3) As Long '// reserved; do not use}
End Type

'// The two functions exported by AVICap
Declare Function capCreateCaptureWindowA Lib "avicap32.dll" ( _
ByVal lpszWindowName As String, _
ByVal dwStyle As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Integer, _
ByVal hWndParent As Long, ByVal nID As Long) As Long
Declare Function capGetDriverDescriptionA Lib "avicap32.dll" ( _
ByVal wDriver As Integer, _
ByVal lpszName As String, _
ByVal cbName As Long, _
ByVal lpszVer As String, _
ByVal cbVer As Long) As Boolean

'// ------------------------------------------------------------------
'// String IDs from status and error callbacks
'// ------------------------------------------------------------------

Public Const IDS_CAP_BEGIN = 300 '/* "Capture Start" */
Public Const IDS_CAP_END = 301 '/* "Capture End" */

Public Const IDS_CAP_INFO = 401 '/* "%s" */
Public Const IDS_CAP_OUTOFMEM = 402 '/* "Out of memory" */
Public Const IDS_CAP_FILEEXISTS = 403 '/* "File '%s' exists -- overwrite it?" */
Public Const IDS_CAP_ERRORPALOPEN = 404 '/* "Error opening palette '%s'" */
Public Const IDS_CAP_ERRORPALSAVE = 405 '/* "Error saving palette '%s'" */
Public Const IDS_CAP_ERRORDIBSAVE = 406 '/* "Error saving frame '%s'" */
Public Const IDS_CAP_DEFAVIEXT = 407 '/* "avi" */
Public Const IDS_CAP_DEFPALEXT = 408 '/* "pal" */
Public Const IDS_CAP_CANTOPEN = 409 '/* "Cannot open '%s'" */
Public Const IDS_CAP_SEQ_MSGSTART = 410 '/* "Select OK to start capture\nof video sequence\nto %s." */

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

137 回復:把焦點定位到任何已運行的窗口。
Public Const IDS_CAP_SEQ_MSGSTOP = 411 '/* "Hit ESCAPE or click to end capture" */

Public Const IDS_CAP_VIDEDITERR = 412 '/* "An error occurred while trying to run VidEdit." */
Public Const IDS_CAP_READONLYFILE = 413 '/* "The file '%s' is a read-only file." */
Public Const IDS_CAP_WRITEERROR = 414 '/* "Unable to write to file '%s'.\nDisk may be full." */
Public Const IDS_CAP_NODISKSPACE = 415 '/* "There is no space to create a capture file on the specified device." */
Public Const IDS_CAP_SETFILESIZE = 416 '/* "Set File Size" */
Public Const IDS_CAP_SAVEASPERCENT = 417 '/* "SaveAs: %2ld%% Hit Escape to abort." */

Public Const IDS_CAP_DRIVER_ERROR = 418 '/* Driver specific error message */

Public Const IDS_CAP_WAVE_OPEN_ERROR = 419 '/* "Error: Cannot open the wave input device.\nCheck sample size, frequency, and channels." */
Public Const IDS_CAP_WAVE_ALLOC_ERROR = 420 '/* "Error: Out of memory for wave buffers." */
Public Const IDS_CAP_WAVE_PREPARE_ERROR = 421 '/* "Error: Cannot prepare wave buffers." */
Public Const IDS_CAP_WAVE_ADD_ERROR = 422 '/* "Error: Cannot add wave buffers." */
Public Const IDS_CAP_WAVE_SIZE_ERROR = 423 '/* "Error: Bad wave size." */

Public Const IDS_CAP_VIDEO_OPEN_ERROR = 424 '/* "Error: Cannot open the video input device." */
Public Const IDS_CAP_VIDEO_ALLOC_ERROR = 425 '/* "Error: Out of memory for video buffers." */
Public Const IDS_CAP_VIDEO_PREPARE_ERROR = 426 '/* "Error: Cannot prepare video buffers." */
Public Const IDS_CAP_VIDEO_ADD_ERROR = 427 '/* "Error: Cannot add video buffers." */
Public Const IDS_CAP_VIDEO_SIZE_ERROR = 428 '/* "Error: Bad video size." */

Public Const IDS_CAP_FILE_OPEN_ERROR = 429 '/* "Error: Cannot open capture file." */
Public Const IDS_CAP_FILE_WRITE_ERROR = 430 '/* "Error: Cannot write to capture file. Disk may be full." */
Public Const IDS_CAP_RECORDING_ERROR = 431 '/* "Error: Cannot write to capture file. Data rate too high or disk full." */
Public Const IDS_CAP_RECORDING_ERROR2 = 432 '/* "Error while recording" */
Public Const IDS_CAP_AVI_INIT_ERROR = 433 '/* "Error: Unable to initialize for capture." */
Public Const IDS_CAP_NO_FRAME_CAP_ERROR = 434 '/* "Warning: No frames captured.\nConfirm that vertical sync interrupts\nare configured and enabled." */
Public Const IDS_CAP_NO_PALETTE_WARN = 435 '/* "Warning: Using default palette." */
Public Const IDS_CAP_MCI_CONTROL_ERROR = 436 '/* "Error: Unable to access MCI device." */
Public Const IDS_CAP_MCI_CANT_STEP_ERROR = 437 '/* "Error: Unable to step MCI device." */
Public Const IDS_CAP_NO_AUDIO_CAP_ERROR = 438 '/* "Error: No audio data captured.\nCheck audio card settings." */
Public Const IDS_CAP_AVI_DRAWDIB_ERROR = 439 '/* "Error: Unable to draw this data format." */
Public Const IDS_CAP_COMPRESSOR_ERROR = 440 '/* "Error: Unable to initialize compressor." */
Public Const IDS_CAP_AUDIO_DROP_ERROR = 441 '/* "Error: Audio data was lost during capture, reduce capture rate." */

'/* status string IDs */
Public Const IDS_CAP_STAT_LIVE_MODE = 500 '/* "Live window" */

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

138 回復:把焦點定位到任何已運行的窗口。
Public Const IDS_CAP_STAT_OVERLAY_MODE = 501 '/* "Overlay window" */
Public Const IDS_CAP_STAT_CAP_INIT = 502 '/* "Setting up for capture - Please wait" */
Public Const IDS_CAP_STAT_CAP_FINI = 503 '/* "Finished capture, now writing frame %ld" */
Public Const IDS_CAP_STAT_PALETTE_BUILD = 504 '/* "Building palette map" */
Public Const IDS_CAP_STAT_OPTPAL_BUILD = 505 '/* "Computing optimal palette" */
Public Const IDS_CAP_STAT_I_FRAMES = 506 '/* "%d frames" */
Public Const IDS_CAP_STAT_L_FRAMES = 507 '/* "%ld frames" */
Public Const IDS_CAP_STAT_CAP_L_FRAMES = 508 '/* "Captured %ld frames" */
Public Const IDS_CAP_STAT_CAP_AUDIO = 509 '/* "Capturing audio" */
Public Const IDS_CAP_STAT_VIDEOCURRENT = 510 '/* "Captured %ld frames (%ld dropped) %d.%03d sec." */
Public Const IDS_CAP_STAT_VIDEOAUDIO = 511 '/* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps). %ld audio bytes (%d,%03d sps)" */
Public Const IDS_CAP_STAT_VIDEOONLY = 512 '/* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps)" */
Function capSetCallbackOnError(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnError = SendMessage(lwnd, WM_CAP_SET_CALLBACK_ERROR, 0, lpProc)
End Function
Function capSetCallbackOnStatus(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnStatus = SendMessage(lwnd, WM_CAP_SET_CALLBACK_STATUS, 0, lpProc)
End Function
Function capSetCallbackOnYield(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnYield = SendMessage(lwnd, WM_CAP_SET_CALLBACK_YIELD, 0, lpProc)
End Function
Function capSetCallbackOnFrame(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnFrame = SendMessage(lwnd, WM_CAP_SET_CALLBACK_FRAME, 0, lpProc)
End Function
Function capSetCallbackOnVideoStream(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnVideoStream = SendMessage(lwnd, WM_CAP_SET_CALLBACK_VIDEOSTREAM, 0, lpProc)
End Function
Function capSetCallbackOnWaveStream(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnWaveStream = SendMessage(lwnd, WM_CAP_SET_CALLBACK_WAVESTREAM, 0, lpProc)
End Function
Function capSetCallbackOnCapControl(ByVal lwnd As Long, ByVal lpProc As Long) As Boolean
capSetCallbackOnCapControl = SendMessage(lwnd, WM_CAP_SET_CALLBACK_CAPCONTROL, 0, lpProc)
End Function
Function capSetUserData(ByVal lwnd As Long, ByVal lUser As Long) As Boolean
capSetUserData = SendMessage(lwnd, WM_CAP_SET_USER_DATA, 0, lUser)
End Function
Function capGetUserData(ByVal lwnd As Long) As Long
capGetUserData = SendMessage(lwnd, WM_CAP_GET_USER_DATA, 0, 0)
End Function
Function capDriverConnect(ByVal lwnd As Long, ByVal i As Integer) As Boolean
capDriverConnect = SendMessage(lwnd, WM_CAP_DRIVER_CONNECT, i, 0)
End Function
Function capDriverDisconnect(ByVal lwnd As Long) As Boolean
capDriverDisconnect = SendMessage(lwnd, WM_CAP_DRIVER_DISCONNECT, 0, 0)
End Function
Function capDriverGetName(ByVal lwnd As Long, ByVal szName As Long, ByVal wSize As Integer) As Boolean
capDriverGetName = SendMessage(lwnd, YOURCONSTANTMESSAGE, wSize, szName)

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

139 回復:把焦點定位到任何已運行的窗口。
End Function
Function capDriverGetVersion(ByVal lwnd As Long, ByVal szVer As Long, ByVal wSize As Integer) As Boolean
capDriverGetVersion = SendMessage(lwnd, WM_CAP_DRIVER_GET_VERSION, wSize, szVer)
End Function
Function capDriverGetCaps(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capDriverGetCaps = SendMessage(lwnd, WM_CAP_DRIVER_GET_CAPS, wSize, s)
End Function
Function capFileSetCaptureFile(ByVal lwnd As Long, szName As String) As Boolean
capFileSetCaptureFile = SendMessageS(lwnd, WM_CAP_FILE_SET_CAPTURE_FILE, 0, szName)
End Function
Function capFileGetCaptureFile(ByVal lwnd As Long, ByVal szName As Long, wSize As String) As Boolean
capFileGetCaptureFile = SendMessageS(lwnd, WM_CAP_FILE_SET_CAPTURE_FILE, wSize, szName)
End Function
Function capFileAlloc(ByVal lwnd As Long, ByVal dwSize As Long) As Boolean
capFileAlloc = SendMessage(lwnd, WM_CAP_FILE_ALLOCATE, 0, dwSize)
End Function
Function capFileSaveAs(ByVal lwnd As Long, szName As String) As Boolean
capFileSaveAs = SendMessageS(lwnd, WM_CAP_FILE_SAVEAS, 0, szName)
End Function
Function capFileSetInfoChunk(ByVal lwnd As Long, ByVal lpInfoChunk As Long) As Boolean
capFileSetInfoChunk = SendMessage(lwnd, WM_CAP_FILE_SET_INFOCHUNK, 0, lpInfoChunk)
End Function
Function capFileSaveDIB(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capFileSaveDIB = SendMessage(lwnd, WM_CAP_FILE_SAVEDIB, 0, szName)
End Function
Function capEditCopy(ByVal lwnd As Long) As Boolean
capEditCopy = SendMessage(lwnd, WM_CAP_EDIT_COPY, 0, 0)
End Function
Function capSetAudioFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capSetAudioFormat = SendMessage(lwnd, WM_CAP_SET_AUDIOFORMAT, wSize, s)
End Function
Function capGetAudioFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Long
capGetAudioFormat = SendMessage(lwnd, WM_CAP_GET_AUDIOFORMAT, wSize, s)
End Function
Function capGetAudioFormatSize(ByVal lwnd As Long) As Long
capGetAudioFormatSize = SendMessage(lwnd, WM_CAP_GET_AUDIOFORMAT, 0, 0)
End Function
Function capDlgVideoFormat(ByVal lwnd As Long) As Boolean
capDlgVideoFormat = SendMessage(lwnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)
End Function
Function capDlgVideoSource(ByVal lwnd As Long) As Boolean
capDlgVideoSource = SendMessage(lwnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)
End Function
Function capDlgVideoDisplay(ByVal lwnd As Long) As Boolean
capDlgVideoDisplay = SendMessage(lwnd, WM_CAP_DLG_VIDEODISPLAY, 0, 0)
End Function
Function capDlgVideoCompression(ByVal lwnd As Long) As Boolean
capDlgVideoCompression = SendMessage(lwnd, WM_CAP_DLG_VIDEOCOMPRESSION, 0, 0)
End Function
Function capGetVideoFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Long
capGetVideoFormat = SendMessage(lwnd, WM_CAP_GET_VIDEOFORMAT, wSize, s)
End Function
Function capGetVideoFormatSize(ByVal lwnd As Long) As Long
capGetVideoFormatSize = SendMessage(lwnd, WM_CAP_GET_VIDEOFORMAT, 0, 0)
End Function
Function capSetVideoFormat(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

140 回復:把焦點定位到任何已運行的窗口。
capSetVideoFormat = SendMessage(lwnd, WM_CAP_SET_VIDEOFORMAT, wSize, s)
End Function
Function capPreview(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capPreview = SendMessage(lwnd, WM_CAP_SET_PREVIEW, f, 0)
End Function
Function capPreviewRate(ByVal lwnd As Long, ByVal wMS As Integer) As Boolean
capPreviewRate = SendMessage(lwnd, WM_CAP_SET_PREVIEWRATE, wMS, 0)
End Function
Function capOverlay(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capOverlay = SendMessage(lwnd, WM_CAP_SET_OVERLAY, f, 0)
End Function
Function capPreviewScale(ByVal lwnd As Long, ByVal f As Boolean) As Boolean
capPreviewScale = SendMessage(lwnd, WM_CAP_SET_SCALE, f, 0)
End Function
Function capGetStatus(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capGetStatus = SendMessage(lwnd, WM_CAP_GET_STATUS, wSize, s)
End Function
Function capSetScrollPos(ByVal lwnd As Long, ByVal lpP As Long) As Boolean
capSetScrollPos = SendMessage(lwnd, WM_CAP_SET_SCROLL, 0, lpP)
End Function
Function capGrabFrame(ByVal lwnd As Long) As Boolean
capGrabFrame = SendMessage(lwnd, WM_CAP_GRAB_FRAME, 0, 0)
End Function
Function capGrabFrameNoStop(ByVal lwnd As Long) As Boolean
capGrabFrameNoStop = SendMessage(lwnd, WM_CAP_GRAB_FRAME_NOSTOP, 0, 0)
End Function
Function capCaptureSequence(ByVal lwnd As Long) As Boolean
capCaptureSequence = SendMessage(lwnd, WM_CAP_SEQUENCE, 0, 0)
End Function
Function capCaptureSequenceNoFile(ByVal lwnd As Long) As Boolean
capCaptureSequenceNoFile = SendMessage(lwnd, WM_CAP_SEQUENCE_NOFILE, 0, 0)
End Function
Function capCaptureStop(ByVal lwnd As Long) As Boolean
capCaptureStop = SendMessage(lwnd, WM_CAP_STOP, 0, 0)
End Function
Function capCaptureAbort(ByVal lwnd As Long) As Boolean
capCaptureAbort = SendMessage(lwnd, WM_CAP_ABORT, 0, 0)
End Function
Function capCaptureSingleFrameOpen(ByVal lwnd As Long) As Boolean
capCaptureSingleFrameOpen = SendMessage(lwnd, WM_CAP_SINGLE_FRAME_OPEN, 0, 0)
End Function
Function capCaptureSingleFrameClose(ByVal lwnd As Long) As Boolean
capCaptureSingleFrameClose = SendMessage(lwnd, WM_CAP_SINGLE_FRAME_CLOSE, 0, 0)
End Function
Function capCaptureSingleFrame(ByVal lwnd As Long) As Boolean
capCaptureSingleFrame = SendMessage(lwnd, WM_CAP_SINGLE_FRAME, 0, 0)
End Function
Function capCaptureGetSetup(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capCaptureGetSetup = SendMessage(lwnd, WM_CAP_GET_SEQUENCE_SETUP, wSize, s)
End Function
Function capCaptureSetSetup(ByVal lwnd As Long, ByVal s As Long, ByVal wSize As Integer) As Boolean
capCaptureSetSetup = SendMessage(lwnd, WM_CAP_SET_SEQUENCE_SETUP, wSize, s)
End Function
Function capSetMCIDeviceName(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capSetMCIDeviceName = SendMessage(lwnd, WM_CAP_SET_MCI_DEVICE, 0, szName)
End Function
Function capGetMCIDeviceName(ByVal lwnd As Long, ByVal szName As Long, ByVal wSize As Integer) As Boolean
capGetMCIDeviceName = SendMessage(lwnd, WM_CAP_GET_MCI_DEVICE, wSize, szName)
End Function

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

141 回復:把焦點定位到任何已運行的窗口。
Function capPaletteOpen(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capPaletteOpen = SendMessage(lwnd, WM_CAP_PAL_OPEN, 0, szName)
End Function
Function capPaletteSave(ByVal lwnd As Long, ByVal szName As Long) As Boolean
capPaletteSave = SendMessage(lwnd, WM_CAP_PAL_SAVE, 0, szName)
End Function
Function capPalettePaste(ByVal lwnd As Long) As Boolean
capPalettePaste = SendMessage(lwnd, WM_CAP_PAL_PASTE, 0, 0)
End Function
Function capPaletteAuto(ByVal lwnd As Long, ByVal iFrames As Integer, ByVal iColor As Long) As Boolean
capPaletteAuto = SendMessage(lwnd, WM_CAP_PAL_AUTOCREATE, iFrames, iColors)
End Function
Function capPaletteManual(ByVal lwnd As Long, ByVal fGrab As Boolean, ByVal iColors As Long) As Boolean
capPaletteManual = SendMessage(lwnd, WM_CAP_PAL_MANUALCREATE, fGrab, iColors)
End Function

---------------
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ej@bantz.com
'* Web: http://ej.bantz.com
'*
Option Explicit

Private Sub Form_Load()

Dim lpszName As String * 100
Dim lpszVer As String * 100
Dim Caps As CAPDRIVERCAPS

'//Create Capture Window
capGetDriverDescriptionA 0, lpszName, 100, lpszVer, 100 '// Retrieves driver info
lwndC = capCreateCaptureWindowA(lpszName, WS_CAPTION Or WS_THICKFRAME Or WS_VISIBLE Or WS_CHILD, 0, 0, 160, 120, Me.hwnd, 0)

'// Set title of window to name of driver
SetWindowText lwndC, lpszName

'// Set the video stream callback function
capSetCallbackOnStatus lwndC, AddressOf MyStatusCallback
capSetCallbackOnError lwndC, AddressOf MyErrorCallback

'// Connect the capture window to the driver
If capDriverConnect(lwndC, 0) Then
'/////
'// Only do the following if the connect was successful.
'// if it fails, the error will be reported in the call
'// back function.
'/////
'// Get the capabilities of the capture driver
capDriverGetCaps lwndC, VarPtr(Caps), Len(Caps)

'// If the capture driver does not support a dialog, grey it out
'// in the menu bar.
If Caps.fHasDlgVideoSource = 0 Then mnuSource.Enabled = False
If Caps.fHasDlgVideoFormat = 0 Then mnuFormat.Enabled = False
If Caps.fHasDlgVideoDisplay = 0 Then mnuDisplay.Enabled = False

'// Turn Scale on
capPreviewScale lwndC, True

'// Set the preview rate in milliseconds
capPreviewRate lwndC, 66

'// Start previewing the image from the camera
capPreview lwndC, True

'// Resize the capture window to show the whole image
ResizeCaptureWindow lwndC

End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

'// Disable all callbacks
capSetCallbackOnError lwndC, vbNull
capSetCallbackOnStatus lwndC, vbNull
capSetCallbackOnYield lwndC, vbNull
capSetCallbackOnFrame lwndC, vbNull
capSetCallbackOnVideoStream lwndC, vbNull
capSetCallbackOnWaveStream lwndC, vbNull
capSetCallbackOnCapControl lwndC, vbNull

End Sub

Private Sub mnuAllocate_Click()

Dim sFile As String * 250
Dim lSize As Long

'// Setup swap file for capture
lSize = 1000000

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

142 回復:把焦點定位到任何已運行的窗口。
sFile = "C:\TEMP.AVI"
capFileSetCaptureFile lwndC, sFile
capFileAlloc lwndC, lSize

End Sub

Private Sub mnuAlwaysVisible_Click()

mnuAlwaysVisible.Checked = Not (mnuAlwaysVisible.Checked)

If mnuAlwaysVisible.Checked Then
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
Else
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
End If

End Sub

Private Sub mnuCompression_Click()
' /*
' * Display the Compression dialog when "Compression" is selected from
' * the menu bar.
' */

capDlgVideoCompression lwndC

End Sub

Private Sub mnuCopy_Click()

capEditCopy lwndC

End Sub

Private Sub mnuDisplay_Click()
' /*
' * Display the Video Display dialog when "Display" is selected from
' * the menu bar.
' */

capDlgVideoDisplay lwndC

End Sub

Private Sub mnuExit_Click()

Unload Me

End Sub

Private Sub mnuFormat_Click()
' /*
' * Display the Video Format dialog when "Format" is selected from the
' * menu bar.
' */

capDlgVideoFormat lwndC
ResizeCaptureWindow lwndC

End Sub

Private Sub mnuPreview_Click()

frmMain.StatusBar.SimpleText = vbNullString
mnuPreview.Checked = Not (mnuPreview.Checked)
capPreview lwndC, mnuPreview.Checked

End Sub

Private Sub mnuScale_Click()

mnuScale.Checked = Not (mnuScale.Checked)
capPreviewScale lwndC, mnuScale.Checked

If mnuScale.Checked Then
SetWindowLong lwndC, GWL_STYLE, WS_THICKFRAME Or WS_CAPTION Or WS_VISIBLE Or WS_CHILD
Else
SetWindowLong lwndC, GWL_STYLE, WS_BORDER Or WS_CAPTION Or WS_VISIBLE Or WS_CHILD
End If

ResizeCaptureWindow lwndC

End Sub

Private Sub mnuSelect_Click()

frmSelect.Show vbModal, Me

End Sub

Private Sub mnuSource_Click()
' /*
' * Display the Video Source dialog when "Source" is selected from the
' * menu bar.
' */

capDlgVideoSource lwndC

End Sub

Private Sub mnuStart_Click()
' /*
' * If Start is selected from the menu, start Streaming capture.
' * The streaming capture is terminated when the Escape key is pressed
' */

Dim sFileName As String
Dim CAP_PARAMS As CAPTUREPARMS

capCaptureGetSetup lwndC, VarPtr(CAP_PARAMS), Len(CAP_PARAMS)

CAP_PARAMS.dwRequestMicroSecPerFrame = (1 * (10 ^ 6)) / 30 ' 30 Frames per second
CAP_PARAMS.fMakeUserHitOKToCapture = True
CAP_PARAMS.fCaptureAudio = False

capCaptureSetSetup lwndC, VarPtr(CAP_PARAMS), Len(CAP_PARAMS)

sFileName = "C:\myvideo.avi"

capCaptureSequence lwndC ' Start Capturing!
capFileSaveAs lwndC, sFileName ' Copy video from swap file into a real file.

End Sub

Private Sub StatusBar1_PanelClick(ByVal Panel As ComctlLib.Panel)

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

Private Sub Command1_Click()

End Sub

Private Sub cmdCancel_Click()

Unload Me

End Sub

Private Sub cmdSelect_Click()

Dim sTitle As String
Dim Caps As CAPDRIVERCAPS

If cmboSource.ListIndex <> -1 Then

'// Connect the capture window to the driver
If capDriverConnect(lwndC, cmboSource.ListIndex) Then

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

143 回復:把焦點定位到任何已運行的窗口。

'// Get the capabilities of the capture driver
capDriverGetCaps lwndC, VarPtr(Caps), Len(Caps)

'// If the capture driver does not support a dialog, grey it out
'// in the menu bar.
frmMain.mnuSource.Enabled = Caps.fHasDlgVideoSource
frmMain.mnuFormat.Enabled = Caps.fHasDlgVideoFormat
frmMain.mnuDisplay.Enabled = Caps.fHasDlgVideoDisplay

sTitle = cmboSource.Text

SetWindowText lwndC, sTitle
ResizeCaptureWindow lwndC
End If

End If

Unload Me

End Sub

Private Sub Form_Load()

Dim lpszName As String * 100
Dim lpszVer As String * 100
Dim x As Integer
Dim lResult As Long
Dim Caps As CAPDRIVERCAPS

'// Get a list of all the installed drivers
x = 0
Do
lResult = capGetDriverDescriptionA(x, lpszName, 100, lpszVer, 100) '// Retrieves driver info
If lResult Then
cmboSource.AddItem lpszName
x = x + 1
End If
Loop Until lResult = False

'// Get the capabilities of the current capture driver
lResult = capDriverGetCaps(lwndC, VarPtr(Caps), Len(Caps))

'// Select the driver that is currently being used
If lResult Then cmboSource.ListIndex = Caps.wDeviceIndex

End Sub

-------------
'*
'* Author: E. J. Bantz Jr.
'* Copyright: None, use and distribute freely ...
'* E-Mail: ejbantz@usa.net
'* Web: http://www.inlink.com/~ejbantz

'// ------------------------------------------------------------------
'// Windows API Constants / Types / Declarations
'// ------------------------------------------------------------------
Public Const WS_BORDER = &H800000
Public Const WS_CAPTION = &HC00000
Public Const WS_SYSMENU = &H80000
Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_THICKFRAME = &H40000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = 1
Public Const SWP_NOZORDER = &H4
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SM_CYCAPTION = 4
Public Const SM_CXFRAME = 32
Public Const SM_CYFRAME = 33
Public Const WS_EX_TRANSPARENT = &H20&
Public Const GWL_STYLE = (-16)
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'// Memory manipulation
Declare Function lStrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Declare Function lStrCpyn Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As Any, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Declare Sub RtlMoveMemory Lib "kernel32" (ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
Declare Sub hmemcpy Lib "kernel32" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'// Window manipulation
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

144 回復:把焦點定位到任何已運行的窗口。
Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public lwndC As Long ' Handle to the Capture Windows

Function MyFrameCallback(ByVal lwnd As Long, ByVal lpVHdr As Long) As Long

Debug.Print "FrameCallBack"

Dim VideoHeader As VIDEOHDR
Dim VideoData() As Byte

'//Fill VideoHeader with data at lpVHdr
RtlMoveMemory VarPtr(VideoHeader), lpVHdr, Len(VideoHeader)

'// Make room for data
ReDim VideoData(VideoHeader.dwBytesUsed)

'//Copy data into the array
RtlMoveMemory VarPtr(VideoData(0)), VideoHeader.lpData, VideoHeader.dwBytesUsed

Debug.Print VideoHeader.dwBytesUsed
Debug.Print VideoData

End Function

Function MyYieldCallback(lwnd As Long) As Long

Debug.Print "Yield"

End Function

Function MyErrorCallback(ByVal lwnd As Long, ByVal iID As Long, ByVal ipstrStatusText As Long) As Long

If iID = 0 Then Exit Function

Dim sStatusText As String
Dim usStatusText As String

'Convert the Pointer to a real VB String
sStatusText = String$(255, 0) '// Make room for message
lStrCpy StrPtr(sStatusText), ipstrStatusText '// Copy message into String
sStatusText = Left$(sStatusText, InStr(sStatusText, Chr$(0)) - 1) '// Only look at left of null
usStatusText = StrConv(sStatusText, vbUnicode) '// Convert Unicode

LogError usStatusText, iID

End Function

Function MyStatusCallback(ByVal lwnd As Long, ByVal iID As Long, ByVal ipstrStatusText As Long) As Long

If iID = 0 Then Exit Function

Dim sStatusText As String
Dim usStatusText As String

'// Convert the Pointer to a real VB String
sStatusText = String$(255, 0) '// Make room for message
lStrCpy StrPtr(sStatusText), ipstrStatusText '// Copy message into String
sStatusText = Left$(sStatusText, InStr(sStatusText, Chr$(0)) - 1) '// Only look at left of null
usStatusText = StrConv(sStatusText, vbUnicode) '// Convert Unicode

frmMain.StatusBar.SimpleText = usStatusText
Debug.Print "Status: ", usStatusText, iID

Select Case iID '

End Select

End Function

Sub ResizeCaptureWindow(ByVal lwnd As Long)

Dim CAPSTATUS As CAPSTATUS
Dim lCaptionHeight As Long
Dim lX_Border As Long
Dim lY_Border As Long

lCaptionHeight = GetSystemMetrics(SM_CYCAPTION)
lX_Border = GetSystemMetrics(SM_CXFRAME)
lY_Border = GetSystemMetrics(SM_CYFRAME)

'// Get the capture window attributes .. width and height
If capGetStatus(lwnd, VarPtr(CAPSTATUS), Len(CAPSTATUS)) Then

'// Resize the capture window to the capture sizes
SetWindowPos lwnd, HWND_BOTTOM, 0, 0, _
CAPSTATUS.uiImageWidth + (lX_Border * 2), _
CAPSTATUS.uiImageHeight + lCaptionHeight + (lY_Border * 2), _
SWP_NOMOVE Or SWP_NOZORDER
End If

Debug.Print "Resize Window."

End Sub

Function MyVideoStreamCallback(lwnd As Long, lpVHdr As Long) As Long

Beep '// Replace this with your code!

End Function

Function MyWaveStreamCallback(lwnd As Long, lpVHdr As Long) As Long

Debug.Print "WaveStream"

End Function

Sub LogError(txtError As String, lID As Long)

frmMain.StatusBar.SimpleText = txtError
Debug.Print "Error: ", txtError, lID

End Sub

作者: 61.142.212.* 2005-10-28 22:07 　回復此發言

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

145 利用微軟的語音引擎使你的程序會朗讀,需要安裝微軟語音引擎或者金
Dim vText As New VTxtAuto.VTxtAuto

Private Sub Command1_Click()
Dim astr As String

Command1.Enabled = False
vText.Register vbNullString, "Speech"
'vtext.Register
astr = "This is a sample of Microsoft Speech Engine?"
vText.Speak astr, vtxtsp_NORMAL Or vtxtst_QUESTION
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set vText = Nothing
End Sub

作者: 61.142.212.* 2005-10-28 22:09 　回復此發言

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

146 一個屏幕保護的程序(流星)。
Private W As Integer
Private H As Integer

Private Sub Command1_Click()
Label1.Visible = False
MoveTo = move_forward
Command1.Visible = False
Accelarate = False
WindowState = 2
W = ScaleWidth
H = ScaleHeight

For i = 1 To 150

Star(i).x = W / 2
Star(i).y = H / 2
RandomX:
Randomize
Star(i).AddX = Int(Rnd * 29) - Int(Rnd * 29)
If Star(i).AddX = 0 Then GoTo RandomX
RandomY:
Star(i).AddY = Int(Rnd * 19) - Int(Rnd * 19)
If Star(i).AddY = 0 Then GoTo RandomY

Next

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
End
End If

If KeyCode = vbKeySpace Then Accelarate = True
If KeyCode = vbKeyF1 Then
ChDir App.Path
Shell "NOTEPAD.EXE 3Dstarfield.txt", vbMaximizedFocus
End If

End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeySpace Then Accelarate = False

End Sub

Private Sub Form_Load()

Move Screen.Width / 2 - Width / 2, Screen.Height / 2 - Height / 2
Command1.Move ScaleWidth / 2 - Command1.Width / 2, ScaleHeight / 4 - Command1.Height / 2
Label1.Move ScaleWidth / 2 - Label1.Width / 2, ScaleHeight / 2 - Label1.Height / 2

End Sub

Private Sub Timer1_Timer()
If Command1.Visible = True Then Exit Sub

For i = 1 To 150

SetPixel hdc, W / 2, H / 2, &H404040

Select Case Abs(W / 2 - (Star(i).x))
Case Is < 20
col = &H0&
Size = 1
Case Is < 80
col = &H404040
Size = 1
Case Is < 150
col = &H808080
Size = 2
Case Is < 200
col = &HC0C0C0
Size = 3
Case Is < 250
col = &HFFFFFF
Size = 4
Case Else
col = &HFFFFFF
Size = 5

End Select

Select Case Abs(H / 2 - (Star(i).y))

Case Is < 20
If Size = 0 Then
Size = 1
col = back5
End If
Case Is < 80
If Size = 0 Then
col = &H404040
Size = 1
End If
Case Is < 150
If Size < 2 Then
Size = 2
col = &H808080
End If
Case Is < 200
If Size < 3 Then
Size = 3
col = &HC0C0C0
End If
Case Is < 250
If Size < 4 Then
Size = 4
col = &HFFFFFF
End If
Case Else
If Size < 5 Then
Size = 5
col = &HFFFFFF
End If

End Select

SetPixel hdc, W / 2, H / 2, col

Select Case Size
Case 1
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
Case 2
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
Case 3
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
Case 4
SetPixel Me.hdc, Star(i).x, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1, Star(i).y, &H0&

作者: 61.142.212.* 2005-10-28 22:10 　回復此發言

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

147 一個屏幕保護的程序(流星)。
SetPixel Me.hdc, Star(i).x - 1, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
Case 5
SetPixel Me.hdc, Star(i).x + a, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + a, Star(i).y - 1, &H0&
SetPixel Me.hdc, Star(i).x + a, Star(i).y - 2, &H0&
SetPixel Me.hdc, Star(i).x - 1 + a, Star(i).y - 2, &H0&
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 1 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x + Star(i).AddX, Star(i).y - 2 + Star(i).AddY, col
SetPixel Me.hdc, Star(i).x - 1 + Star(i).AddX, Star(i).y - 2 + Star(i).AddY, col
End Select

Star(i).x = Star(i).x + Star(i).AddX
Star(i).y = Star(i).y + Star(i).AddY
Star(i).AddX = Star(i).AddX + Sgn(Star(i).AddX) * (Size / 5)
Star(i).AddY = Star(i).AddY + Sgn(Star(i).AddY) * (Size / 5)
If Accelarate Then
Star(i).AddX = Star(i).AddX + Sgn(Star(i).AddX) * Size
Star(i).AddY = Star(i).AddY + Sgn(Star(i).AddY) * Size
End If

If Star(i).x < 0 Or Star(i).x > ScaleWidth Or Star(i).y < 0 Or Star(i).y > ScaleHeight Then
Star(i).x = W / 2
Star(i).y = H / 2
RandomX:
Randomize
Star(i).AddX = Int(Rnd * 29) - Int(Rnd * 29)
If Star(i).AddX = 0 Then GoTo RandomX
RandomY:
Star(i).AddY = Int(Rnd * 19) - Int(Rnd * 19)
If Star(i).AddY = 0 Then GoTo RandomY
End If

End Sub

-------------
Public Type Stars
x As Double
y As Integer
AddX As Integer
AddY As Integer
End Type

Public Star(1000) As Stars
Public Accelarate As Boolean

Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

作者: 61.142.212.* 2005-10-28 22:10 　回復此發言

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

148 MIDI電子琴(建議裝上軟波表)。(強力推薦)
' 《VB前線》http://vbbattlefront.163.net
'************************************************************
'* VB 系列功能演示程序 *
'* *
'* 如果您發現此程序有任何不妥之處或存在需要改進的地方, *
'* 望告訴我本人,本人將非常感激您,并一定回信致謝! *
'* *
'* by 池星澤(Xing) my Email:vbxing@990.net *
'************************************************************
'*程序編號∶033
'*功能∶MIDI電子琴
'*日期∶4/25/1999
'************************************************************
Option Explicit

Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey As Long)
Private sudu As Integer
Private Const VK_LBUTTON& = &H1
Private isOgain As Boolean '是否重復按鍵
Private Sta As Integer
Private Sub ComDevies_Click()
Dim dl As Integer
dl = MIDI_OutOpen(ComDevies.ItemData(ComDevies.ListIndex))
End Sub

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Command2_Click()
Open App.Path & "\haap.txt" For Input As #1
ComDevies.ListIndex = 0
ComSounds.ListIndex = 9
HScroll1.Value = 32
Timer2.Enabled = True
Command2.Enabled = False
End Sub

Private Sub ComSounds_Click()
Call program_change(0, 0, ComSounds.ListIndex)
End Sub

Private Sub Form_Load()
Dim Retu As Boolean
Dim i As Integer

Retu = Midi_OutDevsToList(ComDevies)
ComDevies.ListIndex = 0
Call fill_sound_list

For i = 0 To 64
Picture1(i).DragMode = 1
Next
HScroll1.Value = 36
HScroll2.Value = 127
End Sub
Private Sub fill_sound_list()
Dim s As String

Open App.Path & "\genmidi.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, s
ComSounds.AddItem s
Loop
ComSounds.ListIndex = 0
Close #1
End Sub

Private Sub Form_Unload(Cancel As Integer)
midi_OutClose
End
End Sub

Private Sub HScroll1_Change()
Sta = HScroll1.Value
Label2.Caption = Diao(Sta Mod 12)
End Sub

Private Sub HScroll2_Change()
sudu = HScroll2.Value
End Sub

Private Sub HScroll3_Change()
Label6.Caption = HScroll3.Value
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim i As Integer
For i = 0 To 64 '關閉所有的發音
Call note_off(0, i + Sta)
Next
End Sub

Private Sub Picture1_DragOver(Index As Integer, Source As Control, x As Single, Y As Single, State As Integer)
'完成發音
Static OldNote As Integer
If (OldNote <> Index) Or (isOgain = True) Then
Call note_off(0, OldNote + Sta)
Call note_on(0, Index + Sta, sudu) '參數分別為通道編號,音調,速度
OldNote = Index
isOgain = False
End If
End Sub
Private Sub Timer1_Timer()
Dim MyKey As Integer
MyKey% = GetKeyState(VK_LBUTTON)
If MyKey% And &H4000 Then
isOgain = False
Else
isOgain = True
End If
End Sub

Private Sub Timer2_Timer()
Dim s As String
Dim Index As Integer
Line Input #1, s
s = Trim(s)
If s = "End" Then
Close #1
Timer2.Enabled = False
Command2.Enabled = True
Label1_MouseMove 0, 0, 1, 1
Exit Sub
End If
Index = Val(s)
If Index < 100 Then
Index = Index + 7
Picture1_DragOver Index, Picture1(Index), 1, 1, 1
Index = Index + 24

作者: 61.142.212.* 2005-10-28 22:12 　回復此發言

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

149 MIDI電子琴(建議裝上軟波表)。(強力推薦)
Picture1_DragOver Index, Picture1(Index), 1, 1, 1
End If
isOgain = True
End Sub
Private Function Diao(i As Integer) As String
Select Case i
Case 0
Diao = "C"
Case 1
Diao = "C#"
Case 2
Diao = "D"
Case 3
Diao = "D#"
Case 4
Diao = "E"
Case 5
Diao = "F"
Case 6
Diao = "F#"
Case 7
Diao = "G"
Case 8
Diao = "G#"
Case 9
Diao = "A"
Case 10
Diao = "A#"
Case 11
Diao = "B"
End Select
End Function
---------------
Option Explicit

Private Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
Private Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
Private Declare Function MIDIOutOpen Lib "winmm.dll" Alias "midiOutOpen" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
Private Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long
Private Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
Private Declare Function midiOutGetErrorText Lib "winmm.dll" Alias "midiOutGetErrorTextA" (ByVal err As Long, ByVal lpText As String, ByVal uSize As Long) As Long

Private Const MAXERRORLENGTH = 128 ' max error text length (including NULL)

Private Const MIDIMAPPER = (-1)
Private Const MIDI_MAPPER = (-1)
'MIDIOUTCAPS結構描述了Musical Instrument Digital Interface(MIDI)輸入設備的性能
Type MIDIOUTCAPS
wMid As Integer
wPid As Integer ' 產品 ID
vDriverVersion As Long ' 設備版本
szPname As String * 32 ' 設備 name
wTechnology As Integer ' 設備類型
wVoices As Integer
wNotes As Integer
wChannelMask As Integer
dwSupport As Long
End Type

Dim hMidi As Long

Public Function Midi_OutDevsToList(Obj As Control) As Boolean
Dim i As Integer
Dim midicaps As MIDIOUTCAPS
Dim isAdd As Boolean

Obj.Clear
isAdd = False
If midiOutGetDevCaps(MIDIMAPPER, midicaps, Len(midicaps)) = 0 Then '若獲取設備信息成功
Obj.AddItem midicaps.szPname '添加設備名稱
Obj.ItemData(Obj.NewIndex) = MIDIMAPPER '這是默認設備ID = -1
isAdd = True
End If
'添加其他設備
For i = 0 To midiOutGetNumDevs() - 1
If midiOutGetDevCaps(i, midicaps, Len(midicaps)) = 0 Then
Obj.AddItem midicaps.szPname
Obj.ItemData(Obj.NewIndex) = i
isAdd = True
End If
Next
Midi_OutDevsToList = isAdd
End Function
Public Function MIDI_OutOpen(ByVal dev_id As Integer) As Integer
Dim midi_error As Integer

midi_OutClose
midi_error = MIDIOutOpen(hMidi, dev_id, 0, 0, 0)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
MIDI_OutOpen = (hMidi <> 0)
End Function
Public Sub midi_OutClose()
Dim midi_error As Integer

If hMidi <> 0 Then
midi_error = midiOutClose(hMidi)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
hMidi = 0
End If
End Sub
Public Sub note_on(ch As Integer, ByVal kk As Integer, v As Integer)
Call midi_outshort(&H90 + ch, kk, v)
End Sub

Public Sub note_off(ch As Integer, ByVal kk As Integer)
Call midi_outshort(&H80 + ch, kk, 0)
End Sub

Sub midi_outshort(b1 As Integer, b2 As Integer, b3 As Integer)
Dim midi_error As Integer

midi_error = midiOutShortMsg(hMidi, b3 * &H10000 + b2 * &H100 + b1)
If Not midi_error = 0 Then
Call midi_outerr(midi_error)
End If
End Sub
Sub program_change(ch As Integer, cc0nr As Integer, ByVal pnr As Integer)
Call control_change(ch, 0, cc0nr)
Call midi_outshort(&HC0 + ch, pnr, 0)
End Sub
Sub control_change(ch As Integer, ccnr As Integer, ByVal v As Integer)
Call midi_outshort(&HB0 + ch, ccnr, v)
End Sub

Sub midisetrpn(ch As Integer, pmsb As Integer, plsb As Integer, msb As Integer, lsb As Integer)
Call midi_outshort(ch, &H65, pmsb)
Call midi_outshort(ch, &H64, plsb)
Call midi_outshort(ch, &H6, msb)
Call midi_outshort(ch, &H26, lsb)
End Sub
Sub midi_outerr(ByVal midi_error As Integer)
Dim s As String
Dim x As Integer

s = Space(MAXERRORLENGTH)
x = midiOutGetErrorText(midi_error, s, MAXERRORLENGTH)
MsgBox s

End Sub

作者: 61.142.212.* 2005-10-28 22:12 　回復此發言

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

150 電子琴
Option Explicit

Const INVALID_NOTE = -1 ' Code for keyboard keys that we don't handle

Dim numDevices As Long ' number of midi output devices
Dim curDevice As Long ' current midi device
Dim hmidi As Long ' midi output handle
Dim rc As Long ' return code
Dim midimsg As Long ' midi output message buffer
Dim channel As Integer ' midi output channel
Dim volume As Integer ' midi volume
Dim baseNote As Integer ' the first note on our "piano"

' Set the value for the starting note of the piano
Private Sub base_Click()
Dim s As String
Dim i As Integer
s = InputBox("Enter the new base note for the keyboard (0 - 111)", "Base note", CStr(baseNote))
If IsNumeric(s) Then
i = CInt(s)
If (i >= 0 And i < 112) Then
baseNote = i
End If
End If
End Sub

' Select the midi output channel
Private Sub chan_Click(Index As Integer)
chan(channel).Checked = False
channel = Index
chan(channel).Checked = True
End Sub

' Open the midi device selected in the menu. The menu index equals the
' midi device number + 1.
Private Sub device_Click(Index As Integer)
device(curDevice + 1).Checked = False
device(Index).Checked = True
curDevice = Index - 1
rc = midiOutClose(hmidi)
rc = midiOutOpen(hmidi, curDevice, 0, 0, 0)
If (rc <> 0) Then
MsgBox "Couldn't open midi out, rc = " & rc
End If
End Sub

' If user presses a keyboard key, start the corresponding midi note
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
StartNote NoteFromKey(KeyCode)
End Sub

' If user lifts a keyboard key, stop the corresponding midi note
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
StopNote NoteFromKey(KeyCode)
End Sub

Private Sub Form_Load()
Dim i As Long
Dim caps As MIDIOUTCAPS

' Set the first device as midi mapper
device(0).Caption = "MIDI Mapper"
device(0).Visible = True
device(0).Enabled = True

' Get the rest of the midi devices
numDevices = midiOutGetNumDevs()
For i = 0 To (numDevices - 1)
midiOutGetDevCaps i, caps, Len(caps)
device(i + 1).Caption = caps.szPname
device(i + 1).Visible = True
device(i + 1).Enabled = True
Next

' Select the MIDI Mapper as the default device
device_Click (0)

' Set the default channel
channel = 0
chan(channel).Checked = True

' Set the base note
baseNote = 60

' Set volume range
volume = 127
vol.Min = 127
vol.Max = 0
vol.Value = volume

End Sub

Private Sub Form_Unload(Cancel As Integer)
' Close current midi device
rc = midiOutClose(hmidi)
End Sub

' Start a note when user click on it
Private Sub key_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StartNote (Index)
End Sub

' Stop the note when user lifts the mouse button
Private Sub key_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
StopNote (Index)
End Sub

' Press the button and send midi start event
Private Sub StartNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
If (key(Index).Value = 1) Then

151 電子琴
Exit Sub
End If
key(Index).Value = 1
midimsg = &H90 + ((baseNote + Index) * &H100) + (volume * &H10000) + channel
midiOutShortMsg hmidi, midimsg
End Sub

' Raise the button and send midi stop event
Private Sub StopNote(Index As Integer)
If (Index = INVALID_NOTE) Then
Exit Sub
End If
key(Index).Value = 0
midimsg = &H80 + ((baseNote + Index) * &H100) + channel
midiOutShortMsg hmidi, midimsg
End Sub

' Get the note corresponding to a keyboard key
Private Function NoteFromKey(key As Integer)
NoteFromKey = INVALID_NOTE
Select Case key
Case vbKeyZ
NoteFromKey = 0
Case vbKeyS
NoteFromKey = 1
Case vbKeyX
NoteFromKey = 2
Case vbKeyD
NoteFromKey = 3
Case vbKeyC
NoteFromKey = 4
Case vbKeyV
NoteFromKey = 5
Case vbKeyG
NoteFromKey = 6
Case vbKeyB
NoteFromKey = 7
Case vbKeyH
NoteFromKey = 8
Case vbKeyN
NoteFromKey = 9
Case vbKeyJ
NoteFromKey = 10
Case vbKeyM
NoteFromKey = 11
Case 188 ' comma
NoteFromKey = 12
Case vbKeyL
NoteFromKey = 13
Case 190 ' period
NoteFromKey = 14
Case 186 ' semicolon
NoteFromKey = 15
Case 191 ' forward slash
NoteFromKey = 16
End Select

End Function

' Set the volume
Private Sub vol_Change()
volume = vol.Value
End Sub
-------
'This is a complete piano application u can contact me at haisrini@email.com

Option Explicit

Public Const MAXPNAMELEN = 32 ' Maximum product name length

' Error values for functions used in this sample. See the function for more information
Public Const MMSYSERR_BASE = 0
Public Const MMSYSERR_BADDEVICEID = (MMSYSERR_BASE + 2) ' device ID out of range
Public Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Public Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Public Const MMSYSERR_NOMEM = (MMSYSERR_BASE + 7) ' memory allocation error

Public Const MMSYSERR_INVALHANDLE = (MMSYSERR_BASE + 5) ' device handle is invalid
Public Const MIDIERR_BASE = 64
Public Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1) ' still something playing
Public Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3) ' hardware is still busy
Public Const MIDIERR_BADOPENMODE = (MIDIERR_BASE + 6) ' operation unsupported w/ open mode

'User-defined variable the stores information about the MIDI output device.
Type MIDIOUTCAPS
wMid As Integer ' Manufacturer identifier of the device driver for the MIDI output device
' For a list of identifiers, see the Manufacturer Indentifier topic in the
' Multimedia Reference of the Platform SDK.

wPid As Integer ' Product Identifier Product of the MIDI output device. For a list of
' product identifiers, see the Product Identifiers topic in the Multimedia
' Reference of the Platform SDK.

vDriverVersion As Long ' Version number of the device driver for the MIDI output device.
' The high-order byte is the major version number, and the low-order byte is
' the minor version number.

szPname As String * MAXPNAMELEN ' Product name in a null-terminated string.

wTechnology As Integer ' One of the following that describes the MIDI output device:

作者: 61.142.212.* 2005-10-28 22:18 　回復此發言

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

152 電子琴
' MOD_FMSYNTH-The device is an FM synthesizer.
' MOD_MAPPER-The device is the Microsoft MIDI mapper.
' MOD_MIDIPORT-The device is a MIDI hardware port.
' MOD_SQSYNTH-The device is a square wave synthesizer.
' MOD_SYNTH-The device is a synthesizer.

wVoices As Integer ' Number of voices supported by an internal synthesizer device. If the
' device is a port, this member is not meaningful and is set to 0.

wNotes As Integer ' Maximum number of simultaneous notes that can be played by an internal
' synthesizer device. If the device is a port, this member is not meaningful
' and is set to 0.

wChannelMask As Integer ' Channels that an internal synthesizer device responds to, where the least
' significant bit refers to channel 0 and the most significant bit to channel
' 15. Port devices that transmit on all channels set this member to 0xFFFF.

dwSupport As Long ' One of the following describes the optional functionality supported by
' the device:
' MIDICAPS_CACHE-Supports patch caching.
' MIDICAPS_LRVOLUME-Supports separate left and right volume control.
' MIDICAPS_STREAM-Provides direct support for the midiStreamOut function.
' MIDICAPS_VOLUME-Supports volume control.
'
' If a device supports volume changes, the MIDICAPS_VOLUME flag will be set
' for the dwSupport member. If a device supports separate volume changes on
' the left and right channels, both the MIDICAPS_VOLUME and the
' MIDICAPS_LRVOLUME flags will be set for this member.
End Type

Declare Function midiOutGetNumDevs Lib "winmm" () As Integer
' This function retrieves the number of MIDI output devices present in the system.
' The function returns the number of MIDI output devices. A zero return value means
' there are no MIDI devices in the system.

Declare Function midiOutGetDevCaps Lib "winmm.dll" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Long, lpCaps As MIDIOUTCAPS, ByVal uSize As Long) As Long
' This function queries a specified MIDI output device to determine its capabilities.
' The function requires the following parameters;
' uDeviceID- unsigned integer variable identifying of the MIDI output device. The
' device identifier specified by this parameter varies from zero to one
' less than the number of devices present. This parameter can also be a
' properly cast device handle.
' lpMidiOutCaps- address of a MIDIOUTCAPS structure. This structure is filled with
' information about the capabilities of the device.
' cbMidiOutCaps- the size, in bytes, of the MIDIOUTCAPS structure. Use the Len
' function with the MIDIOUTCAPS variable as the argument to get
' this value.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MMSYSERR_BADDEVICEID The specified device identifier is out of range.
' MMSYSERR_INVALPARAM The specified pointer or structure is invalid.
' MMSYSERR_NODRIVER The driver is not installed.
' MMSYSERR_NOMEM The system is unable to load mapper string description.

Declare Function midiOutClose Lib "winmm.dll" (ByVal hMidiOut As Long) As Long

作者: 61.142.212.* 2005-10-28 22:18 　回復此發言

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

153 電子琴
' The function closes the specified MIDI output device. The function requires a
' handle to the MIDI output device. If the function is successful, the handle is no
' longer valid after the call to this function. A successful function call returns
' MMSYSERR_NOERROR.

' A failure returns one of the following:
' MIDIERR_STILLPLAYING Buffers are still in the queue.
' MMSYSERR_INVALHANDLE The specified device handle is invalid.
' MMSYSERR_NOMEM The system is unable to load mapper string description.

Declare Function midiOutOpen Lib "winmm.dll" (lphMidiOut As Long, ByVal uDeviceID As Long, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Long
' The function opens a MIDI output device for playback. The function requires the
' following parameters
' lphmo- Address of an HMIDIOUT handle. This location is filled with a
' handle identifying the opened MIDI output device. The handle
' is used to identify the device in calls to other MIDI output
' functions.
' uDeviceID- Identifier of the MIDI output device that is to be opened.
' dwCallback- Address of a callback function, an event handle, a thread
' identifier, or a handle of a window or thread called during
' MIDI playback to process messages related to the progress of
' the playback. If no callback is desired, set this value to 0.
' dwCallbackInstance- User instance data passed to the callback. Set this value to 0.
' dwFlags-Callback flag for opening the device. Set this value to 0.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MIDIERR_NODEVICE- No MIDI port was found. This error occurs only when the mapper is opened.
' MMSYSERR_ALLOCATED- The specified resource is already allocated.
' MMSYSERR_BADDEVICEID- The specified device identifier is out of range.
' MMSYSERR_INVALPARAM- The specified pointer or structure is invalid.
' MMSYSERR_NOMEM- The system is unable to allocate or lock memory.

Declare Function midiOutShortMsg Lib "winmm.dll" (ByVal hMidiOut As Long, ByVal dwMsg As Long) As Long
' This function sends a short MIDI message to the specified MIDI output device. The function
' requires the handle to the MIDI output device and a message is packed into a doubleword
' value with the first byte of the message in the low-order byte. See the code sample for
' how to create this value.
'
' The function returns MMSYSERR_NOERROR if successful or one of the following error values:
' MIDIERR_BADOPENMODE- The application sent a message without a status byte to a stream handle.
' MIDIERR_NOTREADY- The hardware is busy with other data.
' MMSYSERR_INVALHANDLE- The specified device handle is invalid.

作者: 61.142.212.* 2005-10-28 22:18 　回復此發言

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

154 回復:把焦點定位到任何已運行的窗口。
Option Explicit

Private Sub cmdScreen_Click()
Set Picture1.Picture = CaptureScreen()
End Sub

Private Sub cmdForm_Click()
'
' Get the whole form inclusing borders, caption,...
'
Set Picture1.Picture = CaptureForm(Me)
End Sub

Private Sub cmdClient_Click()
'
' Just get the client area of the form,
' no borders, caption,...
'
Set Picture1.Picture = CaptureClient(Me)
End Sub

Private Sub cmdActive_Click()
Dim EndTime As Date
'
' Give the user 2 seconds to activate
' a window then capture it.
'
MsgBox "Two seconds after you close this dialog " & _
"the active window will be captured.", _
vbInformation, "Capture Active Window"
'
' Wait for two seconds
'
EndTime = DateAdd("s", 2, Now)
Do Until Now > EndTime
DoEvents
Loop
'
' Get the active window.
' Set focus back to form
'
Set Picture1.Picture = CaptureActiveWindow()
Me.SetFocus
End Sub

Private Sub cmdPrint_Click()
'
' Print the contents of the picturebox.
'
Call PrintPictureToFitPage(Printer, Picture1.Picture)
Printer.EndDoc
End Sub

Private Sub cmdClear_Click()
Set Picture1.Picture = Nothing
End Sub

Private Sub Form_Load()
'
' Capture any form or window including the screen into a
' Visual Basic Picture object. Once the on-screen image
' is captured in the Picture object, it can be printed
' using the PaintPicture method of the Visual Basic
' Printer object.
'
' Automatically resize the picturebox
' according to the size of its contents.
'
Picture1.AutoSize = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set frmCapture = Nothing
End Sub

------------
Option Explicit
Option Base 0
'
' This module contains several routines for capturing windows into a
' picture. All routines have palette support.
'
' CreateBitmapPicture - Creates a picture object from a bitmap and palette.
' CaptureWindow - Captures any window given a window handle.
' CaptureActiveWindow - Captures the active window on the desktop.
' CaptureForm - Captures the entire form.
' CaptureClient - Captures the client area of a form.
' CaptureScreen - Captures the entire screen.
' PrintPictureToFitPage - prints any picture as big as possible on the page.
'
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type

Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

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

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
'
' DC = Device Context
'
' Creates a bitmap compatible with the device associated
' with the specified DC.
Private Declare Function CreateCompatibleBitmap Lib "GDI32" ( _

作者: 61.142.212.* 2005-10-28 22:22 　回復此發言

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

155 回復:把焦點定位到任何已運行的窗口。
ByVal hDC As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long

' Retrieves device-specific information about a specified device.
Private Declare Function GetDeviceCaps Lib "GDI32" ( _
ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long

' Retrieves a range of palette entries from the system palette
' associated with the specified DC.
Private Declare Function GetSystemPaletteEntries Lib "GDI32" ( _
ByVal hDC As Long, ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) _
As Long

' Creates a memory DC compatible with the specified device.
Private Declare Function CreateCompatibleDC Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Creates a logical color palette.
Private Declare Function CreatePalette Lib "GDI32" ( _
lpLogPalette As LOGPALETTE) As Long

' Selects the specified logical palette into a DC.
Private Declare Function SelectPalette Lib "GDI32" ( _
ByVal hDC As Long, ByVal hPalette As Long, _
ByVal bForceBackground As Long) As Long

' Maps palette entries from the current logical
' palette to the system palette.
Private Declare Function RealizePalette Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Selects an object into the specified DC. The new
' object replaces the previous object of the same type.
' Returned is the handle of the replaced object.
Private Declare Function SelectObject Lib "GDI32" ( _
ByVal hDC As Long, ByVal hObject As Long) As Long

' Performs a bit-block transfer of color data corresponding to
' a rectangle of pixels from the source DC into a destination DC.
Private Declare Function BitBlt Lib "GDI32" ( _
ByVal hDCDest As Long, ByVal XDest As Long, _
ByVal YDest As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hDCSrc As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
As Long

' Retrieves the DC for the entire window, including title bar,
' menus, and scroll bars. A window DC permits painting anywhere
' in a window, because the origin of the DC is the upper-left
' corner of the window instead of the client area.
Private Declare Function GetWindowDC Lib "USER32" ( _
ByVal hWnd As Long) As Long

' Retrieves a handle to a display DC for the Client area of
' a specified window or for the entire screen. You can use
' the returned handle in subsequent GDI functions to draw in
' the DC.
Private Declare Function GetDC Lib "USER32" ( _
ByVal hWnd As Long) As Long

' Releases a DC, freeing it for use by other applications.
' The effect of the ReleaseDC function depends on the type
' of DC. It frees only common and window DCs. It has no
' effect on class or private DCs.
Private Declare Function ReleaseDC Lib "USER32" ( _
ByVal hWnd As Long, ByVal hDC As Long) As Long

' Deletes the specified DC.
Private Declare Function DeleteDC Lib "GDI32" ( _
ByVal hDC As Long) As Long

' Retrieves the dimensions of the bounding rectangle of the
' specified window. The dimensions are given in screen
' coordinates that are relative to the upper-left corner

作者: 61.142.212.* 2005-10-28 22:22 　回復此發言

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

156 回復:把焦點定位到任何已運行的窗口。
' of the screen.
Private Declare Function GetWindowRect Lib "USER32" ( _
ByVal hWnd As Long, lpRect As RECT) As Long

' Returns a handle to the Desktop window. The desktop
' window covers the entire screen and is the area on top
' of which all icons and other windows are painted.
Private Declare Function GetDesktopWindow Lib "USER32" () As Long

' Returns a handle to the foreground window (the window
' the user is currently working). The system assigns a
' slightly higher priority to the thread that creates the
' foreground window than it does to other threads.
Private Declare Function GetForegroundWindow Lib "USER32" () As Long

' Creates a new picture object initialized according to a PICTDESC
' structure, which can be NULL, to create an uninitialized object if
' the caller wishes to have the picture initialize itself through
' IPersistStream::Load. The fOwn parameter indicates whether the
' picture is to own the GDI picture handle for the picture it contains,
' so that the picture object will destroy its picture when the object
' itself is destroyed. The function returns an interface pointer to the
' new picture object specified by the caller in the riid parameter.
' A QueryInterface is built into this call. The caller is responsible
' for calling Release through the interface pointer returned - phew!
Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
' - Creates a bitmap type Picture object from a bitmap and palette.
'
' hBmp
' - Handle to a bitmap
'
' hPal
' - Handle to a Palette
' - Can be null if the bitmap doesn't use a palette
'
' Returns
' - Returns a Picture object containing the bitmap
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Dim r As Long
Dim Pic As PicBmp
'
' IPicture requires a reference to "Standard OLE Types"
'
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'
' Fill in with IDispatch Interface ID
'
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'
' Fill Pic with the necessary parts.
'
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With
'
' Create the Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'
' Return the new Picture object.
'
Set CreateBitmapPicture = IPic
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureWindow
' - Captures any portion of a window.
'
' hWndSrc
' - Handle to the window to be captured
'
' bClient
' - If True CaptureWindow captures from the bClient area of the
' window
' - If False CaptureWindow captures from the entire window

作者: 61.142.212.* 2005-10-28 22:22 　回復此發言

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

157 回復:把焦點定位到任何已運行的窗口。
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
' - Specify the portion of the window to capture
' - Dimensions need to be specified in pixels
'
' Returns
' - Returns a Picture object containing a bitmap of the specified
' portion of the window that was captured
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function CaptureWindow(ByVal hWndSrc As Long, _
ByVal bClient As Boolean, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture

Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
'
' Get the proper Device Context (DC) depending on the value of bClient.
'
If bClient Then
hDCSrc = GetDC(hWndSrc) 'Get DC for Client area.
Else
hDCSrc = GetWindowDC(hWndSrc) 'Get DC for entire window.
End If
'
' Create a memory DC for the copy process.
'
hDCMemory = CreateCompatibleDC(hDCSrc)
'
' Create a bitmap and place it in the memory DC.
'
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
'
' Get the screen properties.
'
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) 'Raster capabilities
HasPaletteScrn = RasterCapsScrn And RC_PALETTE 'Palette support
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) 'Palette size
'
' If the screen has a palette make a copy and realize it.
'
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'
' Create a copy of the system palette.
'
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
'
' Select the new palette into the memory DC and realize it.
'
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
'
' Copy the on-screen image into the memory DC.
'
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, _
LeftSrc, TopSrc, vbSrcCopy)
'
' Remove the new copy of the on-screen image.
'
hBmp = SelectObject(hDCMemory, hBmpPrev)
'
' If the screen has a palette get back the
' palette that was selected in previously.
'
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
'
' Release the DC resources back to the system.
'
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
'
' Create a picture object from the bitmap
' and palette handles.
'
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CaptureScreen() As Picture
Dim hWndScreen As Long
'
' Get a handle to the desktop window.
hWndScreen = GetDesktopWindow()
'
' Capture the entire desktop.
'
With Screen
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
.Width \ .TwipsPerPixelX, .Height \ .TwipsPerPixelY)
End With
End Function

Public Function CaptureForm(frm As Form) As Picture
'
' Capture the entire form.

作者: 61.142.212.* 2005-10-28 22:22 　回復此發言

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

158 回復:把焦點定位到任何已運行的窗口。
'
With frm
Set CaptureForm = CaptureWindow(.hWnd, False, 0, 0, _
.ScaleX(.Width, vbTwips, vbPixels), _
.ScaleY(.Height, vbTwips, vbPixels))
End With
End Function

Public Function CaptureClient(frm As Form) As Picture
'
' Capture the client area of the form.
'
With frm
Set CaptureClient = CaptureWindow(.hWnd, True, 0, 0, _
.ScaleX(.ScaleWidth, .ScaleMode, vbPixels), _
.ScaleY(.ScaleHeight, .ScaleMode, vbPixels))
End With
End Function

Public Function CaptureActiveWindow() As Picture
Dim hWndActive As Long
Dim RectActive As RECT
'
' Get a handle to the active/foreground window.
' Get the dimensions of the window.
'
hWndActive = GetForegroundWindow()
Call GetWindowRect(hWndActive, RectActive)
'
' Capture the active window.
'
With RectActive
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, _
.Right - .Left, .Bottom - .Top)
End With
End Function

Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintPictureToFitPage
' - Prints a Picture object as big as possible.
'
' Prn
' - Destination Printer object
'
' Pic
' - Source Picture object
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim PicRatio As Double
Dim PrnWidth As Double
Dim PrnHeight As Double
Dim PrnRatio As Double
Dim PrnPicWidth As Double
Dim PrnPicHeight As Double
Const vbHiMetric As Integer = 8
'
' Determine if picture should be printed in landscape
' or portrait and set the orientation.
'
If Pic.Height >= Pic.Width Then
Prn.Orientation = vbPRORPortrait 'Taller than wide
Else
Prn.Orientation = vbPRORLandscape 'Wider than tall
End If
'
' Calculate device independent Width to Height ratio for picture.
'
PicRatio = Pic.Width / Pic.Height
'
' Calculate the dimentions of the printable area in HiMetric.
'
With Prn
PrnWidth = .ScaleX(.ScaleWidth, .ScaleMode, vbHiMetric)
PrnHeight = .ScaleY(.ScaleHeight, .ScaleMode, vbHiMetric)
End With
'
' Calculate device independent Width to Height ratio for printer.
'
PrnRatio = PrnWidth / PrnHeight
'
' Scale the output to the printable area.
'
If PicRatio >= PrnRatio Then
'
' Scale picture to fit full width of printable area.
'
PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode)
Else
'
' Scale picture to fit full height of printable area.
'
PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode)
End If
'
' Print the picture using the PaintPicture method.
'
Call Prn.PaintPicture(Pic, 0, 0, PrnPicWidth, PrnPicHeight)
End Sub

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

作者: 61.142.212.* 2005-10-28 22:22 　回復此發言

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

159 bmp->ico
' Bmp2Ico.frm
'
' By Herman Liu
'
' To show how to make an icon file out of a bitmap, and vice versa.
'
' Sometimes you see a nice bitmap picture, or part of it, and want to make it as an icon.
' You can do what you want now (Just add "file open" and "file save" functions to open the
' bmp/ico file and save the ico/bmp file respectively. That is, for example, instead of
' using the existing image in Picture1, load your own. When it is converted into an icon in
' Picture2, save it to a file name you want. Of course, in this case, you may want to fix
' the size of the image first).
'
' Notes: If you have a copy of my "IconEdit", and you want to give yourself a challenge, you
' can incorporate this code into it. This will be fairly easy. (Basically, you only need to
' add a few menu items, as almost all the APIs here are already there, so are all major
' procedures). In "IconEdit" I have left out many functions, since I don't want to blur the
' essentials. For example, if I open up just the Region function, there would be
' implications on Flip/Rotate/Invert and I have to allow region dragging and so on.)
'
Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

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

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

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

Private Declare Function CreateIconIndirect Lib "user32" (icoinfo As ICONINFO) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lppictDesc As _
pictDesc, riid As Guid, ByVal fown As Long, ipic As IPicture) As Long

Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, _
icoinfo As ICONINFO) As Long

Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, _
ByVal crColor As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long

Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type

Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Const PICTYPE_BITMAP = 1
Const PICTYPE_ICON = 3
Dim iGuid As Guid
Dim hdcMono
Dim bmpMono
Dim bmpMonoTemp
Const stdW = 32
Const stdH = 32
Dim mresult

作者: 61.142.212.* 2005-10-28 22:25 　回復此發言

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

160 bmp->ico
Private Sub Form_Load()
' Create monochrome hDC and bitmap
hdcMono = CreateCompatibleDC(hdc)
bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
With iGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
End Sub

Private Sub command1_Click()
On Error Resume Next
Dim mtransp As Long
' Let us select a background color here (just a matter of choice)
picImage.BackColor = Picture1.BackColor
' Area having the following color is to be transparent
mtransp = Picture1.Point(0, 0)
' Create transparent part
CreateTransparent Picture1, picImage, mtransp
' Create a mask
CreateMask_viaMemoryDC picImage, picMask
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcAnd)
mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcInvert)
BuildIcon Picture2
SavePicture Picture2.Picture, App.Path & "/Frombmp.ico"
End Sub

Private Sub command2_Click()
On Error Resume Next
Dim i, j
Dim p, q

Picture4.Picture = Picture3.Image

'--------------------------------------------------------
'NB This following is only a matter of variation, not a must.

' Let us select the form's color as background color here
' and replace the existing one with it.
'--------------------------------------------------------
p = Picture4.Point(0, 0)
q = Me.BackColor
' Paint the desired color as if backgound
For i = 0 To stdW
For j = 0 To stdH
If Picture4.Point(i, j) = p Then
Picture4.PSet (i, j), q
End If
Next j
Next i

SavePicture Picture4.Picture, App.Path & "/Fromico.bmp"
End Sub

' To let you see it again and again.
Private Sub Command3_Click()
Picture2.Picture = LoadPicture()
End Sub

Private Sub Command4_Click()
Picture4.Picture = LoadPicture()
End Sub

Private Function CreateMask_viaMemoryDC(Pic1 As PictureBox, Pic2 As PictureBox) As Boolean
On Error GoTo errHandler
CreateMask_viaMemoryDC = False

Dim dx As Long, dy As Long
Dim hdcMono2 As Long, bmpMono2 As Long, bmpMonoTemp2 As Long

dx = Pic1.ScaleWidth
dy = Pic1.ScaleHeight

' Create memory device context (0 is screen, as we want the new
' DC compatible with the screen).
hdcMono2 = CreateCompatibleDC(0)
If hdcMono2 = 0 Then
GoTo errHandler
End If
' Create monochrome bitmap, of a wanted size
bmpMono2 = CreateCompatibleBitmap(hdcMono2, dx, dy)
' Get a monohrome bitmap by default after putting in the
' above created bitmap into the DC.
bmpMonoTemp2 = SelectObject(hdcMono2, bmpMono2)
' Copy bitmap of Pic1 to memory DC to create mono mask of the color bitmap.
mresult = BitBlt(hdcMono2, 0, 0, dx, dy, Pic1.hdc, 0, 0, vbSrcCopy)
' Copy mono memory mask to a picture box, as wanted in this case
mresult = BitBlt(Pic2.hdc, 0, 0, dx, dy, hdcMono2, 0, 0, vbSrcCopy)

' Clean up
Call SelectObject(hdcMono2, bmpMonoTemp2)
Call DeleteDC(hdcMono2)
Call DeleteObject(bmpMono2)

CreateMask_viaMemoryDC = True
Exit Function
errHandler:
MsgBox "MakeMask_viaMemoryDC"

作者: 61.142.212.* 2005-10-28 22:25 　回復此發言

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

161 bmp->ico
End Function

Private Sub ExtractIconComposite(inPic As PictureBox)
On Error Resume Next
Dim ipic As IPicture
Dim icoinfo As ICONINFO
Dim pDesc As pictDesc
Dim hDCWork
Dim hBMOldWork
Dim hNewBM
Dim hBMOldMono

GetIconInfo inPic.Picture, icoinfo
hDCWork = CreateCompatibleDC(0)
hNewBM = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)

hBMOldWork = SelectObject(hDCWork, hNewBM)
hBMOldMono = SelectObject(hdcMono, icoinfo.hBMMask)
BitBlt hDCWork, 0, 0, stdW, stdH, hdcMono, 0, 0, vbSrcCopy
SelectObject hdcMono, hBMOldMono
SelectObject hDCWork, hBMOldWork
With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_BITMAP
.hImage = hNewBM
End With
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picMask = ipic
Set ipic = Nothing

pDesc.hImage = icoinfo.hBMColor
' Third parameter set to 1 (true) to let picture be destroyed automatically
OleCreatePictureIndirect pDesc, iGuid, 1, ipic
picImage = ipic

DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
Set hBMOldMono = Nothing
End Sub

Private Sub BuildIcon(inPic As PictureBox)
On Error Resume Next
Dim hOldMonoBM
Dim hDCWork
Dim hBMOldWork
Dim hBMWork
Dim ipic As IPicture
Dim pDesc As pictDesc
Dim icoinfo As ICONINFO

BitBlt hdcMono, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcCopy
SelectObject hdcMono, bmpMonoTemp
hDCWork = CreateCompatibleDC(0)

With inPic
hBMWork = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)
End With

hBMOldWork = SelectObject(hDCWork, hBMWork)
BitBlt hDCWork, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcCopy
SelectObject hDCWork, hBMOldWork

With icoinfo
.fIcon = 1
.xHotspot = 16 ' Doesn't matter here
.yHotspot = 16
.hBMMask = bmpMono
.hBMColor = hBMWork
End With

With pDesc
.cbSizeofStruct = Len(pDesc)
.picType = PICTYPE_ICON
.hImage = CreateIconIndirect(icoinfo)
End With

OleCreatePictureIndirect pDesc, iGuid, 1, ipic

inPic.Picture = LoadPicture()
inPic = ipic
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
DeleteObject icoinfo.hBMMask
DeleteDC hDCWork
Set hBMOldWork = Nothing
End Sub

Sub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _
inTrasparentColor As Long)
On Error Resume Next
Dim mMaskDC As Long
Dim mMaskBmp As Long
Dim mTempMaskBMP As Long
Dim mMonoBMP As Long
Dim mMonoDC As Long
Dim mTempMonoBMP As Long
Dim mSrcHDC As Long, mDestHDC As Long
Dim w As Long, h As Long

w = inpicSrc.ScaleWidth
h = inpicSrc.ScaleHeight

mSrcHDC = inpicSrc.hdc
mDestHDC = inpicDest.hdc

' Set back color of source pic and dest pic to the desired transparent color
mresult = SetBkColor&(mSrcHDC, inTrasparentColor)
mresult = SetBkColor&(mDestHDC, inTrasparentColor)

' Create a mask DC compatible with dest image
mMaskDC = CreateCompatibleDC(mDestHDC)
' and a bitmap of its size
mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
' Move that bitmap into mMaskDC
mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)

' Meanwhile create another DC for mono bitmap
mMonoDC = CreateCompatibleDC(mDestHDC)
' and its bitmap, a mono one (by setting nPlanes and nbitcount
' both to 1)
mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)

' Copy source image to mMonoDC
mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)

' Copy mMonoDC into mMaskDC
mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)

'We don't need mMonoBMP any longer
mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
mresult = DeleteObject(mMonoBMP)
mresult = DeleteDC(mMonoDC)

'Now copy source image to dest image with XOR
mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)

'Copy the mMaskDC to dest image with AND
mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)

'Copy source image to dest image with XOR
BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
'Picture is there to stay
inpicDest.Picture = inpicDest.Image

' We don't need these
mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
mresult = DeleteObject(mMaskBmp)
mresult = DeleteDC(mMaskDC)
End Sub

' Last clear up
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SelectObject bmpMono, bmpMonoTemp
DeleteObject bmpMono
DeleteDC hdcMono
End Sub

162 從資源文件中讀取各種格式圖片。
Option Explicit
'
' Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
' Demonstrates how to load GIFs and JPGs from file and resource, as well
' as all other supported graphics formats (bmp, dib, wmf,.emf, ico, cur).
'
' Is based loosely on the C code from the following:
' "Q218972 - SAMPLE: How To Load and Display Graphics Files w/LOADPIC.EXE"
' http://support.microsoft.com/support/kb/articles/Q218/9/72.ASP
'

Private Sub Form_Load()
Picture1.TabStop = False
Option1(0) = True
End Sub

Private Sub Command1_Click()
Set Picture1 = PictureFromFile(hwnd)
End Sub

Private Sub Option1_Click(Index As Integer)
Select Case Index
Case 0: Set Picture1 = PictureFromBits(LoadResData("Beany", "bmp"))
Case 1: Set Picture1 = PictureFromBits(LoadResData("Busy_l", "cur"))
Case 2: Set Picture1 = PictureFromBits(LoadResData("Cartman", "jpg"))
Case 3: Set Picture1 = PictureFromBits(LoadResData("ccrpAbout", "gif"))
Case 4: Set Picture1 = PictureFromBits(LoadResData("Desktop", "ico"))
Case 5: Set Picture1 = PictureFromBits(LoadResData("Moneybag", "wmf"))
End Select
End Sub
--------
Option Explicit
'
' Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
Public Enum CBoolean ' enum members are Long data types
CFalse = 0
CTrue = 1
End Enum

Public Const S_OK = 0 ' indicates successful HRESULT

'WINOLEAPI CreateStreamOnHGlobal(
' HGLOBAL hGlobal, // Memory handle for the stream object
' BOOL fDeleteOnRelease, // Whether to free memory when the object is released
' LPSTREAM * ppstm // Indirect pointer to the new stream object
');
Declare Function CreateStreamOnHGlobal Lib "ole32" _
(ByVal hGlobal As Long, _
ByVal fDeleteOnRelease As CBoolean, _
ppstm As Any) As Long

'STDAPI OleLoadPicture(
' IStream * pStream, // Pointer to the stream that contains picture's data
' LONG lSize, // Number of bytes read from the stream
' BOOL fRunmode, // The opposite of the initial value of the picture's property
' REFIID riid, // Reference to the identifier of the interface describing the type
' // of interface pointer to return
' VOID ppvObj // Indirect pointer to the object, not AddRef'd!!
');
Declare Function OleLoadPicture Lib "olepro32" _
(pStream As Any, _
ByVal lSize As Long, _
ByVal fRunmode As CBoolean, _
riid As GUID, _
ppvObj As Any) As Long

Public Type GUID ' 16 bytes (128 bits)
dwData1 As Long ' 4 bytes
wData2 As Integer ' 2 bytes
wData3 As Integer ' 2 bytes
abData4(7) As Byte ' 8 bytes, zero based
End Type

Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As GUID) As Long

Public Const sIID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

Public Const GMEM_MOVEABLE = &H2
Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

作者: 61.142.212.* 2005-10-28 22:27 　回復此發言

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

163 從資源文件中讀取各種格式圖片。

' ====================================================================

Public Const MAX_PATH = 260

Public Type OPENFILENAME ' ofn
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

' OPENFILENAME Flags
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_FILEMUSTEXIST = &H1000

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'

Public Function PictureFromFile(hwnd As Long, Optional sFile As String = "") As StdPicture
Dim ofn As OPENFILENAME
Dim ff As Integer
Dim abFile() As Byte

' If a file's path is not specified show the dialog.
If (Len(sFile) = 0) Then
With ofn
.lStructSize = Len(ofn)
.hWndOwner = hwnd
.lpstrFilter = "All Picture Files" & vbNullChar & "*.bmp;*.dib;*.gif;*.jpg;*.wmf;*.emf;*.ico;*.cur" & vbNullChar & _
"Bitmaps (*.bmp;*.dib)" & vbNullChar & "*.bmp;*.dib" & vbNullChar & _
"GIF Images (*.gif)" & vbNullChar & "*.gif" & vbNullChar & _
"JPEG Images (*.jpg)" & vbNullChar & "*.jpg" & vbNullChar & _
"Metafiles (*.wmf;*.emf)" & vbNullChar & "*.wmf;*.emf" & vbNullChar & _
"Icons (*.ico;*.cur)" & vbNullChar & "*.ico;*.cur" & vbNullChar & _
"All Files (*.*)" & vbNullChar & "*.*" & vbNullChar & vbNullChar
.lpstrFile = String$(MAX_PATH, 0)
.nMaxFile = MAX_PATH
.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
End With

If GetOpenFileName(ofn) Then
sFile = Left$(ofn.lpstrFile, InStr(ofn.lpstrFile, vbNullChar) - 1)
End If
End If

' If we have a file path, load it into a byte array and try to make
' a picture out of it...
If Len(sFile) Then
ff = FreeFile
Open sFile For Binary As ff
ReDim abFile(LOF(ff) - 1)
Get #ff, , abFile
Close ff

Set PictureFromFile = PictureFromBits(abFile)
End If

End Function

Public Function PictureFromBits(abPic() As Byte) As IPicture ' not a StdPicture!!
Dim nLow As Long
Dim cbMem As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture As GUID
Dim istm As stdole.IUnknown ' IStream
Dim ipic As IPicture

' Get the size of the picture's bits
On Error GoTo Out
nLow = LBound(abPic)
On Error GoTo 0
cbMem = (UBound(abPic) - nLow) + 1

' Allocate a global memory object
hMem = GlobalAlloc(GMEM_MOVEABLE, cbMem)
If hMem Then

' Lock the memory object and get a pointer to it.
lpMem = GlobalLock(hMem)
If lpMem Then

' Copy the picture bits to the memory pointer and unlock the handle.
MoveMemory ByVal lpMem, abPic(nLow), cbMem
Call GlobalUnlock(hMem)

' Create an ISteam from the pictures bits (we can explicitly free hMem
' below, but we'll have the call do it...)
If (CreateStreamOnHGlobal(hMem, CTrue, istm) = S_OK) Then
If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then

' Create an IPicture from the IStream (the docs say the call does not
' AddRef its last param, but it looks like the reference counts are correct..)
Call OleLoadPicture(ByVal ObjPtr(istm), cbMem, CFalse, IID_IPicture, PictureFromBits)

End If ' CLSIDFromString
End If ' CreateStreamOnHGlobal
End If ' lpMem

' Call GlobalFree(hMem)
End If ' hMem

Out:
End Function

164 全屏的下雪場景制作
Dim Snow(1000, 2), Amounty As Integer

Private Sub Form_Load()
Form1.Show
DoEvents
Randomize: Amounty = 325
For J = 1 To Amounty
Snow(J, 0) = Int(Rnd * Form1.Width)
Snow(J, 1) = Int(Rnd * Form1.Height)
Snow(J, 2) = 10 + (Rnd * 20)
Next J

Do While Not (DoEvents = 0)
For LS = 1 To 10
For I = 1 To Amounty
OldX = Snow(I, 0): OldY = Snow(I, 1): Snow(I, 1) = Snow(I, 1) + Snow(I, 2)
If Snow(I, 1) > Form1.Height Then Snow(I, 1) = 0: Snow(I, 2) = 5 + (Rnd * 30): Snow(I, 0) = Int(Rnd * Form1.Width): OldX = 0: OldY = 0
Coloury = 8 * (Snow(I, 2) - 10): Coloury = 60 + Coloury: PSet (OldX, OldY), QBColor(0): PSet (Snow(I, 0), Snow(I, 1)), RGB(Coloury, Coloury, Coloury)
Next I
Next LS
Label1.Refresh
Loop
End
End Sub

Private Sub Timer1_Timer()

End Sub

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

作者: 61.142.212.* 2005-10-28 22:30 　回復此發言

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

165 雨滴特效顯示圖片
'需求一個PictureBox( Named picture2),一個Command按鍵)
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Const SRCCOPY = &HCC0020
Private Picture1 As New StdPicture

Private Sub Command1_Click()
Dim i As Long
Dim j As Long
Dim height5 As Long, width5 As Long
Dim hMemDc As Long

'stdPicture物件的度量單位是Himetric所以要轉換成Pixel
height5 = ScaleY(Picture1.Height, vbHimetric, vbPixels)
If height5 > Picture2.ScaleHeight Then
height5 = Picture2.ScaleHeight
End If
width5 = ScaleX(Picture1.Width, vbHimetric, vbPixels)
If width5 > Picture2.ScaleWidth Then
width5 = Picture2.ScaleWidth
End If
'Create Memory DC
hMemDc = CreateCompatibleDC(Picture2.hdc)
'將Picture1的BitMap圖指定給hMemDc
Call SelectObject(hMemDc, Picture1.Handle)
For i = height5 To 1 Step -1
Call BitBlt(Picture2.hdc, 0, i, width5, 1, _
hMemDc, 0, i, SRCCOPY)
For j = i - 1 To 1 Step -1
Call BitBlt(Picture2.hdc, 0, j, width5, 1, _
hMemDc, 0, i, SRCCOPY)
Next j
Next
Call DeleteDC(hMemDc)
End Sub

Private Sub Form_Load()
Dim i As Long
Picture2.ScaleMode = 3 '設定成Pixel的度量單位
'設定待Display的圖
Set Picture1 = LoadPicture("benz-sl.jpg")
End Sub

166 一個像“南極星”的自動隱藏工具欄。(推薦)
Option Explicit

Dim BarData As APPBARDATA

Dim bAutoHide As Boolean
Dim bAnimate As Boolean
Private Sub Form_Load()

Dim lResult As Long

Move 0, 0, 0, 0
Screen.MousePointer = vbDefault

bAutoHide = True
bAnimate = True

BarData.cbSize = Len(BarData)
BarData.hwnd = hwnd
BarData.uCallbackMessage = WM_MOUSEMOVE
lResult = SHAppBarMessage(ABM_NEW, BarData)
lResult = SetRect(BarData.rc, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
BarData.uEdge = ABE_TOP
lResult = SHAppBarMessage(ABM_QUERYPOS, BarData)
If bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 2 'tbrToolBar.Bands("ToolBar").Height + 6
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
BarData.lParam = True
lResult = SHAppBarMessage(ABM_SETAUTOHIDEBAR, BarData)
If lResult = 0 Then
bAutoHide = False
Else
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top - 42, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
End If
End If
If Not bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 42
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

Static bRecieved As Boolean
Dim lResult As Long
Dim newRC As RECT
Dim lMessage As Long

lMessage = x / Screen.TwipsPerPixelX

If bRecieved = False Then
bRecieved = True
Select Case lMessage
Case WM_ACTIVATE
lResult = SHAppBarMessage(ABM_ACTIVATE, BarData)
Case WM_WINDOWPOSCHANGED
lResult = SHAppBarMessage(ABM_WINDOWPOSCHANGED, BarData)
Case ABN_STATECHANGE
lResult = SetRect(BarData.rc, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
BarData.uEdge = ABE_TOP
lResult = SHAppBarMessage(ABM_QUERYPOS, BarData)
If bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 2
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
BarData.lParam = True
lResult = SHAppBarMessage(ABM_SETAUTOHIDEBAR, BarData)
If lResult = 0 Then
bAutoHide = False
Else
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top - 42, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
End If
End If
If Not bAutoHide Then
BarData.rc.Bottom = BarData.rc.Top + 42
lResult = SHAppBarMessage(ABM_SETPOS, BarData)
lResult = SetWindowPos(BarData.hwnd, HWND_TOP, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
End If
Case ABN_FULLSCREENAPP
Beep
End Select
bRecieved = False
End If
End Sub

Private Sub Form_Resize()
picFrame.Move 0, 0, Width, Height
End Sub

Private Sub Form_Unload(Cancel As Integer)
If BarData.hwnd <> 0 Then SHAppBarMessage ABM_REMOVE, BarData
End Sub

Private Sub picFrame_DblClick()
Unload Me
End Sub

Private Sub picFrame_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim lResult As Long
Dim iCounter As Integer

167 一個像“南極星”的自動隱藏工具欄。(推薦)
If Top < 0 Then
If bAnimate Then
For iCounter = -36 To -1
BarData.rc.Top = iCounter
lResult = SetWindowPos(BarData.hwnd, 0&, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
Next
End If
BarData.rc.Top = 0
lResult = SetWindowPos(BarData.hwnd, HWND_TOPMOST, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_SHOWWINDOW)
tmrHide.Enabled = True
End If
End Sub

Private Sub tmrHide_Timer()
Dim lResult As Long
Dim lpPoint As POINTAPI
Dim iCounter As Integer
lResult = GetCursorPos(lpPoint)
If lpPoint.x < Left \ Screen.TwipsPerPixelX Or lpPoint.x > (Left + Width) \ Screen.TwipsPerPixelX Or lpPoint.y < Top \ Screen.TwipsPerPixelY Or lpPoint.y - 10 > (Top + Height) \ Screen.TwipsPerPixelY Then
If bAnimate Then
For iCounter = -1 To -37 Step -1
BarData.rc.Top = iCounter
lResult = SetWindowPos(BarData.hwnd, 0&, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 42, SWP_NOACTIVATE)
Next
End If
BarData.rc.Top = -42
lResult = SetWindowPos(BarData.hwnd, HWND_TOPMOST, BarData.rc.Left, BarData.rc.Top, BarData.rc.Right - BarData.rc.Left, 44, SWP_NOACTIVATE)
tmrHide.Enabled = False
End If
End Sub

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

Type POINTAPI
x As Long
y As Long
End Type

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

Type APPBARDATA
cbSize As Long
hwnd As Long
uCallbackMessage As Long
uEdge As Long
rc As RECT
lParam As Long ' message specific
End Type

Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Const WM_MOUSEMOVE = &H200
Public Const WM_ACTIVATE = &H6
Public Const WM_WINDOWPOSCHANGED = &H47

Public Const ABE_BOTTOM = 3
Public Const ABE_LEFT = 0
Public Const ABE_RIGHT = 2
Public Const ABE_TOP = 1
Public Const ABM_ACTIVATE = &H6
Public Const ABM_GETAUTOHIDEBAR = &H7
Public Const ABM_GETSTATE = &H4
Public Const ABM_GETTASKBARPOS = &H5
Public Const ABM_NEW = &H0
Public Const ABM_QUERYPOS = &H2
Public Const ABM_REMOVE = &H1
Public Const ABM_SETAUTOHIDEBAR = &H8
Public Const ABM_SETPOS = &H3
Public Const ABM_WINDOWPOSCHANGED = &H9
Public Const ABN_FULLSCREENAPP = &H2
Public Const ABN_POSCHANGED = &H1
Public Const ABN_STATECHANGE = &H0
Public Const ABN_WINDOWARRANGE = &H3

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1

Public Const HWND_TOP = 0
Public Const HWND_TOPMOST = -1

Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40

168 類似于東方快車工具條的東東的源碼。(推薦)
'程序∶池星澤
'獲得鼠標指針在屏幕坐標上的位置
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long
'獲得窗口在屏幕坐標中的位置
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
'判斷指定的點是否在指定的巨型內部
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, _
ByVal ptx As Long, ByVal pty As Long) As Long
'準備用來使窗體始終在最前面
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter _
As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags _
As Long) As Long
'用來移動窗體
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Const HWND_TOPMOST = -1

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Is_Move_B As Boolean '判斷指針是否位于移動欄(本例中移動欄位于窗體的側一小地方)
Private Is_Movestar_B As Boolean '判斷移動是否開始
Private MyRect As RECT
Private MyPoint As POINTAPI
Private Movex As Long, Movey As Long '記錄窗體移動前,窗體左上角與鼠標指針位置間的縱橫距離
Private max As Long '窗口變長以后的尺寸(用戶可隨意改動)

Private Sub Command1_Click(Index As Integer)
Form1.SetFocus
Select Case Index
Case 0
Form1.PopupMenu Form2.mnu_file, vbPopupMenuLeftAlign, 240, max - 30
Case 1
Case 7
Command1(8).Enabled = Not Command1(8).Enabled
If Command1(8).Enabled = True Then
Command1(7).Picture = Image2(1).Picture
Picture1.Width = 4455
Form1.Width = Form1.Width + 1820
Else
Command1(7).Picture = Image2(0).Picture
Picture1.Width = 2645
Form1.Width = Form1.Width - 1820
End If
Line (0, 0)-(Form1.Width, Form1.Height), vbBlue, BF
Get_Windows_Rect
'......
Case 13
End
' .....
End Select
End Sub

Private Sub Form_Load()
Timer1.Interval = 50: Timer2.Interval = 1000
Form1.BackColor = vbBlue
Get_Windows_Rect
End Sub
Sub Get_Windows_Rect()
Dim dl&
max = 390: Form1.Height = max
Form1.Top = 0 '窗體始終放在屏幕頂部
dl& = GetWindowRect(Form1.hwnd, MyRect)
End Sub
Private Sub Form_Paint()
'使窗體始終置于最前面
If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
Form1.Height \ Screen.TwipsPerPixelY, 0
End If
End Sub

Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Is_Move_B Then
Movex = MyPoint.X - MyRect.Left
Movey = MyPoint.Y - MyRect.Top
Is_Movestar_B = True
End If
End Sub

Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dl&
If Is_Movestar_B Then
dl& = MoveWindow(Form1.hwnd, MyPoint.X - Movex, MyPoint.Y - Movey, _
MyRect.Right - MyRect.Left, MyRect.Bottom, -1)
End If
End Sub

Private Sub Image1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Get_Windows_Rect
Is_Movestar_B = False
End Sub

Private Sub Timer1_Timer()
Dim dl&
dl& = GetCursorPos(MyPoint)
If (PtInRect(MyRect, MyPoint.X, MyPoint.Y) And _
Form1.Height = max) Or MyPoint.Y <= 3 Then
' If MyPoint.Y <= 3 Then
Form1.BackColor = vbBlue '窗體背景顏色(用戶可隨意改動)
Form1.Height = max
'判斷鼠標指針是否位于窗體拖動區
If MyPoint.X - MyRect.Left <= 10 Or Is_Movestar_B Then
Screen.MousePointer = 15
Is_Move_B = True
Else
Screen.MousePointer = 0
Is_Move_B = False
End If
Else
If Not Is_Movestar_B Then
Form1.Height = 30 '窗體變小
End If
End If
End Sub

Private Sub Timer2_Timer()
Static color As Integer
If color > 64 Then color = 0
Line (0, 0)-(Form1.Width, Form1.Height), QBColor(color Mod 16), BF
color = color + 15
End Sub
---------

Private Sub mnu_exit_Click()
End
End Sub

169 cool bg
'1.程式名稱:炫彩式的啟動表單
'2.開發日期:05/28/1999
'3.開發環境:Visual Basic 5.0 中文專業版 + SP3
'4.作者姓名:宋世杰 (小翰,Jaric)
'5.作者信箱:jaric@tacocity.com.tw
'6.作者網址:http://fly.to/jaric 或 http://tacocity.com.tw/jaric
'7.網址名稱:Visual Basic 實戰網
'8.注意事項:您可以任意散布本程式,但是請勿將以上說明刪除,謝謝!
' 如果本程式經過您的修改,可以在下方加入您的個人資訊。
'VB編程樂園 http://www.vbeden.com 整理

Option Explicit

Public Sub splash(obj As Object, r As Byte, g As Byte, b As Byte, fr As Byte, fg As Byte, fb As Byte, no As Long)
Dim i As Long, n1 As Single, n2 As Single
For i = 0 To no
n2 = i / no
n1 = 1 - n2
obj.BackColor = RGB(Int(r * n1 + fr * n2), _
Int(g * n1 + fg * n2), Int(b * n1 + fb * n2))
DoEvents
Next
End Sub

Private Sub Command1_Click()
Call splash(Command1, 255, 0, 0, 255, 255, 0, 50)
End Sub

Private Sub Form_Load()
Dim msg As String
Show
Call splash(Me, 255, 0, 0, 0, 0, 255, 3000)
Call splash(Me, 0, 0, 255, 0, 255, 0, 3000)
msg = "VB實戰網 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

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方法開始發送消息�？蛻魴C則在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