如何去優化你的VB程式幫助
1、如何去優化你的VB程式
Visual Basic 作為一種進階程式設計語言，它也有着不可避免的缺點---開發出的應用程式運作速度慢。如果我們能夠程式做一些優化，那麼情況将會大大改善。要優化程式運作的實際速度，常用的方法有三種：
1.盡量避免使用 Variant 變量。由于VB不能确定 Variant 變量的具體類型，是以它會給該類型變量配置設定16個位元組的空間，而且在用變量進行運算時還要考慮到資料類型的轉換。這既占用記憶體，又影響了速度，會使涉及到複雜運算的程式慢。注意，一個變量的預設類型就是 Variant，其它類型的變量要用Dim語句單獨聲明。
2.在遇到整型資料時盡量使用Long變量。因為Long變量是32位CPU的本機資料類型，是以處理速度會很快，尤其是在循環體中。
3.将控件的常用屬性儲存在變量中。一般控件存在于DLL或OCX這類的外部程式中。衆所周知，調用DLL遠比通路記憶體慢。是以對于那些放在循環體中的常用屬性，如果将它們儲存在變量中，那麼速度将會有成百上千倍提升。
我們在編寫程式時應注意到，在進行長時間等待操作時，可以做一些動畫之類的效果，好讓使用者知道程式運作正常。下面是幾個常用優化方法：
（1）使用 Splash 螢幕。也就是我們常見的歡迎視窗。大的應用程式在啟動時，往往會主動或被動地載入一大堆DLL，這要花費很長時間。是以我們在啟動時可以先顯示一個簡單的視窗，上面隻放一些作者、版權之類的資訊，在這個視窗的Form_Load事件中用Load方法讀入那些最常用的窗體子產品。這樣，雖然實際等待的時間延長了，但使用者所看到的螢幕總是變化的，是以感覺下程式啟動加快了。而且由于常用窗體子產品事先已載入記憶體，以後隻需用Show方法來顯示它，跳過了載入過程，在程式運作過程中也會很快的。
（2）使用Timer控件。由于Timer控件的出現，使得背景作業有了可能。我們可以在每次Timer事件中完成一小部分任務。這樣，由于Timer中的事件能夠在很短的時間内完成，使用者一般查覺不到速度的變化。如果一定要在一個循環内完成某個任務，那麼不要忘了用DoEvents來釋放使用者。
（3）使用進度條。要使用進度條，需要事先知道資料量，是以它很适合用于對已知資料的操作，如資料庫的排序。
總之，優化程式要從自己、從使用者等多方面考慮，使程式開發周期短，且高效易用。
2、在VB中如何建立閃爍(智語)屏
大型應用系統啟動運作的時間需要很長時間,其時間會根據需要初始化的數量和使用者系統的速度變化,是以在主視窗顯示前,應顯示一個初始化視窗,使應用程式看起來更具吸引力,因為當裝載程式時不斷可以向使用者顯示一些資訊，而且可産生美觀的視覺效果。例如vb、delphi在啟動時均在主界面前顯示一splash視窗.
---- 1. 下面是顯示閃爍(智語)屏splash的一種簡單方法:
option explicit
private sub form_load()
'顯示主視窗
me.show
'顯示splash視窗
frmsplash.show
doevents
'執行應用程式初始化
initialize
'關閉splash視窗
unload spalsh
end sub
---- 該過程代碼應放在應用程式的啟動窗體中。第一個show方法可使windows在螢幕上顯示主窗體，下一個show方法顯示閃爍屏，它是你設計的名為frmsplash的窗體.在利用show方法之後，再利用Doevents函數，以確定閃爍屏窗體的所有元數立即繪制完。Initialize函數執行應用程式在啟動時需要執行的費時任務，例如，從檔案中裝載資料，将窗體裝入記憶體等等。這時一切都準備就緒.
---- 2.閃爍窗體模闆
---- Visual Basic 中含有許多摸闆窗體，其中之一是閃爍屏。要為項目添加Splash screen 窗體，需要從project菜單中選擇Add Form.在Add Form 對話框的New标簽上選擇Splash Screen圖示，并單擊Open.這樣Splash Screen窗體就被添加到項目中.
---- 下列代碼顯示了如何定制Splash Screen 窗體摸闆的執行個體:
option explicit
private sub form_load()
frmsplash.lbllicenseto=app.legaltrademarks
frmsplash.lblcompanyproduct=app.productname
frmsplash.lblplatform="window 98"
frmsplash.lblcopyright=app.legalcopyright
frmsplash.lblcompany=app.companyname
frmsplash.lblwarning="Warning:this program is protected" & _
"by copyright law,so don't copy "
frmsplash.show
doevents
initialize
unload frmsplash
end sub
---- 注意這裡使用了app對象，該對象可以通路有關你的應用程式的資訊;
---- splash screen 窗體摸闆代碼子產品的代碼如下所示:
Private Sub Form_keypress(keyascii as integer)
unload me
End sub
Private sub form_load()
lblversion.caption="version"&app.major&".
"app.minor"."app.revision
lblproductname.caption=app.title
end sub
private sub frame1_click()
unload me
End Sub
3、如何用VB建立快捷方式
Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Sub Command1_Click()
Dim lReturn As Long
'添加到桌面
lReturn = fCreateShellLink("../../Desktop", "Shortcut to Calculator", "c:/windows/calc.exe", "")
'添加到程式組
lReturn = fCreateShellLink("", "Shortcut to Calculator", "c:/windows/calc.exe", "")
'添加到啟動組
lReturn = fCreateShellLink("/Startup", "Shortcut to Calculator", "c:/windows/calc.exe", "")
End Sub
4、如何在VB中判斷Windows9x的運作模式
在Windows下程式設計，經常發現有不少功能Windows系統已經做了，如果能夠直接調用，就可省去不少程式的編寫，并能提高程式的運作效率。在很多情況下，我們都可以用“Ctrl ＋ X”、“Ctrl ＋ C”、 “Ctrl ＋ V”和“Ctrl ＋ Z”分别進行“剪切”、“複制”、“粘貼”和“撤消”操作，由此想到，如果我們能夠在程式中調用系統的這些功能，就無需為如何實作這些操作而操心了。經過不斷的探索，終于發現SendMessage和PostMessage能夠擔此重任，真是如獲至寶，于是迫不及待地把它們介紹給各位朋友。
用VB5的“API浏覽器”可以很容易地找到這兩個API 函數：
Declare Function SendMessage Lib “user32” Alias “SendMessageA” _(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _lParam As Any) As Long
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
這兩個函數的功能幾乎是一樣的，隻是SendMessage是直接調用Windows函數來發送消息，隻有這個消息完全被處理後此函數才傳回，而PostMessage則給窗體的消息隊列增加一個消息，這個消息将在未來某個時候進行正常事件處理時得到處理。以下僅以SendMessage為例。
函數中雖然有四個參數，但關鍵的是前兩個：hwnd 和wMsg。Hwnd是句柄，Microsoft Windows應用程式中的每個窗體和控件都擁有一個句柄，通過句柄可以指明函數的操作對象；wMsg是一個十六進制數，代表了函數要發送的具體消息。
下面以具體例子說明如何用SendMessage實作“剪切”、“複制”、“粘貼”、“撤消” 和“删除”功能:
在窗體中放置一個文本框Text1和五個按鈕，分别執行以上五種功能，編寫以下程式。
Option Explicit
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
Const WM_CUT = ＆H300
Const WM_COPY = ＆H301
Const WM_PAST = ＆H302
Const WM_CLEAR = ＆H303
Const WM_UNDO = ＆H304
Dim fb As Long
Private Sub cmdClear_Click()
fb = PostMessage(Text1.hwnd, WM_CLEAR, 0, 0)
End Sub
Private Sub cmdCopy_Click()
fb = SendMessage(Text1.hwnd, WM_COPY, 0, 0)
End Sub
Private Sub cmdCut_Click()
fb = SendMessage(Text1.hwnd, WM_CUT, 0, 0)
End Sub
Private Sub cmdPast_Click()
fb=SendMessage(Text1.hwnd, WM_PAST, 0, 0)
End Sub
Private Sub cmdUndo_Click()
fb=SendMessage(Text1.hwnd, WM_UNDO, 0, 0)
End Sub
除了TextBox外SendMessage 還可以對RitchTextBox和ComboBox等進行操作,隻要相應改變hwnd參數即可。
5、如何在Windows作業系統中改變檔案打開方式
在Windows 95／NT／98作業系統中改變檔案打開方式的問題，又可稱為改變檔案類型關聯的問題，即把某類型（擴充名）的檔案與某應用程式關聯，例如通常當輕按兩下＊.txt檔案時系統自動調用Notepad.exe。本文介紹利用Windows系統資料庫編輯器Regedit.exe手工或程式設計改變檔案打開方式的方法，并提供程式執行個體。
一、基本思路：
1、系統資料庫編輯器Regedit.exe是用于更改系統系統資料庫設定的進階工具，包含了關于系統配置及運作的重要資訊，預設通路路徑為C:/Windows/Regedit.exe。輕按兩下Regedit.exe圖示，運作系統資料庫編輯器。在左側顯示欄内看到HKEY_CLASSES_ROOT、KEY_CURRENT_USER、HKEY_LOCAL_MACHINE等主鍵。與檔案類型有關的所有主鍵、鍵名、鍵值都存放在HKEY_CLASSES_ROOT下。
◆輕按兩下HKEY_CLASSES_ROOT，向下拖動滾動條，找到.txt主鍵，右側顯示欄内“txtfile”說明：在HKEY_CLASSES_ROOT下有一txtfile主鍵，其下存放了打開＊.txt檔案應用程式的有關資訊。
◆向下拖動滾動條，找到txtfile主鍵，右側顯示欄内“文本文檔”為檔案類型描述。輕按兩下txtfile，DefaultIcon右側顯示欄内“shell32.dll,－152”為＊.txt檔案的圖示；shell/open/command，右側顯示欄内“C:/WINDOWS/NOTEPAD.EXE ％1”為打開＊.txt檔案的應用程式名稱及參數。 改變打開檔案方式的方法（例如用VISIO打開＊.exc檔案）：
◆手工：打開系統系統資料庫，在HKEY_CLASSES_ROOT下找到.exc及另一主鍵名，找到此主鍵，将shell/open/command右側顯示欄内“C:/WINDOWS/NOTEPAD.EXE ％1”改為“C:/VISIO.EXE ％1”（假設VISIO.EXE的通路路徑是C:/，具體視情況而定），按F5重新整理系統系統資料庫。
◆程式設計：利用VB、Delphi、C＋＋Builder等讀寫系統系統資料庫，可自動改變檔案打開方式。本文提供VB、Delphi程式設計執行個體。
二、程式設計執行個體：
㈠利用VB程式設計
1、在VB5.0 IDE中，建立工程Project1，在Form1上添加指令按鈕Command1。
2、選擇菜單“工程”—“添加子產品”—“子產品”—“打開”，在Project1中添加子產品Moudle1。
3、在Moudle1“通用—聲明”部分聲明API函數和常量。
Const REG_SZ = 1
Global Const HKEY_CLASSES_ROOT = ＆H80000000
Declare Function OSRegQueryValueEx Lib “advapi32”Alias “RegQueryValueExA”(ByVal hKey As Long, ByVal lpszValueName As String,
ByVal dwReserved As Long, lpdwType As Long, lpbData As Any, cbData As Long) As Long
Declare Function OSRegOpenKey Lib “advapi32”Alias “RegOpenKeyA”(ByVal hKey As Long, ByVal lpszSubKey As String, phkResult As Long) As Long
Declare Function OSRegSetValueEx Lib“advapi32”Alias “RegSetValueExA”（ByVal hKey As Long, ByVal lpszValueName As String,
ByVal dwReserved As Long, ByVal fdwType As Long, lpbData As Any, ByVal cbData As Long) As Long
Declare Function OSRegCloseKey Lib“advapi32”Alias “RegCloseKey”(ByVal hKey As Long) As Long
4、在Moudle 1中編寫函數。
Function RegOpenKey(ByVal hKey As Long, ByVal lpszSubKey As String,
phkResult As Long) As Boolean
Dim lResult As Long
On Error GoTo 0 ` 關閉錯誤陷阱
lResult = OSRegOpenKey(hKey, lpszSubKey, phkResult)
If lResult = 0 Then
RegOpenKey = True
Else
RegOpenKey = False
End If
End Function
Function RegSetStringValue(ByVal hKey As Long, ByVal strValueName As String,
ByVal strData As String, Optional ByVal fLog) As Boolean
Dim lResult As Long
On Error GoTo 0
lResult = OSRegSetValueEx(hKey, strValueName, 0＆, REG_SZ, ByVal strData,
LenB(StrConv(strData, vbFromUnicode)) ＋ 1)
If lResult = 0 Then
RegSetStringValue = True
Else
RegSetStringValue = False
End If
End Function
Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer
intZeroPos = InStr(strString, Chr＄(0))
If intZeroPos > 0 Then
StripTerminator=Left＄(strString, intZeroPos － 1)
Else
StripTerminator = strString
End If
End Function
Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String,
strData As String) As Boolean
Dim lResult As Long
Dim lValueType As Long
Dim strBuf As String
Dim lDataBufSize As Long
RegQueryStringValue = False
On Error GoTo 0
lResult = OSRegQueryValueEx(hKey, strValueName, 0＆, lValueType, ByVal 0＆,
lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, “”)
lResult = OSRegQueryValueEx(hKey, strValueName, 0＆, 0＆, ByVal strBuf,
lDataBufSize)
If lResult = ERROR_SUCCESS Then
RegQueryStringValue = True
strData = StripTerminator(strBuf)
End If
End If
End If
End Function
5、輕按兩下Command1，編寫Click事件代碼。
Private Sub Command1_Click()
Dim hKey As Long
Dim MyReturn As Long
Dim MyData As String
MyReturn = OSRegOpenKey(HKEY_CLASSES_ROOT, “.exc”, hKey)
MyReturn=RegQueryStringValue(hKey,“”,MyData)
MyReturn=OSRegOpenKey(HKEY_CLASSES_ROOT, MyData＋“/shell/open/command”,hKey)
MyReturn = RegSetStringValue(hKey,“”,“c:/visio.exe 1％”, False)
If MyReturn Then
MsgBox “改變檔案打開方式成功！”,vbInformation,“請注意”
Else
MsgBox “改變檔案打開方式失敗！”,vbExclamation,“請注意”
End If
OSRegCloseKey (hKey)
End Sub
6、按F5運作程式，在簡體中文Windows95／NT／98、VB5.0／6.0環境中調試通過。
㈡利用Delphi程式設計
1、在Delphi3.0 IDE中，建立工程Project1，在Form1上添加按鈕Button1。
2、在uses子句中添加Registry。
3、輕按兩下Button1，編寫Click事件代碼。
procedure TForm1.Button1Click(Sender: Tobject);
var
MyRegistry : TRegINIFile;
Return:string;
begin
try
MyRegistry := TRegINIFile.Create(``);
MyRegistry.RootKey := HKEY_CLASSES_ROOT;
Return:=MyRegistry.ReadString (`.gid`,``,`No! Not Found the Key!`);
MyRegistry.WriteString(Return,``,`這隻是一個示範！`);
MyRegistry.WriteString(Return＋`/DefaultIcon`,``,`c:/visio.exe,1`);
MyRegistry.WriteString(Return＋`/shell/open/command`,``,`c:/visio.exe ％1`);
finally
MyRegistry.Free;
end;
ShowMessage(`改變檔案打開方式成功！`);
end;
4、按F9運作程式，在簡體中文Windows95／NT／98、Delphi3.0／4.0環境中調試通過。
6、用VB開發應用程式如何使用INI檔案
為了友善使用者使用和使系統具有靈活性，大多數Win-dows應用程式将使用者所做的選擇以及各種變化的系統資訊記錄在初始化(INI)檔案中。是以，當系統的環境發生變化時，可以直接修改INI檔案，而無需修改程式。由此可見，INI檔案對系統功能是至關重要的。本文将介紹采用VisualBasicforWindows(下稱VB)開發Windows應用程式時如何讀寫INI檔案。
INI檔案是文本檔案，由若幹部分(section)組成，在每個帶括号的标題下面，是若幹個以單個單詞開頭的關鍵詞(keyword)和一個等号，每個關鍵詞會控制應用程式某個功能的工作方式，等号右邊的值(value)指定關鍵詞的操作方式。其一般形式如下:
[section1]
keyword1=valuel
keyword2=value2
……
[section2]
keyword1=value1
keyword2=value2
……
其中，如果等号右邊無任何内容(即value為空)，那就表示Windows應用程式已為該關鍵詞指定了預設值，如果在整個檔案中找不到某個關鍵詞(或整個一部分)，那同樣表示為它們指定了預設值。各個部分所出現的順序是無關緊要的，在每一個部分裡，各個關鍵詞的順序同樣也無關緊要。
讀寫INI檔案通常有兩種方式:一是在Windows中用"記事本"(Notepad)對其進行編輯，比較簡單，無需贅述;二是由Windows應用程式讀寫INI檔案，通常是應用程式運作時讀取INI檔案中的資訊，退出應用程式時儲存使用者對運作環境的某些修改。
關鍵詞的值的類型多為字元串或整數型，應分兩種情況讀寫。為了使程式具有可維護性和可移植性，最好把對INI檔案的讀寫封裝在一個子產品(RWINI.BAS)中，在RWI-NI.BAS中構造GetIniS和GetIniN函數以及SetIniS和Se-tIniN過程，在這些函數和過程中需要使用WindowsAPI的"GetPrivateprofileString"、"GetPrivateProfileInt"和"WritePrivateProfileString"函數。
RWINI.BAS子產品的程式代碼如下:
在General-Declearation部分中聲明使用到的WindowsAPI函數:
Declare Function GetprivateprofileString Lib"Ker-nel"(ByVallpAppName As String，ByVallpKeyName As String，ByVallpDefault As String，ByVal lpRetrm-String As String，ByVal cbReturnString As Integer，ByVal Filename As String)As Integer
Declare FunctionGetPrivatePfileInt Lib "Kernel"(ByVal lpAppName As String，ByVal lpKeyName As String，ByVal lpDefault As Integer，ByVal Filename As String)As Integer
Declare FuncitonWritePrivateprofileString Lib "Kernel"(ByVal lpApplicationName As String，ByVal lpKeyName As String，ByVal lpString As String，ByVal lplFileName As String)As Integer
Function GetIniS(ByVal SectionName As String，ByVal KeyWord As String，ByVal DefString As String)As String
Dim ResultString As String * 144，Temp As Integer
Dims As String，i As Integer
Temp%=GetPrivateProfileString(SectionName，KeyWord，""，ResultString，144，AppProfileName())
'檢索關鍵詞的值
IfTemp%＞0Then'關鍵詞的值不為空
s=""
Fori=1To144
IfAsc(Mid$(ResultString，I，1))=0Then
ExitFor
Else
s=s&Mid$(ResultString，I，1)
EndIf
Next
Else
Temp%=WritePrivateProfilesString(sectionname，KeyWord，DefString，ppProfileName())
'将預設值寫入INI檔案
s=DefString
EndIf
GetIniS=s
EndFunction
FunctionGetIniN(ByValSectionNameAsString，ByValKeyWordAsString，ByValDefValue
AsIneger)AsInteger
DimdAsLong，sAsString
d=DefValue
GetIniN=GetPrivateProfileInt(SectionName，
KeyWord，DefValue，ppProfileName())
Ifd＜＞DefValueThen
s=""&d
d=WritePrivateProfileString(SectionName，
KeyWord，s，AppProfileName())
EndIf
EndFunction
SubSetIniS(ByValSectionNameAsString，BtVaKeyWordAsString，ByValValStr
AsString)
Dimres%
res%=WritePrivateprofileString(SectionName，KeyWord，ValStr，AppProfileName())
EndSub
SubSetIniN(ByValSectionNameAsString，ByValKeyWordAsString，ByValValInt
AsInteger)
Dimres%，s$
s$=Str$(ValInt)
res%=WriteprivateProfileString(SectionName，KeyWord，s$，AppProfileName())
EndSub
SectionName為每一部分的标題，KeyWord為關鍵詞，GetIniS和GetIniN中的DefValue為關鍵詞的預設值，SetIniS和SetIniN的ValStr和ValInt為要寫入INI檔案的關鍵詞的值。為了能更好地說明如何使用以上函數和過程，下面舉兩個執行個體。
執行個體1:
開發應用程式通常要使用資料庫和其它一些檔案，這些檔案的目錄(包括路徑和檔案名)不應在程式中固定，而是儲存在INI檔案中，程式運作時由INI檔案中讀入。讀入資料庫檔案的代碼如下:
DimDatabasenameAsString
Databasename=GetIniS("資料庫"，"職工"，"")
IfDatabaseName=""ThenDatabaseName=InputBox("請輸入資料庫《職工》的目錄")，
App.Title)’也可通過"檔案對話框"進行選擇
OnErrorResumeNext
Setdb=OpenDatabas(DatabaseName)
IfErr＜＞0Then
MsgBox"打開資料庫失敗!"，MB-
ICONSTOP，App.Title:GotoErrorProcessing
Else
SetIniS"資料庫"，"職工"，DatabaseName
EndIf
OnErrorGoTo0
……
執行個體2:
為了友善使用者操作，有時需要儲存使用者界面的某些資訊，例如視窗的高度和寬度等。裝載窗體時，從INI檔案中讀入窗體高度和寬度，解除安裝窗體時将窗體目前高度和寬度存入INI檔案，代碼如下:
Sub Form1_Load()
……
Forml.Height=GetIniN("窗體1"，"高度"，6000)
Form1.Width=GetIniN("窗體1"，"高度"，4500)
EndSub
……
Sub Form1_Unload()
……
SetIniN"窗體1"，"高度"，Me.Height
SetIniN"窗體1，"寬度"，Me.Width
……
End Sub
7、程式中如何啟動預設的撥接上網
随着網際網路的迅猛發展，現在程式設計常需要在程式中直接聯網來處理一些事項，如線上注冊和線上幫助，這就要求我們要在程式中建立某些連接配接。很多軟體在不知使用者是否聯網的情況下不管三七二十一就啟動浏覽器查找網址，費了九牛二虎之力隻能查出一錯誤頁來（當然不可能有什麼好的結果）。如果我們在程式編寫時能自動判斷使用者是否已經聯網，如已經聯網則打開聯接，如沒有則啟動預設的撥接上網，這樣是不是讓人覺得你的軟體更勝人一處呢？判斷是否已聯網很多地方都有介紹，這裡我們隻介紹如何啟動預設的撥接上網。
---- 在介紹之前讓我們首先看看如何打開撥号網絡。由于撥号網絡不是一個可執行檔案，是以不能用 “Shell 可執行檔案”的方式來打開。要啟動撥号網絡，需借助 Explorer ，方法如下：
Shell "Explorer ::{20D04FE0-3AEA-1069-A2D8-08002B30309D}/" & "::{992CFFA0-F557-101A-88EC-00DD010CCC48}", vbNormalFocus
---- 但若是要啟動撥号網絡中的某一個連接配接，則需借助rundll.exe 及 rnaui.dll來啟動，方法如下（假定連接配接名稱為163）：
Shell "rundll rnaui.dll,RnaDial 163", vbNormalFocus
---- 說明：在以上叙述中，“,RnaDial 163”這部分不要插入額外的空格，大小寫也不要任意更改。
---- 上面僅僅假定了連接配接名稱，但實際程式設計中我們是不知道其名稱的，如何取得預設的連接配接名稱并啟動它呢？這裡我們可利用系統資料庫來達到目的。完整程式如下：
---- 在窗體上放置一個指令按鈕（名稱為 cmdCallConnect)，下面為代碼部份：
Option Explicit
'有關注冊的API聲明
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal szData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'常數
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_SUCCESS = 0&
Private Sub cmdCallConnect_Click()
'啟動預設撥接上網
Shell "rundll rnaui.dll,RnaDial " + GetConnect, vbNormalFocus
End Sub
Public Function GetConnect() As String
Dim hKey As Long
Dim SubKey As String
hKey = HKEY_CURRENT_USER '主鍵
SubKey = "RemoteAccess" '子鍵
'取得預設連接配接名
GetConnect = GetRegValue(hKey, SubKey, "Default")
End Function
Public Function GetRegValue(hKey As Long, lpszSubKey As String, szKey As String) As Variant
On Error GoTo ErrorRoutineErr:
Dim phkResult As Long
Dim lResult As Long
Dim szBuffer As String
Dim lBuffSize As Long
'建立緩沖區
szBuffer = Space(255)
lBuffSize = Len(szBuffer)
'打開注冊鍵
RegOpenKeyEx hKey, lpszSubKey, 0, 1, phkResult
'查詢結果
lResult = RegQueryValueEx(phkResult,szKey, 0, 0, szBuffer,lBuffSize)
'關閉注冊鍵
RegCloseKey phkResult
'傳回結果
If lResult = ERROR_SUCCESS Then
GetRegValue = Left(szBuffer, lBuffSize - 1)
Else
GetRegValue = ""
End If
Exit Function
ErrorRoutineErr:
GetRegValue = ""
End Function
以上程式在 WIN98,VB6.0 下調試通過。
8、如何通過VB擷取網卡位址
[功能描述] IPX和NETBIOS接口需要網絡位址。該文通過詳細的步驟示範了如何通過VB擷取網卡位址。
步驟：
1)在Visual Basic生成标準的EXE檔案。預設建立 Form1。
2)在Form1中添加一指令按鈕，預設名為Command1。
3)把下列代碼放到Form1中說明部分。
Option Explicit
Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32
Private Type NCB
ncb_command As Byte 'Integer
ncb_retcode As Byte 'Integer
ncb_lsn As Byte 'Integer
ncb_num As Byte ' Integer
ncb_buffer As Long 'String
ncb_length As Integer
ncb_callname As String * NCBNAMSZ
ncb_name As String * NCBNAMSZ
ncb_rto As Byte 'Integer
ncb_sto As Byte ' Integer
ncb_post As Long
ncb_lana_num As Byte 'Integer
ncb_cmd_cplt As Byte 'Integer
ncb_reserve(9) As Byte ' Reserved, must be 0
ncb_event As Long
End Type
Private Type ADAPTER_STATUS
adapter_address(5) As Byte 'As String * 6
rev_major As Byte 'Integer
reserved0 As Byte 'Integer
adapter_type As Byte 'Integer
rev_minor As Byte 'Integer
duration As Integer
frmr_recv As Integer
frmr_xmit As Integer
iframe_recv_err As Integer
xmit_aborts As Integer
xmit_success As Long
recv_success As Long
iframe_xmit_err As Integer
recv_buff_unavail As Integer
t1_timeouts As Integer
ti_timeouts As Integer
Reserved1 As Long
free_ncbs As Integer
max_cfg_ncbs As Integer
max_ncbs As Integer
xmit_buf_unavail As Integer
max_dgram_size As Integer
pending_sess As Integer
max_cfg_sess As Integer
max_sess As Integer
max_sess_pkt_size As Integer
name_count As Integer
End Type
Private Type NAME_BUFFER
name As String * NCBNAMSZ
name_num As Integer
name_flags As Integer
End Type
Private Type ASTAT
adapt As ADAPTER_STATUS
NameBuff(30) As NAME_BUFFER
End Type
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long,ByVal dwFlags As Long, lpMem As Any) As Long
把下面的代碼放入Command1_Click的事件中：
Private Sub Command1_Click()
Dim myNcb As NCB
Dim bRet As Byte
myNcb.ncb_command = NCBRESET
bRet = Netbios(myNcb)
myNcb.ncb_command = NCBASTAT
myNcb.ncb_lana_num = 0
myNcb.ncb_callname = "* "
Dim myASTAT As ASTAT, tempASTAT As ASTAT
Dim pASTAT As Long
myNcb.ncb_length = Len(myASTAT)
Debug.Print Err.LastDllError
pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, myNcb.ncb_length)
If pASTAT = 0 Then
Debug.Print "memory allcoation failed!"
Exit Sub
End If
myNcb.ncb_buffer = pASTAT
bRet = Netbios(myNcb)
Debug.Print Err.LastDllError
CopyMemory myASTAT, myNcb.ncb_buffer, Len(myASTAT)
MsgBox Hex(myASTAT.adapt.adapter_address(0)) & " " & Hex(myASTAT.adapt.adapter_address(1)) _
& " " & Hex(myASTAT.adapt.adapter_address(2)) & " " _
& Hex(myASTAT.adapt.adapter_address(3)) _
& " " & Hex(myASTAT.adapt.adapter_address(4)) & " " _
& Hex(myASTAT.adapt.adapter_address(5))
HeapFree GetProcessHeap(), 0, pASTAT
End Sub
4)按F5，運作該程式。
5)點選Command1。注意，網卡位址将在一資訊框中顯示出來。
9、如何使用 ADO 來壓縮或修複 Microsoft Access 檔案
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來壓縮 Microsoft Access 檔案，RepairDatabase Method 來修複損壞的 Microsoft Access 檔案，。可是自從 ADO 出來之後，好像忘了提供相對的壓縮及修複 Microsoft Access 檔案的功能。
現在 Microsoft 發現了這個問題了，也提供了解決方法，不過有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
這個功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 檔案在您安裝了 MDAC 2.1 之後就有了，您可以在以下的網頁中下載下傳 MDAC 的最新版本！
Universal Data Access Web Site
在下載下傳之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已經是 2.1 以上的版本，您就可以不用下載下傳了！
在您安裝了 MDAC 2.1 或以上的版本之後，您就可以使用 ADO 來壓縮或修複 Microsoft Access 檔案，下面的步驟告訴您如何使用 CompactDatabase Method 來壓縮 Microsoft Access 檔案：
1、建立一個新表單，選擇功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适當的地方加入以下的程式代碼，記得要修改 data source 的內容及目地檔案的路徑：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://nwind2.mdb", _ '來源檔案
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://abbc2.mdb;Jet OLEDB:Engine Type=4" '目的檔案
在 DAO 3.60 之後，RepairDatabase Method 已經無法使用了，以上的程式代碼顯示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
10、如何設定對VB資料庫連接配接的動态路徑
我個人因為經常作一些資料庫方面的程式，對于程式間如何與資料庫進行接口的問題之煩是深有體會，因為VB在資料庫連結的時候，一般是靜态，即資料庫存放的路徑是固定的，如用VB的DATA，adodc,DataEnvironment 等到作資料庫連結時，如果存放資料庫的路徑被改變的話，就會找不到路經，真是一個特别煩的事。
筆者的解決方法是利用app.path 來解決這個問題。
一、用data控件進行資料庫連結，可以這樣：
在form_load()過程中放入：
private form_load()
Dim str As String '定義
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
data1.databasename=str & "/資料庫名"
data1.recordsource="資料表名"
data1.refresh
sub end
這幾句話的意為，打開目前程式運作的目錄下的資料庫。
你隻要保證你的資料庫在你程式所在的目錄之下就行了。
二、利用adodc（ADO Data Control)進行資料庫連結：
private form_load ()
Dim str As String '定義
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "/tsl.mdb"
Adodc1.ConnectionString = str
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from table3"
Adodc1.Refresh
end sub
三、利用DataEnvironment進行資料庫連結
可在過程中放入：
On Error Resume Next
If DataEnvironment1.rsCommand1.State <> adStateClosed Then
DataEnvironment1.rsCommand1.Close '如果打開，則關閉
End If
'i = InputBox("請輸入友人編号:", "輸入")
'If i = "" Then Exit Sub
DataEnvironment1.Connection1.Open App.Path & "/userdatabase/tsl.mdb"
DataEnvironment1.rsCommand1.Open "select * from table3 where 編号='" & i & "'"
'Set DataReport2.DataSource = DataEnvironment1
'DataReport2.DataMember = "command1"
'DataReport2.show
end sub
四、利用ADO(ActiveX Data Objects)進行程式設計：
建立連接配接：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim str
str = App.Path
If Right(str, 1) <> "/" Then
str = str + "/"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "/tsl.mdb"
conn.open str
rs.cursorlocation=aduseclient
rs.open "資料表名",conn,adopenkeyset.adlockpessimistic
用完之後關閉資料庫：
conn.close
set conn=nothing
11、如何讓使用者自行輸入方程式，并計算其結果？
假設我們要讓使用者在“方程式”欄位中自由輸入方程式，然後利用方程式進行計算，則引用ScriptControl控件可以很友善地做到。
( ScriptControl 控件附屬于VB 6.0，如果安裝後沒有看到此一控件，可在CD光牒的 /Common/Tools/VB/Script 目錄底下找此一控件， 其.檔案名為Msscript.ocx。) 假設放在窗體上的ScriptControl控件名稱為ScriptControl1，則在“計算”按鈕的Click事件中編寫如下代碼： Dim Statement As String Statement = "X=" + Text1.Text + vbCrLf + _ "Y=" + Text2.Text + vbCrLf + _ "MsgBox ""計算結果="" & Y " ScriptControl1.ExecuteStatement( Statement )
12、如何解決VB中的Grid控件的列印問題
---- Grid 控件是Visual Basic最常見控件之一， 從VB3.0 到VB5.0 都有該控件。 也是VB愛好者最喜愛的工具之一。用它可以以表格的形式 顯示、浏覽資料，特别是資料庫應用，直接綁定即可顯示浏覽資料庫資訊。然而，美中不足的是Grid 沒有編輯和列印功能，列與列的位置不能互相交換。筆者曾嘗試着給Grid 增添了這些功能，使之錦上添花，功能更強大。下面給出改進方法及源程式，讀者隻需按步驟寫下源程式即可使你的Grid 具有列印功能。該程式筆者在HP5/100Window95環境下用VB5.0 調試通過。
---- 給Grid 控件增加列印方法有三種：1 是直接列印控件的方法，2 是通過 printer 來實作列印功能，3 是通過調用MS-WORD 及MS-EXCEl 來 實 現 打 印。
---- 首先，打開一個應用，在FORM1中增加DATA 控件DATA1,把DATA1的CONNECT 屬性設為dBASE III，再把DATABASENAME屬性設為D:/PJXM.DBF。然後再在FORM1中增加MSFLEXGRID空間GRID1，并把GRID1的DATASOURCE 屬性設為DATA1。這樣資料庫PJXM.DBF 的資訊就會在GRID1中顯示出來。
---- 方法一：直接列印窗體法，在FORM1中增加指令按鈕(command)，CAPTION屬性設為直接列印，再寫入下列編碼：
Sub command_click
Form1.printform
End sub
---- 這樣即可通過列印窗體FORM1的方法把GRID1的資料列印出來，遺憾的是隻能列印GRID1中顯示的資料部分，顯示不出來的則無法列印， 而且這種列印方法很象螢幕硬拷貝把其他控件也列印出來。也不能靈活的控制字型等。
---- 方法二：通過PRINTER實作列印。這種方法
---- 1、加入列印指令按鈕(command1)、函數(print1)即可實作列印功能，寫入下面代碼，讀者稍加改動可寫成标準的函數或過程。
Function prnt1 (x As Integer, y As Integer,
font As Single, txt As String)
printer.CurrentX = x
printer.CurrentY = y
printer.FontBold = False
printer.FontSize = font
printer.Print txt
End Function
Sub command1_click
Dim fnt As Single
Dim pp as integer
Pp=0'設定開始頁碼0
Dim stry,strx,strx1,stry1,linw,page1,p As Integer
Static a(8) As Integer'定義列印的列數
ss$ = "内部結算存入款對帳單"'定義表頭
kan = 0
For i = 0 To 8
a(i) = 1500'定義每列寬
kan = kan + a(i)'計算表格總寬度
Next
page1 = 50'定義每頁行數
strx = 200
strx1 = 200'定義X方向起始位置
stry = 1400
stry1 = 1400'定義Y方向起始位置
linw = 240'定義行寬
fnt = 8'定義字型大小
printer.fontname = "宋體"'定義字型
dd = prnt1(4000, 700, 18, ss$)'列印标題
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
For j = 0 To gridrow - 1'gridrow為所要列印的行數
grid1.row = j
strx = strx1
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
p = p + 1
For i = 0 To 8
grid1.col = i
dd = prnt1(strx, stry, fnt, grid1.text)
strx = strx + a(i)
Next
If p > page1 Then'next page
p = 0
strx = strx1
'line last line
printer.Line (strx - 50, stry + linw)
-(strx + kan - 10, stry + linw)
stry = stry1
'line col
For n = 0 To 8
printer.Line (strx - 30, stry - 30)
-(strx - 30, stry + (page1 + 2) * linw)
strx = strx + a(n)
Next
printer.Line (strx - 30, stry - 30)
-(strx - 30, stry + (page1 + 2) * linw)
pp=pp+1
foot$="第 "+cstr(pp)+"頁"
dd = prnt1(strx - 30-1000, stry + (page1 + 2)
* linw+100, 10, foot$)'列印頁角碼
printer.NewPage'next page
dd = prnt1(4000, 700, 18, ss$) '列印标題
strx = strx1
stry = stry1
printer.Line (strx - 50, stry - 30)-
(strx + kan - 10, stry - 30)' print first row
Else
stry = stry + linw
End If
Next
st = stry
If p < page1 Then '在最後頁剩餘劃空行
For o = p To page1 + 1
strx = strx1
printer.Line (strx - 50, stry - 30)
-(strx + kan - 10, stry - 30)
stry = stry + linw
Next
End If
stry = stry1
strx = strx1
stry = stry1 'line col
For n = 0 To 8
printer.Line (strx - 30, stry - 30)-
(strx - 30, stry + (page1 + 2) * linw)
strx = strx + a(n)
Next
printer.Line (strx - 30, stry - 30)-
(strx - 30, stry + (page1 + 2) * linw)
pp=pp+1
foot$="第 "+cstr(pp)+"頁"
dd = prnt1(strx - 30-1000, stry + (page1 + 2)
* linw+100, 10, foot$)'列印頁角碼
printer.EndDoc'列印結束
Endsub
---- 這種方法通過靈活的程式設計可以友善地調整字型、字型、線形、頁面、紙張大小等。可列印出比較滿意的效果。如果你的計算機上裝有MICROSOFT WORD 和MICRO EXCEL，最精彩的用法還是把GRID 的表格通過VB發送到MICROSOFT WORD 及MICRO EXCEL。生成MICROSOFT WORD 和MICRO EXCEL 表格。這樣就可以充分利用MICROSOFT WORD 和MICRO EXCEL的列印、編輯功能列印出更理想的效果。下面逐一介紹。
---- 方法三：通過生成MICROSOFT WORD表格列印
---- 1、在declaration 中寫入: Dim msword As Object
---- 2、 加入列印指令按鈕(command2)，CAPTION 設為"生成WORD 表格"，寫入下面代碼，
Private Sub command2_Click()
screen.MousePointer = 11
Set msword = CreateObject("word.basic")
Dim AppID, ReturnValue
appID = Shell("d:/office97/office/WINWORD.EXE", 1)
' Run Microsoft Word.
msword.AppActivate "Microsoft Word"
'msword.AppActivate "Microsoft Word", 1
full
Screen.MousePointer = 0
End Sub
---- 2、寫入以下過程full()
Sub full()
Dim i As Integer, j As Integer,
col As Integer, row As Integer
Dim cellcontent As String
Me.Hide
cols = 4'表格的列數
row = gridrow'列印表的行數
msword.filenewdefault
msword.MsgBox "正在建立MS_WORD報表，
請稍候.......", "", -1
msword.leftpara
msword.screenupdating 0
msword.tableinserttable , col, row, , , 16, 167
msword.startofdocument
for j=0 to gridrow' 表格的行數
grid1.row=j
For i = 1 To cols
Gri1d.col=i
If IsNull(grid1.text) Then
cellcontent$ = ""
Else
cellcontent$ = grid1.text
End If
msword.Insert cellcontent$
msword.nextcell
Next i
Next j
msword.tabledeleterow
msword.startofdocument
msword.tableselectrow
msword.tableheadings 1
msword.centerpara
'msword.startdocument
msword.screenrefresh
msword.screenupdating 1
msword.MsgBox " 結束", "", -1
Me.Show
End Sub
---- 方法四：通過發送到MICROSOFT EXCEL實作表格列印
---- 1、加入列印指令按鈕(command3)，CAPTION 設為"生成EXCEL 表格"，寫入下面代碼
Private Sub command3_Click()
Dim i As Integer
Dim j As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Set xlBook = xlApp.Workbooks.Add
'On Error Resume Next
Set xlBook = xlApp.Workbooks.Add 'Open("d:/text2.xls")
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Cells(6, 1) = "i"
For i = 0 To gridrow
grid1.Row = i
For j = 0 To 6
Grid1.Col = j
If IsNull(Grid1.Text) = False Then
xlSheet.Cells(i + 5, j + 1) = Grid1.Text
End If
Next j
Next i
Exit Sub
13、如何在VB中實作繪圖區的大十字光标
有時，我們需要用VB快速開發一個試驗資料繪圖處理程式，将繪圖控件内的滑鼠光标改變成與AutoCAD軟體中使用的大十字光标的形式，将可以比普通的箭頭光标達到更好的效果。那麼我們如何實作這樣的大十字光标呢？
---- 首先，我們明确一下要達到的效果，假若我們在一個Picture控件中繪圖，那麼，滑鼠移動到這個控件上時，滑鼠光标立即改變為大十字形狀，光标中的橫線從控件的左邊界到右邊界，豎線從控件的上邊界到下邊界，即大十字光标将繪圖控件分割為四個象限。當滑鼠移動到控件外時，光标則又恢複成原來的形式。
---- 要實作這樣的光标，得我們自己通過畫線的方式實作。如滑鼠在繪圖控件内，先在滑鼠的目前位置畫上光标的橫線和豎線；當滑鼠位置移動，先擦除原先的光标橫線和豎線，然後再在新的位置畫光标的橫線和豎線，那麼我們就要響應繪圖控件的MouseMove事件。當然，繪圖控件内無論有什麼内容，我們擦除光标線和重畫光标線時都不能破壞原先的内容，是以我們要将繪圖控件的DrawMode設定為vbXorPen（異或方式），繪制光标的橫線和豎線時，用異或的方式将橫線和豎線的象素點顔色設為光标的顔色和原先的象素點色彩的異或值，再用異或的方式在同樣的位置繪制一遍豎線和橫線，橫線和豎線上的象素點再一次和光标顔色進行異或操作，就擦除了光标的橫線和豎線，且又恢複了繪圖控件内原先的内容。
---- 我們還得保證滑鼠移動到繪圖控件内時，普通的滑鼠光标消失，隻有繪制的大十字光标出現，是以還應該設定繪圖控件的MousePointer屬性為vbCuntom，即使用者自定義。繪圖控件的MousePointer屬性設定為vbCustom後，其MouseIcon屬性中應裝入相應的使用者自定義圖形，因為我們希望繪圖控件内隻有我們繪制的光标，而沒有其它的光标，故應該裝入一個空的（透明的）光标圖形。可以任找一個光标檔案，通過任意一個資源編輯器對其進行編輯，用透明的方式填充整個光标圖形，儲存成我們所需的NoIcon.cur即可。
---- 通過以上的關鍵設定和操作，我們就可以實作大十字光标了。利用異或方式進行繪圖，我們還可以實作一般繪圖軟體中常有的“橡皮筋”效果，即用滑鼠定義一個點後，動态拖動滑鼠來定義另外一個點，動态拖動滑鼠過程中，所要繪的圖形也動态相應變化。
---- 以下我們通過一個示例來完整實作繪圖控件中的大十字光标，還示範如何實作用“橡皮筋”效果來畫矩形：
---- 在VB中建立一個标準EXE工程，在Form1中加入一個Picture控件，其Name設為PicDraw，可以裝入一個圖象檔案，PicDraw的大小和其中的圖象大小基本上覆寫大部分的Form1即可。實作代碼如下所示。此程式在VB5.0中運作通過。
Option Explicit
Private Old_X As Single
Private Old_Y As Single
Private isMouseDown As Boolean
Private Box_X0 As Single
Private Box_Y0 As Single
Private Box_X1 As Single
Private Box_Y1 As Single
Private PenColor As Long
Private CrossColor As Long
Private Sub Form_Load()
CrossColor = QBColor(8)
PenColor = QBColor(15)
picDraw.DrawMode = vbXorPen
picDraw.MouseIcon = LoadPicture
(App.Path & "/no.cur")
picDraw.MousePointer = vbCustom
isMouseDown = False
Box_X0 = Box_X1 = Box_Y0 = Box_Y1 = 0
End Sub
Private Sub picDraw_MouseDown
(Button As Integer,
Shift As Integer, X As Single, Y As Single)
If isMouseDown = True Then
'先前已經用滑鼠定義了一個點
Box_X1 = X
Box_Y1 = Y
isMouseDown = False
picDraw.DrawMode = vbCopyPen
picDraw.Line (Box_X0, Box_Y0)-
(Box_X1, Box_Y1),
PenColor, B
picDraw.DrawMode = vbXorPen
'畫一個光标
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
Old_X = X
Old_Y = Y
Else
'定義了一個矩形的第一個頂點，則擦除光标
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
Box_X0 = X
Box_Y0 = Y
isMouseDown = True
End If
End Sub
Private Sub picDraw_MouseMove(Button As Integer,
Shift As Integer, X As Single, Y As Single)
If isMouseDown = True Then
'拖動滑鼠來定義矩形的另外一個頂點，
此時擦除前一個矩形，繪制新的矩形
picDraw.Line (Box_X0, Box_Y0)-(Old_X, Old_Y),
PenColor, B
picDraw.Line (Box_X0, Box_Y0)-(X, Y), PenColor, B
Else
'消除舊光标線
picDraw.Line (0, Old_Y)-(picDraw.ScaleWidth, Old_Y),
CrossColor
picDraw.Line (Old_X, 0)-(Old_X, picDraw.ScaleHeight),
CrossColor
'畫新的光标線
picDraw.Line (0, Y)-(picDraw.ScaleWidth, Y),
CrossColor
picDraw.Line (X, 0)-(X, picDraw.ScaleHeight),
CrossColor
End If
Old_X = X
Old_Y = Y
End Sub
14、如何充分擴充VB功能
Visual Basic for Windowss3.0（簡稱VB）是目前開發WINDOWS應用軟體的最有效工具之一，它綜合運用了BAIC語言和新的可視化設計工具，不僅功能強大，而且簡單易學。其次，VB具有事件驅動的程式設計機制，它充分利用WINDOWS圖形環境的特點，能讓開發人員快速地構造強大的應用程式。
那麼在開發VB應用軟體時，如何充分地擴充VB的功能呢？這就要求在不同的層次上要很好地利用VB最具威力和特色的部分：
●在函數層調用動态連結庫。
●在控件層使用VBX。●在應用層執行其他應用程式。
一、在函數層調用功能态連結庫（DLL）
WINDOWS作業系統實際上是由許多功能強大的動态連結庫（DLL）組合而成。VB考慮到有些工作超過自身語言所及的能力範圍，是以提供了直接調用作業系統中這些DLL子程式的能力。例如：在正常情況下，視窗的控制菜單提供了七種功能：還原、移動、大小、最小化、最大化、關閉和切換。而在實際應用中，我們希望視窗按設計時的大小顯示，不允許使用者随意改變視窗大小，也不允許切換到其他視窗，這就要求在設計時必須删除控制菜單中除“移動”和“關閉”選項以外的所有控制菜單項。要完成這一任務，我們首先可把窗體的MaxButton屬性和MinButton屬性設定為False，不允許窗體最小化和最大化，窗體也就不能還原。然後再把窗體的BorderSstyle屬性設定為1－Fixed Single或3－Fixed Double，不允許窗體改變大小。但VB本身卻無法删除“切換”選項和兩條分隔線。幸運的是，通過調用WINDOWS DLL就很容易做到。
通常，要使用WINDOWS DLL，首先必須說明要使用的DLL子程式，我們可在兩個地方說明所使用的DLL子程式，即在全局子產品中說明，或者在窗體層的說明部分中說明。其格式是：
Declare Sub子程式名Lib“庫名”［Alias“别名”］［（［參數］）］
Declare Function子程式名Lib“庫名”［Aliass“别名”］［（［參數］）］［AS資料類型］
第一種格式表示過程沒有傳回值，第二種格式表示過程傳回一個值，該值可用于表達式中，庫名如果用的是WINDOWS操作環境（在System目錄下）中的庫，如“USER.EXE”，“KERNEL.EXE”或者“GDI.EXE”等，就用此名作為庫名。如果用的是其他來源的DLL，則用包括路徑的檔案名稱（如：“C：＼WINDOWS＼BRUSH.DLL”）。别名（Alias）是允許另外使用别的名稱來稱呼子程式，尤其是當外來子程式名與VB保留字相同時，它就顯得特别有用，參數指要被傳遞到子程式的參數值，資料類型指的是函數傳回值的資料類型，它可能是Integer，Long，Single，Double，Currency或String。下面就是所要使用的DLL子程式的說明：
Declare Function GetSystemMenu％ Lib＂User＂（ByValhWnd％，ByValbRevert％）
Declare ＼function ＼RemoveMenu％ Lib＂User＂（ByValhMenu％，ByValnPosition％，ByValwFlags％）
當說明完DLL子程式後，執行DLL子程式的方法，就象在VB中執行通用過程（函數）一樣。下面我們編寫一個名為Remove－Items－From－System的過程來完成上面例子中提到的功能，過程中調用了上述說明過的兩個DLL子程式：
Sub remove－Items－From－Sysmenu（A－Form As Form）
'擷取窗體系統菜單句炳
HSysMenu＝GetSystemMenu（A－Form.hWnd，0）
'删除除“移動”和“關閉”外的所有菜單項， 删除時必須從最後一個菜單項開始
R＝RemoveMenu（HSysMenu，8，MF－BYPOSITION） '删除切換
R＝RemoveMenu（HSysMenu，7，MF－BYPOSITION） '删除第一條分隔線
R＝RemoveMenu（HSysMenu，5，MF－BYPOSITION） '删除第二條分隔線
End Sub
有了這個過程，在任一窗體的Form－Load事件中加入下面一行代碼就可以删除該窗體除“移動”和“關閉”選項以外的所有控制菜單項：
Remove－Items－From－Sysmenu Me
二、在控件層使用VBX
VB功能強大的第二個部分是VBX的使用，即其開放及無限擴增的特性。雖然VB工具箱（ToolBox）已經盡量将設計應用軟體所需的工具包括在内，但是，為了不斷擴充VB的功能，VB提供了一套開發工具（Custom Control Development Kit）供第三方開發者來設計所需要的控件。當設計完控件檔案後（其檔案擴充名為“.VBX”）可以從菜單“file”項下選“Add File...”指令，結果畫面上出現一個＂Add File＂對話框，輕按兩下所需的VBX檔案名即可将該VBX加入到VB中，這些控件裝入VB後，VB會将這些外來控件加到原有工具箱中，與其他控件一起合并使用。正是因為有了這一技術，VB才能夠不斷發展，使用VB程式設計也更為友善、迅速和有效，這是VB差別于其他程式開發環境的主要特色之一。自從VB推出以來，第三方軟體公司設計了大量的新控件，下面是開發WINDOWS應用程式時幾個非常有用的VBX：
●三維控件Threed.vbx
它提供了包括指令按鈕、複選框、單選鈕 、架構、下推按鈕和面闆在内的六種三維控件，使用這些控件可使窗體更具有立體感。
●圖形控件Graph.vbx
向圖形控件發送資料後，圖形控件可繪制二維或三維餅圖，、直方圖、趨勢圖，并且可以列印或拷貝到剪貼闆上。
●通訊控件Mscomm.vbx
它提供了串行通訊的能力，可用于串行端口之間傳送和接收資料。
●資料網格控件Truegrid.vbx
它既可以作為一般的資料顯示表格，也可把一個資料庫和一個網格聯系起來，它是制作資料庫浏覽器或資料顯示的理想工具。
二、在應用層執行其他應用程式
在編制複雜的大型軟體時，我們經常會需要有一些功能相對獨立和完善的專用程式，如編輯程式，而這些程式通常是通用和流行并經實踐檢驗的。如果由開發者重新編制這些程式，不僅大大增加了程式工作量以及調試過程，而且功能上很難比得上這些通用程式。顯然，如果我們能直接調用這些程式是最為理想的。令人欣喜的是，VB提供了一個可用來調用其他應用程式的Shell函數，使VB的某些功能可直接由其他應用程式來完成，進而大大地減少了程式設計任務。
格式是Shell（指令字元串［，視窗類型］）
其中的指令字元串是欲執行的應用程式名，可執行檔案的擴充名隻限于“.COM”，“.EXE”，“.BAT”，“.PIF”，預設擴充名為.EXE檔案，視窗類型是一整數值，它對應于程式執行時的顯示視窗風格，是可選 的，共有下列5種選擇：
視窗類型值
視窗類型 1，5，9
正常視窗，具有指針 2
最小視窗，具有指針（預設） 3
最大視窗，具有指針 4，8
正常視窗，不具指針 6，7
最小視窗，不具指針
當Shell函數成功地調用某一個應用程式時，傳回一個任務辨別（Task ID），該ID表示正在執行的程式的唯一辨別。
［例］
X＝Shell（"C：/WINDOWS/NOTEPAD.EXE",1）
該語句調用WINDOWS附件中的記事本NOTEPAD.EXE作為編輯程式來使用，并傳回1個ID值到X。
15、成組更新控件屬性
Sub EnableAll(Enabled As Boolean, ParamArray objs() As Variant)
Dim obj As Variant
For Each obj In objs
obj.Enabled = Enabled
Next obj
End Sub
應用：
EnableAll True, Text1, Text2, Command1, Command2
VB問題全功略（4） [查找本頁請按Ctrl+F]
［上一頁］（4）［下一頁］
16、如何避免程式重複執行？（偵測是否存在前一副本，若有，則結束目前新啟動的程式）
17、如何讓一個 App 永遠保持在最上層 ( Always on Top )
18、表單配置視窗和解析度
19、連續變量的聲明 Dim a, b, c as string * 4
20、正确的除錯 (Debug) 方式
16、如何避免程式重複執行？（偵測是否存在前一副本，若有，則結束目前新啟動的程式）
使用者在啟動程式後，有時會将程式縮小在工作列上，之後要用時，又會重新啟動一次程式，資料庫程式有時會是以造成資料錯亂！若您不希望使用者重複啟動程式，您可以使用 APP 物件來判斷，方法如下：
Private Sub Form_Load()
If App.PrevInstance Then '檢視前一版本
MsgBox "此程式已經在執行中！", 48
End
End If
End Sub
17、如何讓一個 App 永遠保持在最上層 ( Always on Top )
請在聲明區中加入以下聲明
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
Const SWP_NOMOVE = &H2 '不更動目前視窗位置
Const SWP_NOSIZE = &H1 '不更動目前視窗大小
Const HWND_TOPMOST = -1 '設定為最上層
Const HWND_NOTOPMOST = -2 '取消最上層設定
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
'将 APP 視窗設定成永遠保持在最上層
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
'取消最上層設定
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
18、表單配置視窗和解析度
這個地方不是要告訴您如何寫出一支程式，會自動根據使用者熒幕的解析度調整 Form 及各控制項的大小，也就是适用于各種解析度的程式。那是另一個主題！
由于我在集團式的公司資訊中心上班，在我的開發過程中，我的使用者依不同公司别，分成幾個族群，有的公司都是使用 640x480 的解析度，有的都用 800x600，設計公司則是 1024x768，為了替這些公司開發軟體，在 VB5.0 以前，寫各家公司的程式以前就必須先調整熒幕的解析度 (否則在解析度 800x600 的電腦上開發的程式，在 640x480 解析度的電腦中執行時，右方和下方的畫面會跑出熒幕外面)，有的電腦一改變解析度就必須重新開機，更是麻煩！
VB5.0 以後，VB 多提供了一個功能，就是【表單配置視窗】，從此以後，您可以在高解析度的熒幕中，開發低解析度的程式，要怎麼做呢？ 《假設您的電腦解析度是 1024x768》
很簡單！在【表單配置視窗】上的熒幕上按滑數右鍵，選擇【解析度】。看到了嗎！在【表單配置視窗】上的熒幕上，出現了二個虛線框，上面各标明了 640x480 及 800x600。好了！現在您可以開始開發各種不同解析度的系統了！
例如您要開發的系統，解析度是 640x480，您隻要注意不要讓您的表單超出 640x480 的虛線框就可以了！
19、連續變量的聲明 Dim a, b, c as string * 4
我想聲明 a,b,c 三個字串變量
Dim a, b, c as string * 4 (錯的)
這樣的聲明在 VB 中，結果可能和您要的不同！
有些程式語言，例如 C，類似以上的聲明表示三個字串變量。
但是在 VB 中卻不是如此！
以上的聲明在 VB 中表示聲明了 a,b 2 個 variant (不定形态變量)，以及 c 這個字串變量。
要聲明 a,b,c 三個字串變量，正确的寫法如下：
Dim a as string * 4
Dim b as string * 4
Dim c as string * 4
若想寫在同一行，也可以，寫法如下：
Dim a as string * 4, b as string * 4, c as string * 4
20、正确的除錯 (Debug) 方式
當程式執行起來怪怪的，很多人在除錯 (Debug) 時，都喜歡在程式中使用中斷點 (Break) 加上 MsgBox 來看執行結果，但有些時候，這樣子的作法會造成某些事件 (Event) 無法觸發，甚至改變事件原來觸發的順序！
比較正确的作法是在程式中使用 Debug.Print "事件名稱/要顯示的訊息" ，而不要用中斷點 (Break)。
21、Move Method 速度較快
當我們要移動控制項 (Control) 或表單 (Form) 時，很多人習慣這樣寫：
frmCustomer.Left = frmCustomer.Left + 100
frmCustomer.Top = frmCustomer.Top + 50
但是若使用 Move Method ，可以加快 40%：
frmCustomer.Move frmCustomer.Left + 100, frmCustomer.Top + 50
22、哇！我的變量名稱變成了保留字！
當我們更新 VB 的版本時，有時候會因為以前程式中使用的變量名稱或函數名稱變成了保留字，而使程式跑起來完全不正常，例如：
print：VB3 時不是保留字，但到了 VB4 卻變成了保留字。
array：VB4 時不是保留字，但到了 VB5 卻變成了保留字。
遇到這種情形，其實也很簡單！隻要在 VB 中叫出該工程，打開任何一個表單的程式碼，選擇【編輯功能表】中的【取代】，搜尋範圍設定成【整個工程】，并将【全字拼寫須符合】選項打勾，然後将該工程中該字串改成另一個新字串，再重新 Make 成執行檔即可。
下一次您更新 VB 的版本時，若原來正常的程式跑起來變得怪怪的，别忘了檢查一下您自己定義的變數名稱或函數名稱是否也變成了保留字！
23、快捷鍵 -- 找尋 Function/Subroutine
當您的 APP 愈來愈大時，或是您要維護别人開發的大系統時，是否曾經有過一種情形，程式中 call 了某一個 Function/Subroutine，您要找尋這個 Function/Subroutine，除了一個一個 Module 找之外，大部份的人都是使用【編輯功能表】的【搜尋】功能。
其實您可以使用 【Shift + F2】快捷鍵！很簡單，方法如下：
隻要将滑鼠停留在程式中該 Function/Subroutine Name 上，再使用【Shift + F2】快捷鍵即可！
24、我上一次程式寫到那裡呢？
有時候您會同時寫幾個不同的程式，或因為某種原因，程式停了一段時間，當您下一次要再繼續寫時，已經忘了上次寫到那裡了，其實有一個很簡單的方法，可以馬上喚起您的記憶！
在您在寫程式中要停下時，先随便寫一行注解，但是拿掉注解符号〈'〉後存檔，下一次您載入工程後，馬上使用【執行功能表】中的【全部編譯後開始】，此時第一個錯誤的地方使是上次程式中斷的地方！
25、不友善的 Msdn -- VB6.0 的 Help
很多 VB 程式設計師抱怨為了存取 VB6.0 的 Help，必須一直将 Msdn 光碟放在光碟機中，否則就必須安裝 680MB 的 Help 到硬碟中！
其實還有一個比較人性化的方法，就是在安裝 Msdn 時，選擇【自訂安裝】，然後隻要選擇 Visual Basic 檔案 (13792K) 即可。
如此您便可以直接由硬碟存取 VB 的相關主題，若您想看其他非 VB 主題，再由光碟存取。
VB問題全功略（6） [查找本頁請按Ctrl+F]
［上一頁］（6）［下一頁］
26、如何快速設定 Form 上所有控制項的 TabIndex 順序
27、Boolean 值的轉換
28、呼叫子程式（Subroutine）
29、輸入時，自動轉換成大寫？
30、輸入時，自動轉換成小寫？
26、如何快速設定 Form 上所有控制項的 TabIndex 順序
由于在設計 Form 上的控制項時，不一定會依照輸入的順序，在完成設計之後，我們通常會重設各控制項的 TabIndex 順序，當 Form 上的控制項比較多時，設定起來相當麻煩，常常還會設錯。
有一個很簡單又不容易出錯的方法，是從畫面上的右下角往左上角 (方向是先向左再往上)，逐一的将控制項的 TabIndex 屬性設成 0。
1：右手用滑鼠點一下右下角的控制項，左手按 F4，将 TabIndex 設成 0。
2：右手往左用滑鼠點一下倒數第二個控制項，左手按 F4，左手按 0。
3：右手往左用滑鼠點一下倒數第三個控制項，左手按 F4，左手按 0。
4：重複以上動作直到左上角第一個控制項為止。
好了，您已經設定好整個 Form 上所有控制項的 TabIndex 順序了！其原理就是當您設定一個控制項的 TabIndex 為 0 時，原來 TabIndex 為 0 的控制項，TabIndex 就變成了 1、而 1 的變成 2...依序 +1 改變。
27、Boolean 值的轉換
我們都知道 Boolean 這個資料形态隻有 True/False 二種值，但是當我們要存到資料庫時，我們常常會将它轉成數值，您可以直接設定 True=-1 / False =0，若您必須使用函數轉換，很可能會用 Val()，但是小心，其結果是錯的！
您必須使用 Abs() 或 CInt()，為什麼呢？看結果就知道了！
Val(True) 結果是 0
CInt(True) 結果是 -1
Abs(True) 結果是 1
28、呼叫子程式（Subroutine）
當我們呼叫子程式 (Subroutine) 時，有二種方法：
1、Call MyRoutine(參數)
2、MyRoutine 參數
注意第二個方法不可以使用括号 ()，否則 VB 會誤認為是運算子，本來應該是傳址 (Reference)，就會變成了傳值 (Value)！看看以下的例子就知道了：
Call MyRoutine(Text1) 正确
意思是要将 Text1 這個控制項傳入 MyRoutine 中，但是如果拿掉 Call 這個字，VB 傳給 MyRoutine 的卻變成了 Text1 的内含值了！也就是 Text1.text。
MyRoutine(Text1) 錯誤
MyRoutine 要的本來是一個控制項，結果卻傳入了一個字串，您會得到一個《type-mismatch / 資料型态不符》
29、輸入時，自動轉換成大寫？
要自動轉換大小寫，很多人首先想到的一定是 UCase$ 及 LCase$，但是要使用這二個函數，一定不可以在 Key_Press 事件中使用，否則您若輸入《abc》，結果卻變成《CBA》，為什麼呢？
因為當您輸入 a 之後，UCase$ 會替您轉換成 A，但是轉換完後，滑鼠的遊标會停在 A 的前面，您繼續輸入 b，變成了 bA，UCase$ 又替您轉換成 BA，轉換完後，滑鼠的遊标又停在 BA 的前面，您繼續輸入 c，變成了 cBA，UCase$ 又替您轉換成 CBA！ 若您不相信，可以自己試試
在 Key_Press 中正确的作法，是判斷它的參數 KeyAscii ！a 的 Asc 值是 97，A 的 Asc 值是 65，是以要自動将小寫轉成大寫，寫法如下：
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii >= 97 And KeyAscii <= 122 Then
KeyAscii = KeyAscii - 32
End If
30、輸入時，自動轉換成小寫？
要自動轉換大小寫，很多人首先想到的一定是 UCase$ 及 LCase$，但是要使用這二個函數，一定不可以在 Key_Press 事件中使用，否則您若輸入《ABC》，結果卻變成《cba》，為什麼呢？
因為當您輸入 A 之後，LCase$ 會替您轉換成 a，但是轉換完後，滑鼠的遊标會停在 a 的前面，您繼續輸入 B，變成了 Ba，LCase$ 又替您轉換成 ba，轉換完後，滑鼠的遊标又停在 ba 的前面，您繼續輸入 C，變成了 Cba，LCase$ 又替您轉換成 cba！ 若您不相信，可以自己試試
在 Key_Press 中正确的作法，是判斷它的參數 KeyAscii ！a 的 Asc 值是 97，A 的 Asc 值是 65，是以要自動将大寫轉成小寫，寫法如下：
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii >= 65 And KeyAscii <= 90 Then
KeyAscii = KeyAscii + 32
End If
VB問題全功略（7） [查找本頁請按Ctrl+F]
［上一頁］（7）［下一頁］
31、某一天的下 (上) 一個星期幾是那一天？
32、移除字串中不要的字元
33、通往 Internet 的捷徑---捷徑檔的結構
34、Bug：維護 Internet Transfer Control 之 Username 及 Password
35、我要如何在程式中開啟網頁？
31、某一天的下 (上) 一個星期幾是那一天？
參數 : 您相信嗎？這個模組的寫法比用任何其他的方法快幾十倍！參數如下：
1：以那一天為基準日？
2：(Optional) 要找的是星期幾？若不指定，預設值為星期六
3：(Optional) 要往前 (過去) 找或往後 (未來) 找？
若不指定，預設值為往後 (未來) 找
程式碼
Public Function SpecificWeekday(ByVal D As Date, Optional ByVal WhatDay As VbDayOfWeek = vbSaturday, Optional GetNext As Boolean = True) As Date
SpecificWeekday = (((D - WhatDay + GetNext) / 7) - GetNext) * 7 + WhatDay
End Function
或許您想知道程式為什麼這樣寫？
您知道嗎？在 VB 中，其所有日期函數的基準日 (第0天) 是 1899年12月30日 (星期六)，第一天就是 1899年12月31日 (星期日)，是以 VB 的 WeekDay 函數算法其實就是 (Date - 1) Mod 7 + 1。
傳回值
日期
執行個體 :
我想知道以下日子各是那一天？
上個星期一：SpecificWeekday(Now, vbMonday, False)
下個星期六：SpecificWeekday(Now)
2000年9月9日的下一個星期五：SpecificWeekday("09/09/2000", vbFriday)
32、移除字串中不要的字元
參數 : 1：要檢查的字串 [準備移除其中某些字元]
2：要移除的字元 (數字/中英文)
程式碼
Function StringCleaner(s As String, Search As String) As String
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function
傳回值 移除某些字元後的字串
執行個體 :
我想移除 Text1 中的字元 "A"
Text1 = StringCleaner(Text1, "A")
33、通往 Internet 的捷徑---捷徑檔的結構
有些軟體 Setup 完後, 會在程式集或桌面上産生一個 "捷徑" (ShortCut), 直接一點就可以進到特定的網頁, 用 VB 要如何做才可以做到? 難嗎?
不難!! 其實隻要稍為觀查一下該捷徑的檔案内容, 就可以做到了.
捷徑檔的副檔名是 .url, 當然, 如果您直接用記事本去開啟 .url 檔, 一定會很失望, 因為很多軟體的捷徑檔, 都是存成 Binary 的檔案 (不知是否故意的), 不過别擔心, 那隻是障眼法而已.
捷徑檔和 VB 的 .Frm 檔一樣, 不管是 AscII / Binary 都可以.我們自己要産生的, 隻要做成一般文字檔就可以了, 而捷徑檔的格式如下 :
[InternetShortcut]
URL=http://網址 (Internet/ Intranet 通用)
然後随便存一個檔名, 例如 "潤泰網站.url", 隻要副檔名是 .url 即可.
而且 Win95/Win98 很聰明, 會自動将副檔名拿掉. 隻 Show 出 "潤泰網站"
很簡單吧!!! 就算您的機器不能連上 Internet, 您也可以馬上感受一下 Intranet 的功能.
[InternetShortcut]
URL=http://Intranet主機/目錄
如果您連用 VB 寫文字檔都懶的話, 直接用記事本編輯也可以體驗一下的 !!!
34、Bug：維護 Internet Transfer Control 之 Username 及 Password
由于 Bug，在使用 Internet Transfer Control 時，Username 及 Password 必須設定在 URL 之後，否則無效！以下的程式碼是錯的：
Inet1.Password = "Chicken_Feet"
Inet1.UserName = "JohnnyW"
Inet1.URL = FTP://ftp.32X.com
Inet1.Text = Inet1.OpenURL
但是如果改成以下之程式，将 URL 放到最前面，就可以正常執行：
Inet1.URL = FTP://ftp.32X.com
Inet1.Password = "Chicken_Feet"
Inet1.UserName = "JohnnyW"
Inet1.Text = Inet1.OpenURL
35、我要如何在程式中開啟網頁？
在聲明區中聲明如下 (在 .bas 檔中用 Public, 在 Form 中用 Private)
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
在程式中
Intranet：
ShellExecute Me.hWnd, "open", "http://Intranet主機/目錄", "", "", 5
Internet：
ShellExecute Me.hWnd, "open", "http://www.ruentex.com.tw", "", "", 5
很簡單吧!!! 就算您的機器不能連上 Internet, 您也可以馬上感受一下 Intranet 的功能.
36、如何讓表單一開始就顯示在熒幕中央？ （含工作列）
共有二種方法
方法1: VB3/VB4之版本，可于 Form_Load() 程式中加入下列程式碼：
Me.Move (Screen.Width-Width)/2, (Screen.Height-Height)/2
方法2:
VB5以上之版本，則直接将 Form 之 StartUpPosition 設成 (2-熒幕中央) 即可
37、如何讓表單一開始就顯示在熒幕中央？ （不含工作列）
以下之程式在計算時會扣除工作列所占的高度 (或寬度)，如果有啟動 Microsoft Office 的快捷列的話，也會扣除快捷列所占的高度 (或寬度)。
Public Const SM_CXFULLSCREEN = 16
Public Const SM_CYFULLSCREEN = 17
#If Win32 Then
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
#End If
Public Sub CenterForm(frm As Form)
frm.Left = Screen.TwipsPerPixelX * GetSystemMetrics(SM_CXFULLSCREEN) / 2 - frm.Width / 2
frm.Top = Screen.TwipsPerPixelY * GetSystemMetrics(SM_CYFULLSCREEN) / 2 - frm.Height / 2
End Sub
隻要在 Form_Load 中使用 CenterForm Me 即可
38、MDI Form可否跟一般的表單一樣設定背景顔色 (BackColor)？
VB3 以前的版本：不行。MDI Form沒有此一功能。
VB4 / VB5 / VB6 ：可以直接在屬性表中設定！
39、VB可以産生四角形以外其他形狀的 Form 嗎？
這個問題，您一定無法想像有多容易，您可以産生任何形狀的 Form，但必須借助 CreateEllipticRgn 及 SetWindowRgn 二個 API ，例如：
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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Sub Form_Load()
Dim lReturn As Long
Me.Show
lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(10, 10, 340, 150), True)
End Sub
執行結果圖檔
CreateEllipticRgn 之四個參數說明如下：
X1：橢圓中心點之X軸位置，但以 Form 的實№邊界為限。
Y1：橢圓中心點之Y軸位置，但以 Form 的實№邊界為限。
X2：橢圓長邊的長度
Y2：橢圓短邊的長度的
40、如何讓一個 Form 出現在另一個非 MDIForm 的 Form 中？
假設要将 Form2 放在 Form1 中，請在宣告區中宣告：
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
在 Form2 中的 Form_Load 中加入 SetParent(Me.hWnd, Form1.hWnd) 即可。
但有一點要注意的是，在 Unload Form1 之前一定要先 Unload Form2。
VB問題全功略（9） [查找本頁請按Ctrl+F]
［上一頁］（9）［下一頁］
41、如何産生漸層的 Form 背景？
42、Set FormName = Nothing
43、如何移除 Form 右上方之『X』按鈕？
44、如何制作透明的表單 (Form)？
45、在抓取資料庫之資料前先計算資料總筆數
41、如何産生漸層的 Form 背景？
在 Form_Load 中加入以下程式碼
Sub Form_Load()
Form1.AutoRedraw = True
'使 Form 物件的自動重繪有效
Form1.DrawStyle = 6
'直線的樣式為内實線 (6-vbInsideSolid)
Form1.DrawMode = 13
'copy Pen-由 ForeColor 屬性指定的顔色。(13-vbCopyPen)
Form1.DrawWidth = 2
'輸出的線寬為 2 像素 (Pixel)
'為繪圖或列印建立一自訂的座标比例尺
'圖形像素為顯示器或印表機解析度的最小機關
Form1.ScaleMode = 3
'設定物件座标的量測機關為像素 (3-VbPixels)
Form1.ScaleHeight = (256 * 2)
'設定垂直量測機關值為 512
For i = 0 To 255
Form1.Line (0, Y)-(Form1.Width, Y + 2), RGB(0, 0, i), BF
Y = Y + 2
Next i
'RGB(red, green, blue)
'B : 使一方塊用一指定方塊對角的座标畫出
'F : 指定此方塊系以用來畫方塊的色彩來加以填滿 (有B才可用F)
End Sub
42、Set FormName = Nothing
文法：Set objectvar = {[New] objectexpression | Nothing}
Nothing 為選擇性引數。停止 objectvar 和任何特定物件的關連。指定 objectvar 為 Nothing，會在沒有其它變數引用時，釋放所有與先前物件有關的系統和記憶體資源。
當 objectvar 設定成 FormName 時，會将該 Form 中所有占用記憶體的物件所占用的記憶體通通釋放。
雖然有人說 VB 在 Form Unload 時會自動釋放記憶體，但是并不是全部!!
就像有人說, VB 程式要 Make EXE 之前最好先結束 VB, 重新載入該 Project 再 Make EXE, 結果執行檔會比較小, 為什麼 ? 就是少了一些在記憶體中的垃圾 !!
43、如何移除 Form 右上方之『X』按鈕？
其實 Form 右上方之三個按鈕分别對應到 Form 左上方控制盒 (ControlBox) 中的幾個選項 (縮到最小 / 放到最大 / 關閉)，而其中的最大化 (MaxButton) 及最小化 (Minbutton) 都可以直接在 Form 的屬性中設定，但是 VB 并沒有提供設定『X』按鈕的功能！要達到這個功能，必須借助 API：
由于『X』按鈕對應到 ControlBox 的關閉選項，是以我們隻要移除系統 Menu (就是ControlBox) 的關閉選項即可！您自己可以先看看您現在使用的 Browser 左上方的系統 Menu，【關閉】選項是在第幾個，不是第 6 個！是第 7 個，分隔線也算一個！分隔線才是第 6 個！
當我們移除了關閉選項之後，會留下一條很奇怪的分隔線，是以最好連分隔線也一并移除。而 Menu 的 Index 是從 0 開始，分隔線是第 6 個，是以 Index = 5。
修正：為了讓程式碼在 Windows NT 也能運作正常，将各 Integer 型态改成 Long。 89.05.04
'抓取系統 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
'移除系統 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" Alias "RemoveMenu" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
'第一個參數是系統 Menu 的 hwnd
'第二個參數是要移除選項的 Index
44、如何制作透明的表單 (Form)？
請在聲明區中放入以下聲明
Const GWL_EXSTYLE = (-20)
Const WS_EX_TRANSPARENT = &H20&
Const SWP_FRAMECHANGED = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_SHOWME = SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE
Const HWND_NOTOPMOST = -2
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 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
在 Form_Load 使用的範例如下：
Private Sub Form_Load()
SetWindowLong Me.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_SHOWME
Me.Refresh
End Sub
45、在抓取資料庫之資料前先計算資料總筆數
Sub Form1_Load()
Dim db As Database
Dim ds As Snapshot
Dim iNum As Integer '總筆數
Dim wsql As String 'SQL字串
wsql = "Select Count (*) from Authors Where AU_ID > 10"
Set db = OpenDatabase("c:/vb/biblio.mdb")
Set ds = db.CreateSnapshot(wsql)
iNum = ds(0)
MsgBox "總筆數為 " + Str$(iNum)
End Sub
怎麼樣，是不是一樣呢，隻差在一個是 ADO，一個是 DAO 而已！
46、程式啟動時，如何自動判斷 Access 資料庫是否損毀并自動修複？
若程式使用 Access 資料庫開發，當 Access 資料庫損毀時，一進入程式，便會出現以下訊息：
Can't open database 'name'. It may not be a database that your application recognizes, or the file may be corrupt. (Error 3049)
若是程式中未加入錯誤判斷，程式便會中斷跳出，這會給予使用者極不好的印象，要避免這種情形，甚至不讓使用者發現資料庫損毀，便要加入以下之程式碼加以判斷：
Private Sub Form_Load()
Dim db As Database
On Error GoTo error1
Set db = OpenDatabase("c:/test.mdb")
On Error GoTo 0
: '正常程式開始
:
Exit Sub
error1:
If Err = 3049 Then '資料庫損毀
DBEngine.RepairDatabase "C:/test.mdb"
Resume
Else
MsgBox Err & Error(Err)
End If
47、如何讓程式在 Windows 啟動時自動執行？
有以下二個方法：
方法1: 直接将快捷方式放到啟動群組中。
方法2:
在注冊檔 HKEY_LOCAL_MACHINE 中找到以下機碼
/Software/Microsoft/Windows/CurrentVersion/Run
新增一個字串值，包括二個部份
1. 名稱部份：自己取名，可設定為 AP 名稱。
2. 資料部份：則是包含 '全路徑檔案名稱' 及 '執行參數'
例如：
Value Name = Notepad
Value Data = c:/windows/notepad.exe
48、如何讓程式在新 User Login 時自動執行？
在系統資料庫中 HKEY_CURRENT_USER 找到以下代碼
/Software/Microsoft/Windows/CurrentVersion/Run
新增一個字串值，包括二個部份
1. 名稱部份：自己取名，可設定為 AP 名稱。
2. 資料部份：則是包含 '全路徑檔案名稱' 及 '執行參數'
例如：
Value Name = Notepad
Value Data = c:/windows/notepad.exe
49、已将 TextBox 的 Alignment 屬性設為「1-靠右對」(1-RightJustify)，但文字卻未向右靠？
欲将 TextBox 内的文字向右靠，除了将 Alignment 屬性設為「1-靠右對 」之外，亦 将 MultiLine 屬性設為 True。
但是若您希望隻有單行，不要多行，則必須判斷 User 是否按了 Enter Key，那隻好在 TextBox 的 KeyPress 中加入以下程式碼，以去除 Enter 的作用：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
End If
50、在 TextBox 中如何限制隻能輸入數字？
參考下列程式：
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 57 Then
KeyAscii = 0
End If
End Sub
51、我希望 TextBox 中能不接受某些特定字元，例如 '@#$%"，有沒有簡單一點的寫法？
方法有好幾種, 以下列舉二種：
方法1: 可以使用 IF 或 Select Case 一個個判斷, 但如果不接受的字元多時, 較麻煩!
方法2: 将要剔除的字元統統放在一個字串中，隻要一個 IF 判斷即可 !! 如下：
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
sTemplate = "[email protected]#$%^&*()_+-=" '用來存放不接受的字元
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then
KeyAscii = 0
End If
End Sub
52、如何讓滑鼠進入 TextBox 時自動標明 TextBox 中之整串文字？
這個自動標明反白整串文字的動作，會使得輸入的資料完全取代之前在 TextBox 中的所有字元。
Private Sub Text1_GotFocus()
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
53、如何讓 TextBox 由 Insert 模式變成 Overwrite 模式？
Windows 的 TextBox 一直都隻支援 Insert Mode，而不支援 OverStrike(OverWrite) Mode，其實，隻要在 Key_Press 事件中加上幾行指令，就可以做到 OverStrike 功能 !!
以下的程式碼中，隻設定 SelLength=1，而 SelStart 若未指定則會一直跟著滑鼠的遊标所在處，設定 SelLength=1 會反白遊标所在處的下一個字，但是由于您輸入的字元會直接取代該反白的字元(都同時在 Key_Press 發生)，是以您并不會看到字元被標明反白 (Marked)，若是遊标已在字串的最後面，則會直接忽略這個動作。
以下的程式碼中同時也作了以下的錯誤判斷及預防：
1. 當輸入的是倒退符，也就是 Backspace (character 8)。
2. 當輸入的是 return 鍵 (character 13)。
3. 事先已作了標明動作 (Marked)。
Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii <> 8 And KeyAscii <> 13 And Text1.SelLength = 0 Then
Text1.SelLength = 1
End If
End Sub
54、如何使 TextBox 變成隻讀，卷動杆可卷動，但是不出現遊标，也不可被標明反白？
在 Form 中放一個 TextBox，設定 Locked = True，MultiLine = True，ScrollBar = 2 - Vertical。另外再放一個 CommandButton (或其他任何可接受 Focus 的物件)，此物件可由您自行作其他用途，否則設定 Command1.left = -1000 将其移到 Form 的外面。
程式碼如下：
Private Sub Text1_GotFocus()
'馬上将 Text1 的 focus 轉移到 Command1 或其他物件上
Command1.SetFocus
End Sub
55、文字框可以設定快捷鍵嗎？
不行，要設定快捷鍵的先決條件，是該物件必須有 Caption 屬性，但是 TextBox (文字框) 隻有 Text 屬性，并無 Caption 屬性，是以文字框本身是不能設定快捷鍵的！完全沒辦法嗎？
但是還是有辦法的！人家說山不轉路轉，文字框本身不能設定快捷鍵，一般我們在文字框的左方都會放置說明用的 Label，那我們就借用 Label 來做到這個功能，作法如下：
1、将文字框的 TabIndex 設成說明用的 Label 物件的下一個。
2、設定 Label 物件的快捷鍵，奇怪嗎？Label 物件沒有 Focus 好像不要快捷鍵！沒錯，我們就是要利用 Label 物件不要快捷鍵的特性來達到我們的要求！
當您輸入了 Label 物件的快捷鍵，由于 Label 物件沒有 Focus 不接受快捷鍵，于是它立刻将 Focus 送到下一個 TabIndex 的物件，也就是 TextBox 文字框了！
56、如何檢查軟碟驅動器裡是否有軟碟？
使用：
Dim Flag As Boolean
Flag = Fun_FloppyDrive("A:")
If Flag = False Then MsgBox "A:驅沒有準備好，請将磁盤插入驅動器！", vbCritical
'-------------------------------
'函數:檢查軟驅中是否有盤的存在
'-------------------------------
Private Function Fun_FloppyDrive(sDrive As String) As Boolean
On Error Resume Next
Fun_FloppyDrive = Dir(sDrive) <> ""
End Function
57、如何彈出和關閉光驅托盤？
Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Sub Command1_Click()
mciExecute "set cdaudio door open" '彈出光驅
Label2.Caption = "彈 出"
End Sub
Private Sub Command2_Click()
Label2.Caption = "關 閉"
mciExecute "set cdaudio door closed" '合上光驅
Unload Me
End
End Sub
58、如何計算出本月的最後一天
首先為下個月的第一天生成一個順序數值，然後再減去一天
Private Sub Command1_Click()
Dim dtl As Date
dtl = DateSerial(Year(Now), Month(Now) + 1, 1) - 1
MsgBox dtl
End Sub
59、如何讓你的程式在任務清單隐藏
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
'請你試試 Ctrl+Alt+Del 是不是你的程式隐藏了
Private Sub Command1_Click()
i = RegisterServiceProcess(GetCurrentProcessId, 1)
End Sub
60、如何利用API實作代碼延時執行
聲明:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
調用:
Sleep 3000 '延時3秒執行
VB問題全功略（13） [查找本頁請按Ctrl+F]
［上一頁］（13）［下一頁］
61、若畫面上 ListBox 中可顯示的項目數量為 5 條，而 ListBox 中的資料總數已超過 5 條，如何讓新加入 ListBox 的項目能夠馬上顯示在 ListBox 的最後一條〈畫面上顯示最後 5 條，含新加入之資料〉？
62、如何事先標明 ListBox 或 ComboBox 的某一個 Item？
63、模拟 IE 的 位址欄：智慧型下拉式 Combo
64、如何讓 ListBox 同一列顯示二欄以上的欄位？
65、如何控制二欄以上 ListBox 之各欄位寬度？
61、若畫面上 ListBox 中可顯示的項目數量為 5 條，而 ListBox 中的資料總數已超過 5 條，如何讓新加入 ListBox 的項目能夠馬上顯示在 ListBox 的最後一條〈畫面上顯示最後 5 條，含新加入之資料〉？
使用 TopIndex 配合 ListCount 屬性即可，而且不會更改原來的選取狀态。
List1.AddItem "xxx" 'xxx 指新加入之資料
List1.TopIndex = List1.ListCount - n 'n=5 就是畫面上 ListBox 可看到的條數
62、如何事先標明 ListBox 或 ComboBox 的某一個 Item？
有二個方法：
方法1: 使用 For Loop 一一比對，再設定 ListIndex 即可，隻是項目多時比方法2慢。例如：
Dim i As Integer
For i = 0 To List1.ListCount - 1
If List1.List(i) = "搜尋的字串" Then
List1.ListIndex = i
Exit For
End If
Next
方法2: '16位版本：
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Const WM_USER = &H400
Const LB_SELECTSTRING = (WM_USER + 13)
Const CB_SELECTSTRING = (WM_USER + 13)
'32 位版本： ( Integer 改成 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
Const WM_USER = &H400
Const LB_SELECTSTRING = &H18C
Const CB_SELECTSTRING = &H14D
Sub SelectListItem(lst As Control, Idx As String)
Dim i As Long
If TypeOf lst Is ComboBox Then
i = SendMessage(lst.hwnd, CB_SELECTSTRING, -1, ByVal Idx)
Else
i = SendMessage(lst.hwnd, LB_SELECTSTRING, -1, ByVal Idx)
End If
End Sub
在必要的時候，例如 Form_Load，隻要 call SelectListItem(ControlName, StringToFind) 即可，不管是 ListBox 或 Combobox，本範例都适用。
63、模拟 IE 的 位址欄：智慧型下拉式 Combo
不知您是否有注意到？您在 IE 的位址欄直接輸入位址的時候，如果您輸入的位址前面幾位和下拉式 Combo 中現存的位址相同時，IE 便會自動帶出該位址資料放在 Combo 的 Text 框中，而且這串字有一個特性，在滑鼠遊标之前的字是未標明反白的，而在滑鼠遊标之後的字則是已經標明反白的，它的目的有二個：
1. 如果您要輸入的整串字和它帶出的字完全一樣，就可以不用再輸入，可以節省時間。
2. 如果您要輸入的整串字和它帶出的字不一樣，您還是可以繼續輸入，繼續輸入的字串會自動取代後面那串已經標明反白的字串。
以下的範例，隻處理英文字，若要處理其他情形如數字，請自行略加更改，請先在 Form1 中放一個 Combo，然後将以下程式直接 Copy 進去即可：
Dim strCombo As String
Const WM_SETREDRAW = &HB
Const KEY_A = 65
Const KEY_Z = 90
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 Sub combo1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim x%
Dim strTemp$
Dim nRet&
If KeyCode >= KEY_A And KeyCode <= KEY_Z Then
'only look at letters A-Z
strTemp = Combo1.Text
If Len(strTemp) = 1 Then strCombo = strTemp
nRet& = SendMessage(Combo1.hwnd, WM_SETREDRAW, False, 0&)
For x = 0 To (Combo1.ListCount - 1)
If UCase((strTemp & Mid$(Combo1.List(x), Len(strTemp) + 1))) = UCase(Combo1.List(x)) Then
Combo1.ListIndex = x
Combo1.Text = Combo1.List(x)
Combo1.SelStart = Len(strTemp)
Combo1.SelLength = Len(Combo1.Text) - (Len(strTemp))
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Exit For
Else
If InStr(UCase(strTemp), UCase(strCombo)) Then
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Combo1.Text = strCombo
Combo1.SelStart = Len(Combo1.Text)
Else
strCombo = strTemp
End If
End If
Next
nRet& = SendMessage(Combo1.hwnd, WM_SETREDRAW, True, 0&)
End If
End Sub
Private Sub Form_Load()
Combo1.AddItem "AAAAAAAA"
Combo1.AddItem "ABBBBBBB"
Combo1.AddItem "ABCCCCCC"
Combo1.AddItem "ABCDDDDD"
Combo1.AddItem "ABCDEEEE"
Combo1.AddItem "ABCDEFFF"
Combo1.AddItem "ABCDEFGG"
Combo1.AddItem "ABCDEFGH"
End Sub
64、如何讓 ListBox 同一列顯示二欄以上的欄位？
要讓 ListBox 顯示二欄以上，有很多方法：
有人用二個字串中間加上空白來 AddItem，但是這樣有一個很大的缺點，就是第二欄常常無法對齊！有人說可以加上 Format 來強迫留白，以便對齊，但是這些方法都比較麻煩，沒有效率！
有一個很簡單，又保證不用傷腦筋就可以對 的方法，就是使用 vbTab！作法如下：
lstMyListBox.AddItem "0001" & vbTab & "王一" & vbTab & "廣州市"
lstMyListBox.AddItem "0002" & vbTab & "丁二" & vbTab & "上海市"
lstMyListBox.AddItem "0003" & vbTab & "張三" & vbTab & "北京市"
lstMyListBox.AddItem "0004" & vbTab & "李四" & vbTab & "重慶市"
65、如何控制二欄以上 ListBox 之各欄位寬度？
使用 vbTab 來設定 ListBox 的多欄顯示，效果不錯，但是若以 vbTab 來做，每欄長度是固定的，隻有 8，我的資料有些字串很長，有些很短，如果可以逐欄設定寬度，那就太完美了！但是單用 VB 的基本函數，是做不到的！不過我們可以 Call API：
假設要放到 ListBox 的資料有四個欄位，如下：
1、員工編号 (長度為6)
2、員工姓名 (長度為6)
3、員工住址 (長度為38)
4、員工性别 [長為4]
Const LB_SETTABSTOPS = &H192
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
Sub SetListTabStops(iListHandle As Long)
' 設定四個欄位, 長度各為 6,6,38,4
' iListHandle = the window handle of the list box
Dim iNumColumns As Long
Dim iListTabs(3) As Long
Dim Ret As Long
iNumColumns = 4
iListTabs(0) = 24 ' 24/4 = 6 (第1-第6位元組)
iListTabs(1) = 48 ' 48/4 = 12 (第7-第12位元組)
iListTabs(2) = 200 ' 200/4 = 50 (第13-第50位元組)
iListTabs(3) = 216 ' 216/4 = 54 (第51-第54位元組)
Ret = SendMessage(iListHandle, LB_SETTABSTOPS, _
iNumColumns, iListTabs(0))
End Sub
Private Sub Form_Load()
Call SetListTabStops(List1.hwnd)
List1.AddItem "0001" & vbTab & "王一" & vbTab & "廣州市市體育東路二段120巷176号" & vbTab & "男"
List1.AddItem "0002" & vbTab & "丁二" & vbTab & "北京市中關村路100号" & vbTab & "男"
List1.AddItem "0003" & vbTab & "張三" & vbTab & "上海市中山路150巷26号" & vbTab & "女"
List1.AddItem "0004" & vbTab & "李四" & vbTab & "重慶市福州路99号" & vbTab & "男"
66、ListBox 選項資料太長，如何設定 ListBox 的水準卷動軸？
VB 的 ListBox 并沒有水準卷動軸的功能，如果遇到某一個資料項很長時， 使用者就無法看到這一個資料項的所有内容，要如何設定水準卷動軸給 ListBox?
可利用 SendMessage 傳送 LB_SETHORIZONTALEXTENT 訊息給 ListBox，此一訊息的作用就是要求ListBox 設定水準卷動軸， 細節如下：
1. API 的聲明：
'16位
Const WM_USER = &H400
Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)
Private Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
'32位
Const LB_SETHORIZONTALEXTENT = &H194
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
2. 程式範例：
' List1 為 ListBox 的名稱
Call SendMessage(List1.hwnd, LB_SETHORIZONTALEXTENT, 水準卷動軸的寬度, ByVal 0&)
特别注意：
以上的水準卷動軸寬度的機關是 pixel(像素)，或許您會認為這個寬度就是 ListBox 的寬度，但是結果卻不是這樣的，它真正指的是這個卷動軸要卷動的文字的寬度，是以您要預留可能放到 ListBox 内的資料最長的長度，若留得太短，可能出現以下二種情形：
1、 水準卷動軸的寬度設的比 ListBox 本身的寬度還短，VB會認為不需要卷動軸，而不産生卷動軸！
2、 水準卷動軸的寬度設的比 ListBox 内的資料寬度還短，則隻能卷動一半，還是看不到完整内容！
67、ListBox 選項資料太長，如何使用 ToolTip 來顯示内容？
ListBox 選項資料太長，雖然可以加上水準卷動軸，但卷來卷去還是有點麻煩，如果可以出現 Popup ToolTip 就更正點了！當然，您若想要二種功能一起使用，也是可以的。
關于這個主題，我看過很多範例都是使用 API 來做，但是以下這個方法既簡單，又不必使用任何 API，帥吧！
Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim YPos As Integer, iOldFontSize As Integer
iOldFontSize = Me.Font.Size
Me.Font.Size = List1.Font.Size
YPos = Y / Me.TextHeight("Xyz") + List1.TopIndex
Me.Font.Size = iOldFontSize
If YPos < List1.ListCount Then
List1.ToolTipText = List1.List(YPos)
Else
List1.ToolTipText = ""
End If
End Sub
68、如何加長 ComboBox 的下拉選單？
Combo 預設的下拉長度隻有 5,6 個選項，當選項很多時，要卷老半天才能找到資料，很不友善！要加長 ComboBox 的下拉選單，方法如下：
在聲明區中放入以下聲明及 Subroutine
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
Public Sub SetComboHeight(oComboBox As ComboBox, lNewHeight As Long)
Dim oldscalemode As Integer
' This procedure does not work with frames: you
' cannot set the ScaleMode to vbPixels, because
' the frame does not have a ScaleMode Property.
' To get round this, you could set the parent control
' to be the form while you run this procedure.
If TypeOf oComboBox.Parent Is Frame Then Exit Sub
' Change the ScaleMode on the parent to Pixels.
oldscalemode = oComboBox.Parent.ScaleMode
oComboBox.Parent.ScaleMode = vbPixels
' Resize the combo box window.
MoveWindow oComboBox.hwnd, oComboBox.Left, oComboBox.Top, oComboBox.Width, lNewHeight, 1
' Replace the old ScaleMode
oComboBox.Parent.ScaleMode = oldscalemode
End Sub
在任何時候 (不一定是 Form_Load 或 Combo_DropDown)，想要加長 ComboBox 的下拉選單時，隻要加入以下程式即可：
Call SetComboHeight(Combo1, 270) '設定的機關是 Pixels
69、如何加寬 ComboBox 的下拉選單？
和 ListBox 一樣， ComboBox 也會有寬度不夠的情形， Combo 下拉之後資料看不完整，當 Form 上的物件不多時，還可以拉長一點，但有時候也沒辦法！這時候，還是得靠 API 了！
在聲明區中放入以下聲明及 Subroutine
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
Const CB_SETDROPPEDWIDTH = &H160
Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)
' lWidth 是寬度，機關是 pixels
SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Sub
在任何時候 (不一定是 Form_Load 或 Combo_DropDown)，想要加寬 ComboBox 的下拉選單時，隻要加入以下程式即可 (若設定的寬度小于 Combo 原來的寬度則無效)：
Call SetComboWidth(Combo1, 270) '設定的機關是 Pixels
70、如何用程式控制滑鼠遊标 (Mouse Cursor) 到指定位置？
以下這個例子，當 User 在 Text1 中按下 'Enter' 鍵後，滑鼠遊标會自動移到 Command2 按鈕上方
請在聲明區中加入以下聲明：
'16 位版本： ( Sub 無傳回值 )
Declare Sub SetCursorPos Lib "User" (ByVal X As Integer, ByVal Y As Integer)
'32 位版本： ( Function 有傳回值，Integer 改成 Long )
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
'在 Form1 中加入以下程式碼：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
x% = (Form1.Left + Command2.Left + Command2.Width / 2 + 60) / Screen.TwipsPerPixelX
y% = (Form1.Top + Command2.Top + Command2.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos x%, y%
End If
End Sub
71、如何用滑鼠移動沒有标題的 Form，或移動 Form 中的控制項？
在聲明區中放入以下聲明：
'16 位版本： ( Sub 無傳回值 )
Private Declare Sub ReleaseCapture Lib "User" ()
Private Declare Sub SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Long)
'32 位版本： ( Function 有傳回值，Integer 改成 Long )
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 Any) As Long
'共用常數：
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012
'若要移動 Form，程式碼如下：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub
'以上功能也适用于用滑鼠在 Form 中移動控制項，程式碼如下：
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Command1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub
72、如何判斷目前電腦中所有磁盤之型态？
在 Form 中放置一個 ListBox 名稱為 List1
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Sub Form_Load()
Dim i As Integer
Dim ret As Long '傳回值
Dim wtype As String '磁盤型态
For i = 65 To 90 'ASC(A) ~ ASC(Z)
wtype = ""
ret = GetDriveType(Chr$(i) & ":/") '傳入磁盤代号
Select Case ret
Case 2
wtype = "軟碟"
Case 3
wtype = "硬碟"
Case 4
wtype = "網路磁盤"
Case 5
wtype = "CD光牒"
End Select
If wtype <> "" Then List1.AddItem Chr$(i) & ":/" & vbTab & wtype
Next
End Sub
若是 16 位程式，聲明略有不同，如下：
Private Declare Function GetDriveType Lib "Kernel" (ByVal nDrive As Integer) As Integer
傳入的參數型态是 Integer，0 代表 A 磁盤，依次加 1，2 代表 C 磁盤。
73、檢查檔案是否存在？
Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then FileExists = False Else FileExists = True
End Function
傳入之參數是含完整路徑之檔案名稱，若檔案存在，則傳回 -1，否則傳回 0。
74、如何用 Image 來做成帶有圖檔的按鈕，按下滑鼠時如同按鈕般會變換圖檔？
在 Form 中放三個 Image Control，名稱分别為 Image1、LockOpen、LockClosed，并設定好 LockOpen 及 LockClosed 的 Picture 屬性為開啟及關閉的 Icon，然後
Sub Form_Load()
Image1.Picture = LockOpen.Picture
End Sub
Sub Image1_Click()
Static LockedFlag As Integer
If LockedFlag Then
Image1.Picture = LockOpen.Picture
Else
Image1.Picture = LockClosed.Picture
End If
LockedFlag = Not LockedFlag
End Sub
以上之程式代碼雖然在 VB 的各個版本都适用，但 VB 6.0 的 CommandButton 已經可以放置圖檔了，是以 VB 6.0 可以直接使用 CommandButton 達到以上功能！
75、聽說 VB 6.0 的 CommandButton 己經可放圖檔，要如何使用？
先将 Style 屬性設成 「1 - 圖檔外觀」，再設定 Picture 屬性即可。
若希望 Mouse_Down 時可改變圖檔，則需要再設定 DownPicture 屬性。
若希望按鈕 Disable 時可改變圖檔，則需要再設定 DisabledPicture 屬性。
76、同一個 Form 中若要将 OptionButton 分組，該如何做？
在同一個 Container 中，隻能放置一組 OptionButton，是以若要在一個 Form 中放置一組以上之 OptionButton 時，必須以不同之 Container 區隔。
而在 VB 中可當作 Container 的物件有 Form / PictureBox / Frame ...等。
77、VB 32-bits 之後的版本，無論用 Len 或是 LenB 都無法正确的計算中英文混合字串的長度，有沒有解決的辦法？
這是由于 VB 32-bits 都是采 Unicode，Unicode 的儲存方式無論中英文字，均是以 2bytes 來儲存，有兩個方式可以解決：
解法1: '假設欲計算字串 str1 的長度
Dim str1 As String
Dim i As Long
Dim c As Long
Dim n As Long
For i = 1 To Len(str1)
c = Asc(Mid(Str, i, 1))
If c >= 0 And c < 128 Then
n = n + 1 '計算英文
Else
n = n + 2 '計算中文
End If
Next i
解法2: Lenb(Strconv("abcd中英文混合字efg", vbFromUnicode))
78、Visual Basic 程式開發完成後，可否把執行時相關的文檔一并銷售？
在下列條件下可以不須支付權利金便可以重制并散布 Run-time Modules (限于可執行文檔、安裝文檔、ISAM 和Rebuild文檔)：
1.将 Run-time Modules 配合作為您的軟體的一部份一同散布。
2.不使用微軟的名稱，标章或商标來行銷您的軟體。
3.附加一個您軟體的有效著作權通知。
4.同意對微軟或其供應商因為您軟體的散布和使用所導緻的請求、訴訟，包括律師費、賠償、為微軟或其供應商辯護使其不受損害。
79、我想知道某一部電腦出現在 "網路上的芳鄰" 時的名稱，也就是"電腦名稱"，該如何做？
其實出現在 "網路上的芳鄰" 中的名稱, 就是我們在 "控制台" --> "網路" --> "個人資料" --> "電腦名稱" , 要抓這個名稱, 有好幾個方法, 但有的比較複雜, 例如, 直接從系統資料庫抓, 以下的方法則比較簡單. ( VB4-32 以上)
請在聲明區中放入以下聲明 :
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function ComputerName() As String
Dim cn As String
Dim ls As Long
Dim res As Long
cn = String(1024, 0)
ls = 1024
res = GetComputerName(cn, ls)
If res <> 0 Then
ComputerName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
ComputerName = ""
End If
End Function
程式中要使用時隻要直接 call 即可.
例 : Msgbox "ComputerName=" & ComputerName
80、我想知道某一部電腦目前的 Login User 是誰，該如何做？
請在聲明區中放入以下聲明 :
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function UserName() As String
Dim cn As String
Dim ls As Long
Dim res As Long
cn = String(1024, 0)
ls = 1024
res = GetUserName(cn, ls)
If res <> 0 Then
UserName = Mid(cn, 1, InStr(cn, Chr(0)) - 1)
Else
UserName = ""
End If
End Function
程式中要使用時隻要直接 call 即可.
例 : Msgbox "UserName=" & UserName
81、我已經知道 "電腦名稱" 及 "LoginUser" 的抓法了, 我可以将電腦名稱改成 LoginUser 嗎？
可以的, 請在聲明區中放入以下聲明:
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
程式中要使用時隻要直接 call 即可. 例如: 要将電腦名稱改成員工編号 "RT000588"
Private Sub Command1_Click()
Dim res As Long
res = SetComputerName("RT000588")
If res <> 0 Then
MsgBox "成功!!!"
Else
MsgBox "有問題!!!"
End If
End Sub
雖然已經更改成功，但并不會馬上有作用，是以在網路上的芳鄰中，還會是舊的電腦名稱，一直要等到重新開機之後才有作用。
82、反向思考---怎樣讓程式跑慢一點？
大部份時間，我們都希望我們自己開發的程式跑得越快越好，但是有些狀況，我們卻希望它能夠稍微停一下，等待某一個傳回值或某一個動作做完了，才繼續執行下一個指令，可是偏偏 VB 沒有提供這樣的指令，我要怎樣延遲一個VB程式呢
在聲明區中加入以下聲明:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
在事件中隻要 call 它即可
Call Sleep(1000) '1000代表延遲1秒
不過很抱歉，它隻在 32位元中才有提供, 是以要在 VB4-32 位元以上才可使用 !!!
83、《打磚塊》一顆在畫面上跳動碰撞的小球
這個範例加以引申，就可以做出像一樣的遊戲！
'在 Form 中放一個 Shape，Shape 屬性設成 3-圓形，長寬設成 60
'在 Form 中放一個 Timer，Interval 屬性設成 48
'聲明二個 Form Level 或 Global 變數 (此範例聲明在 Form 中)
Dim horizan As Integer
Dim vertical As Integer
'在 Form_Load 設定每次水準或垂直移動的距離
Private Sub Form_Load()
horizan = 50 '水準移動的距離
vertical = 50 '垂直移動的距離
End Sub
'移動小球并檢查是否超出四個邊界 ? 若超過則改變方向.
'注意: Me.Width 包含 Form 左右二邊 Border 的寬度
' Me.Height 包含 Form 上方 TitleBar 的高度及下方 Border 的高度
Private Sub Timer1_Timer()
ball.Move ball.Left + horizan, ball.Top + vertical
If ball.Top <= 0 Then vertical = -vertical
If ball.Top + ball.Height >= Me.Height - 420 Then vertical = -vertical
'扣除 420 是指 Form 上方 TitleBar 的高度 + 下方 Border 的高度
If ball.Left <= 0 Then horizan = -horizan
If ball.Left + ball.Width >= Me.Width - 100 Then horizan = -horizan
'扣除 120 是指 Form 左右二邊 Border 的寬度
End Sub
如果是固定的 Form，以上的程式代碼就已經完成了，但是如果 Form 的大小是可以調整的話，當您調整 Form 的大小後，小球的位置可能有一段時間會跑到熒幕外，要預防這種情形，必須再加上以下的程式代碼：
Private Sub Form_Resize()
If ball.Top <= 0 Then
ball.Top = -25
vertical = -vertical
End If
If ball.Top >= (Me.Height - 420) Then
ball.Top = (Me.Height - 445) - ball.Height
vertical = -vertical
End If
If ball.Left <= 0 Then
ball.Left = -25
horizan = -horizan
End If
If ball.Left >= (Me.Width - 100) Then
ball.Left = (Me.Width - 125) - ball.Width
horizan = -horizan
End If
End Sub
運用時要做調整，主要就是調整以下二個因素：
1、每次水準或垂直移動的距離，就是 horizan / vertical
2、Timer 的間距，就是 Timer 的 Interval
注：其實要完整一點的話，還需要用 API 去抓出 Form 上方 TitleBar 的高度四方 Border 的寬度。
84、為什麼有的程式的畫面或控制項總是閃個不停，如何避免？
原因很多，但最主要的原因是 '不停地改變一些可能不需要改變的控制項屬性'，這些屬性通常是一些會造成控制項 Repaint 的屬性，例如：Enabled, Visible, Contents 及 Text。如果某一個物件的屬性已經是您要設定的值，那就不要再設定一次，如此便會大大降低控制項閃動的頻率。例如：
If Not Command1.Enabled
Then Command1.Enabled=True
End If
以下是一個完成的 Module：
Sub SetEnabled (ctrlIn as Control, bSetting as Integer)
If ctrlIn.Enabled <> bSetting Then
ctrlIn.Enabled=bSetting
End If
End Sub
85、計算二個時間的時間差
VB 有提供一些好用的日期時間計算函數，但是沒有一個計算時間差的功能，有些人會說有的，是 DateDiff，但是，DateDiff 功能卻不夠，您可以算出二個時間所差的總日數、總時數或總秒數，但您算不出是相差幾天幾小時幾分鐘又幾秒鐘！
以下這個模組的功能就是計算二個時間之時間差：
Function Convtime(date1 As Date, date2 As Date) As String
'
'功能 : 計算二個時間的時間差
'
'參數 : date1 是較早的時間, Variant (Date)。
' date2 是較晚的時間, Variant (Date)。
'
'若要計算兩個日期之時間差，計算順序是從 date1 到 date2
'
'傳回值 : 時間差的組合字串, 例如 2年21天13小時5分鐘3秒
'
Dim wsecond As Long '總秒數 / 剩餘秒數
Dim wminute As Long '總分鐘數 / 剩餘分鐘數
Dim whour As Long '總時數 / 剩餘時數
Dim wday As Long '總天數 / 剩餘天數
Dim wyear As Long '總年數
wsecond = DateDiff("s", date1, date2) '總秒數
If wsecond > 60 Then
wminute = wsecond / 60 '總分鐘數
wsecond = wsecond Mod 60 '計算剩餘秒數
End If
If wminute > 60 Then
whour = wminute / 60 '總時數
wminute = wminute Mod 60 '計算剩餘分鐘數
End If
If whour > 24 Then
wday = whour / 24 '總天數
whour = whour Mod 24 '計算剩餘時數
End If
If wday > 365 Then
wyear = wday / 365 '總年數
wday = wday Mod 365 '計算剩餘天數
End If
'拼湊計算結果字串
If wyear > 0 Then Convtime = Convtime & wyear & "年"
If wday > 0 Then Convtime = Convtime & wday & "天"
If whour > 0 Then Convtime = Convtime & whour & "小時"
If wminute > 0 Then Convtime = Convtime & wminute & "分鐘"
If wsecond > 0 Then Convtime = Convtime & wsecond & "秒"
End Function
當然，或許您要的結果不是我算出的字串，可能要算幾周！但是隻要将以上的程式稍作修改，就可以得到您要的結果！
86、處理加了密碼的 Access 資料庫
當 Access 資料庫加了密碼，直接由 Access 開啟資料庫時，會出現密碼問話框，詢問密碼。但是若要由 VB 程式中開啟，必須更改 VB 程式中開啟資料庫的指令，否則會出現錯誤訊息！以下針對各種狀況，分别加以說明：
1、 使用 DAO 文法開啟資料庫：OpenDatabase
若要由程式中開啟，文法如下：
Set DB = OpenDatabase(DatabaseName, False, False, ";Pwd=密碼")
執行個體例如：
Dim db As Database
Set db = OpenDatabase("C:/db1.mdb", False, False, ";Pwd=1")
若要使用 Data 控制項，設定方法如下：
1、設定 DatabaseName 屬性 (資料庫名稱 / 含路徑)
2、設定 Connect 屬性，将預設的字串 "Access" 改成 ";Pwd=密碼" (不含雙引号)
3、設定 RecordSource 屬性 (資料集)
2、
使用 ADO 文法開啟資料庫：
在使用 ADODC 或 DataEnvironment 設定好連線之後，直接利用屬性視窗修改 ConnectionString 屬性(附屬于 ADODC) 或 ConnectionSource 屬性(附屬于 DataEnvironment 的 Connection 物件)，修改的方法是在屬性之後增加以下參數：
;Jet OLEDB:Database Password=密碼
除了 ADODC 及 DataEnvironment 之外， 直接使用 ADO 物件來開啟含有密碼的 mdb 資料庫，設定參數的方法也是相同的。
3、
壓縮加了密碼的資料庫：CompactDatabase
DBEngine.CompactDataBase "原資料庫檔名", "新資料庫檔名", , , ";pwd=密碼"
執行個體例如：
DBEngine.CompactDatabase "C:/Db1.mdb", "C:/Db2.mdb", , , ";pwd=1"
4、
修複加了密碼的資料庫： RepairDatabase
不必理會資料庫設定的密碼！
DBEngine.RepairDataBase "資料庫檔名"
執行個體例如：
DBEngine.RepairDataBase "C:/Db1.mdb"
87、如何取消 TextBox 滑鼠右鍵的 PopupMenu 功能
自從 Microsoft Windows 進入 Windows95 之後，有一個很友善的功能，很多軟體都有提供，就是滑鼠右鍵的 PopupMenu 功能，它确實很友善，但是有時卻是夢魇，那就是您不需要它的時候，它還是會自動出現！本例中的 TextBox 就是明顯的例子。
但是這個夢魇從 VB5.0 以後就可以解決了，因為 VB5.0 提供了 AdressOf 這個運算子，可以做回呼(callback)處理！
請将以下的程式碼放在 .bas 模組中，呼叫 Hook 這個 Sub 并傳入 TextBox 的 hWnd 當作參數，但是切記您在 Unload Form 之前一定要呼叫 UnHook 這個 Sub，否則會産生一個 General Protection Fault！
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
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 Const WM_RBUTTONUP = &H205
Public lpPrevWndProc As Long
Private lngHWnd As Long
Public Sub Hook(hWnd As Long)
lngHWnd = hWnd
lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHook()
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_RBUTTONUP
'Do nothing
'Or popup you own menuCase Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Select
End Function
在 Form_Load 事件中加入以下程式碼：
Call Hook(Text1.hWnd)
在 Form_Unload 中加入以下程式碼：
Call UnHook
88、如何在 Menu 中加入美美的圖案？
在模組中加入以下程式碼：
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 SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Public Const MF_BITMAP = &H4&
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 String
cch As Long
End Type
Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, _
ByVal b As Boolean, lpMenuItemInfo As MENUITEMINFO) As Boolean
Public Const MIIM_ID = &H2
Public Const MIIM_TYPE = &H10
Public Const MFT_STRING = &H0&
在 Form 中加入一個 PictureBox，屬性設定為：
AutoSize = True
Picture = .bmp (尺寸大小為 13x13，不可設定為 .ico)
在 Form_Load 中的程式碼如下：
Private Sub Form_Load()
'取得程式中 Mennu 的 handle
hMenu& = GetMenu(Form1.hWnd)
'取得第一個 submenu 的 handle
hSubMenu& = GetSubMenu(hMenu&, 0)
'取得 Submenu 第一個選項的 menuId
hID& = GetMenuItemID(hSubMenu&, 0)
'加入圖檔
SetMenuItemBitmaps hMenu&, hID&, MF_BITMAP, Picture1.Picture, Picture1.Picture
'在一個 Menu 選項中您一共可以加入二張圖檔
'一張是 checked 狀态用，一張是 unchecked 狀态用
End Sub
89、如何把小圖檔填滿 Form 成為背景圖？
對于這個問題，我看過很多方法，有的方法很麻煩，要聲明一大堆 Type，用一大堆的 API，但是有一個最笨但我認為最好的方法如下： (就好像拼磁磚一樣，不用任何 API, 不必聲明任何 Type)
在 Form 中放一個 PictureBox，Picture 屬性設定為某一張小圖，AutoSize 屬性性設定 True，完成的模組如下：
Sub PictureTile(Frm As Form, Pic As PictureBox)
Dim i As Integer
Dim t As Integer
Frm.AutoRedraw = True
Pic.BorderStyle = 0
For t = 0 To Frm.Height Step Pic.ScaleHeight
For i = 0 To Frm.Width Step Pic.ScaleWidth
Frm.PaintPicture Pic.Picture, i, t
Next i
Next t
End Sub
PictureTile 這個模組共有二個參數，第一個是表單名稱，第二個則是 PictureBox 的名稱。以下為一應用執行個體：
Private Sub Form_Load()
PictureTile Me, Picture1
End Sub
90、如何把小圖檔填滿 MDIForm 成為背景圖？
以下這個範例， 要：
1、一個 MDIForm：不必設定任何屬性。
2、一個 Form1：不一定是 MDIChild，最好 MDIChild 為 False，但是 AutoRedraw 設成 True。
3、Form1 上面放一個隐藏的 PictureBox：名稱為 Picture1，不必設定 Picture 屬性。
4、一張圖檔的完整路徑。
'将以下模組放入 MDIForm 的聲明區中：
Sub TileMDIBkgd(MDIForm As Form, bkgdtiler As Form, bkgdfile As String)
If bkgdfile = "" Then Exit Sub
Dim ScWidth%, ScHeight%
ScWidth% = Screen.Width / Screen.TwipsPerPixelX
ScHeight% = Screen.Height / Screen.TwipsPerPixelY
Load bkgdtiler
bkgdtiler.Height = Screen.Height
bkgdtiler.Width = Screen.Width
bkgdtiler.ScaleMode = 3
bkgdtiler!Picture1.Top = 0
bkgdtiler!Picture1.Left = 0
bkgdtiler!Picture1.Picture = LoadPicture(bkgdfile)
bkgdtiler!Picture1.ScaleMode = 3
For n% = 0 To ScHeight% Step bkgdtiler!Picture1.ScaleHeight
For o% = 0 To ScWidth% Step bkgdtiler!Picture1.ScaleWidth
bkgdtiler.PaintPicture bkgdtiler!Picture1.Picture, o%, n%
Next o%
Next n%
MDIForm.Picture = bkgdtiler.Image
Unload bkgdtiler
End Sub
以下為一應用執行個體：
Private Sub MDIForm_Load()
TileMDIBkgd Me, Form1, "c:/windows/Tiles.bmp"
End Sub
91、如何讓一個 app 永遠保持在最上層 ( Normal on Top )
請在 Form 中放一個 Timer，Interval = 1000 (或更小)，在 Timer 事件中加入以下程式碼：
Private Sub Timer1_Timer()
Me.ZOrder
End Sub
不過這樣子的 Form，隻不過是一個 Normal Window。要産生真正 Topmost Window，就要使用 API 了！
92、關閉指定的程式
要做到像 Task Manager 一樣，可以關閉指定的程式，方法如下：
在聲明區中放入以下聲明：(16位 改成 win31 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
以下之範例示範如何關閉一個視窗标題 (Caption) 為 【小算盤】的程式：
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "小算盤")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "Error posting message."
End If
Else
MsgBox "并未開啟小算盤程式."
End If
93、開啟及關閉CD－Rom的門
在聲明區中加入以下聲明：
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
開啟的程式代碼如下：
retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
關閉的程式代碼如下：
retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0)
94、如何知道您的機器中預設印表機的機型、驅動程式及連接配接埠
想要抓取您機器中軟硬體的資料，其實最友善的，就是直接從系統資料庫中抓取，但是有些人對系統資料庫有畏懼感！覺得系統資料庫好像高深的樣子。
其實雖然從 Windows95 以後 Microsoft 已經将 Win.ini 及 System.ini 的資料寫到系統資料庫中，但是由于 INI 檔之使用已根深蒂固，是以 Microsoft 也不敢冒然廢除 INI 檔的使用，直到 Windows98 為止，一直都是二者并用，也就是有些資料，在寫到注冊的同時，也寫了一份到 INI 檔中！
目前讨論的主題就是一個例子，這三種資料都可從 Win.ini 中直接讀取，結構如下：
[windows]
device=HP LASERJET 6P (TRADITIONAL),HPCXLAB,//SUN/LJIIP2
device=印表機的機型, 驅動程式, 連接配接埠 (三種資料中間以逗點分開)
在聲明區中加入以下聲明： (16位 改成 win31 API)
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
程式代碼如下：
AppName$ = "windows" 'Section 名稱
KeyName$ = "device" 'Key 值名稱
nSize% = 81 '預設傳回值長度
RetStr$ = Space$(nSize%) '設定空白給預設傳回值
NumChars% = GetProfileString(AppName$, KeyName$, NullStr$, RetStr$, nSize%)
' NumChars% 是實際傳回值長度
koRetStr$ = Left$(RetStr$, NumChars%) '實際傳回值
' Parse the string for specifics
'找尋第一個逗點的位置
CommaPos1% = InStr(1, RetStr$, ",")
'找尋第二個逗點的位置
CommaPos2% = InStr(CommaPos1% + 1, RetStr$, ",")
'印表機的機型
lblPrinter.Caption = Left$(RetStr$, CommaPos1% - 1)
'印表機的驅動程式
lblPrinterDriver.Caption = Mid$(RetStr$, CommaPos1% + 1, CommaPos2% - CommaPos1% - 1) & ".DRV"
'印表機的連接配接埠
lblPrinterPort.Caption = Mid$(RetStr$, CommaPos2% + 1)
95、如何判斷二個日期是否為同一月份？
碰到這個問題，很多人第一個念頭想到的就是『簡單！隻要使用 Month() 來判斷就可以了』，但是這個方法卻潛藏危機！為什麼呢？例如：
Month(Date1) = 2
Month(Date2) = 2
以上的二個日期并不一定是同月份，就像 1999/02/01 和 2000/02/01 一樣！
要怎樣做才會正确呢？
要使用 DateDiff ("m", Date1, Date2) = 0 表示同一月份(年度當然也相同)
程式如下：
If DateDiff ("m", Date1, Date2) then
MsgBox "不同月份"
Else
MsgBox "同月份"
End If
96、如何讓二個文字框同步關聯？
要作到這個動作，有的人會想要用 KeyDown 或 KeyPress 事件來處理，但是這都是錯的，雖然第二個文字框終究會動，但是總是比第一個文字框慢了一拍，永遠會漏掉最後一個字！為什麼呢？
因為由鍵盤輸入時，程式接收的順序為 KeyDown --> KeyPress --> KeyUp，而在 KeyPress 時，才會傳入 Keyascii〈此點可由各事件中傳入的參數得知〉轉換成文字，是以在 KeyDown 時，還抓不到輸入的字，在 KeyPress 時，隻有 Keyascii 則需要轉換才抓得到，但是中文比較麻煩！
在 KeyUp 時雖然已經可以抓到鍵入的值，但是我認為倒不如在 Change 事件中來得簡單！不管 User 輸入什麼，隻有第一個文字框資料異動時，才需要處理。
Private Sub Text1_Change()
Text2 = Text1
End Sub
如果不管第一個文字框輸入什麼，第二個文字框隻要顯示最後一個字，則程式要改成：
Private Sub Text1_Change()
Text2 = Right(Text1, 1)
End Sub
97、如何避免核取方塊式的 ListBox 已標明的項目被更改？
當 ListBox 的 Style 設定成〈1-項目包含核取方塊〉，ListBox 控制項以每一個文字項目跟随一個核取方塊的方式顯示。您可透過選取各項目邊的核取方塊以選擇 ListBox 中的多個項目。
但有時候，您這樣子設定的目的是為了顯示一些事先標明的項目，例如從資料庫中抓出的資料或是一些安裝軟體的設定選項确認畫面。您不希望因為使用者再去點選 ListBox 的項目而更動原來設定的項目，這時候，您不能将 Enabled 屬性設成 False，因為這樣子卷動杆就無法卷動，使用者就無法看到 ListBox 的其他項目；您也無法像 TextBox 一樣設定成 Lock 狀态，因為 ListBox 沒有 Lock 屬性。
以下的程式代碼可以解決這個問題，在 Form 中放一個 CommandButton 及一個 ListBox，将 ListBox 的 Style 設定成〈1-項目包含核取方塊〉：
Dim isDisabled As Boolean '是否取消可標明狀态
Private Sub Command1_Click()
isDisabled = Not isDisabled
End Sub
Private Sub List1_ItemCheck(Item As Integer)
If isDisabled Then
List1.Selected(Item) = Not List1.Selected(Item)
End If
End Sub
當 isDisabled 設定成 True 時，使用者一旦標明 ListBox 的某一個項目，程式會立即反轉它的狀态，看起來就像沒改變過標明狀态一樣！而同時 ListBox 還是可以卷動！
98、如何隐藏及再顯示滑鼠
很簡單，隻用到了一個 ShowCursor API，參數也很簡單，隻有一個 bShow，設定值如下：
True：顯示滑鼠 / False：隐藏滑鼠
Declare Function ShowCursor Lib "user32" Alias "ShowCursor" (ByVal bShow As Long) As Long
99、您是左撇子嗎？交換滑鼠的左右鍵！
很簡單，隻用到了一個 SwapMouseButton API，參數也很簡單，隻有一個 bSwap，設定值如下：
True：左右鍵互換 / False：恢複正常
Declare Function SwapMouseButton Lib "user32" Alias "SwapMouseButton" (ByVal bSwap As Long) As Long
假設我是左撇子，則程式為：
Dim RetVal As Long
RetVal = SwapMouseButton(True)
100、資料的加密 / 解密
以下二個模組，一個處理加密，一個處了解密，加密處理必須傳入參數 (就是要加密的字串)，加密後将資料存到加密檔案，要解密時，則從檔案案中讀出并解密：
(假設檔案案名稱為 C:/加密檔案.qwe, 您可以自行更改檔案名或路徑)
'處理加密
Private Function Encrypt(varPass As String)
If Dir("C:/加密檔案.qwe") <> "" Then: Kill "C:/加密檔案.qwe"
Dim varEncrypt As String * 50
Dim varTmp As Double
Open "C:/加密檔案.qwe" For Random As #1 Len = 50
For I = 1 To Len(varPass)
varTmp = Asc(Mid$(varPass, I, 1))
varEncrypt = Str$(((((varTmp * 1.5) / 2.1113) * 1.111119) * I))
Put #1, I, varEncrypt
Next I
Close #1
End Function
'處了解密
Private Function Decrypt() As String
Open "C:/加密檔案.qwe" For Random As #1 Len = 50
Dim varReturn As String * 50
Dim varConvert As Double
VB問題全功略（21） [查找本頁請按Ctrl+F]
［上一頁］（21）［下一頁］
101、如何讓 ComboBox 可以自動下拉？
102、如何從您的應程式中結束 Windows 重開機？
103、我要如何用 VB 來撥電話？ (不用 MSCOMM32.OCX )
104、如何用 VB 啟動其他程式或開啟各類檔案？
105、由程式中啟動螢幕保護程式！(一)
101、如何讓 ComboBox 可以自動下拉？
以下狀況假設我在 Form_Load 中自動下拉 Combo1.
'以下聲明用于16位
Const WM_USER = &H400
Const CB_SHOWDROPDOWN = (WM_USER + 15)
Private Declare Function SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
'以下聲明用于32位
Const CB_SHOWDROPDOWN = &H14F
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 Sub Form_Load()
Combo1.AddItem "11111"
Combo1.AddItem "22222"
Combo1.AddItem "33333"
Combo1.AddItem "44444"
Combo1.AddItem "55555"
Combo1.AddItem "66666"
'Form_Load 即自動下拉 Combo1
Dim nret As Long
nret = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
End Sub
102、如何從您的應程式中結束 Windows 重開機？
很多軟體在 Setup 完之後都會自動關機重開機，以便讓某些設定值可以生效，其實這個功能很簡單，隻要幾行指令就可以做到了！
關鍵就是要使用 ExitWindowsEx 這個 API，這個 API 隻有二個參數，第一個參數是一個 Flag，目的是要告訴 Windows 要以什麼方式關機，在下面的聲明中會列出可用的 Flag 常數值，至于第二個參數則是一個保留值，隻要設定成 0 就可以了。
很重要的一點是：如果您想要讓關機動作更順利，記得要 Unload 您的程式！
'在聲明區中 (Bas Module / Form Module) 加入以下聲明：
Public Const EWX_LOGOFF = 0 '這四個常數值可以并用
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Declare Function ExitWindowsEx Lib "user32" Alias "ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
'執行個體：如果您想強迫關機重開機，程式碼如下：
ret = ExitWindowsEx(EWX_FORCE OR EWX_REBOOT, 0)
103、我要如何用 VB 來撥電話？ (不用 MSCOMM32.OCX )
這個問題很多人問，也很多人回答，答案千篇一律，都說是使用 MSCOMM32.OCX，但是，您知道嗎？如果您隻是想撥号而已，根本就不用使用 MSCOMM32.OCX 這個控制項！
我忘了是從 Windows95 開始，或是 Windows3.1 就有了，Microsoft Windows 就提供了【電話撥号員】這個工具程式，在 Windows98 中的位置是 【開始】【程式集】【附屬應用程式】【通訊】【電話撥号員】，如果找不到的話，表示您在安裝 Windows95/98 時并未選擇安裝【電話撥号員】，您隻要再執行 Windows 安裝程式，選擇【通訊】【電話撥号員】即可！
沒錯！看完以上的說明，您應該知道我們就是要使用【電話撥号員】，請在聲明區中加入以下聲明及模組：
Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long
Public Sub PhoneCall(sNumber As String, sName As String)
Dim lRetVal As Long
lRetVal = tapiRequestMakeCall(Trim$(sNumber), App.Title, Trim$(sName), "")
If lRetVal <> 0 Then
MsgBox "不能撥号, 請采取其他行動"
End If
End Sub
'以上的 PhoneCall 是一個已經完成的模組，就是用來撥号的，它有二個參數：
'第一個參數是電話号碼，是指對方的電話号碼。
'第二個參數是對方的姓名或代号。
'以下是一個應用執行個體，要撥号給電話号碼為 "27058181" 的 "紀文和"：
Private Sub Command1_Click()
PhoneCall "27058181", "紀文和"
End Sub
104、如何用 VB 啟動其他程式或開啟各類檔案？
要在 VB 中啟動其他程式或開啟各類檔案，最簡單的方法就是使用 Shell 函數，例如：要開啟 C:/Test.txt 這個文字檔案，則要啟動記事本來開啟這個檔案案，程式如下：
Dim RetVal As Long
RetVal = Shell("C:/Windows/Notepad.exe C:/Test.txt", 3) '3代表視窗會最大化，并具有駐點，細節請查 Help
以上的文法雖然很簡單，但有一個風險，若是我們不知道開啟檔案的執行檔案位置，則程式便會有錯誤産生，尤其一般軟體在安裝的時候都可以讓使用者自行選擇安裝目錄，是以執行檔案的路徑不能寫死在程式中，要解決這個問題，就是在注冊檔案中找到該副檔案名之啟動程式位置，再放入 Shell 中。
但是以上的作法必須熟悉注冊檔案，而且必須使用 Windows API 來 Call (注冊檔案的存取以後會有專文來說明)，如果您對注冊檔案的存取及 API 的使用都很純熟的話，當然沒問題，但是有些人對于注冊檔案會有畏懼，這時候，您可以使用下面的方法：
Shell("Start C:/Test.txt")
您完全不用知道這份檔案的啟動程式是什麼？它放在什麼地方？參數 Start 便會自動依照附檔案名到注冊檔案中找到啟動程式來開啟該份檔案案！ 不賴吧！
注一：在 Windows 95/98/NT 平台中, 什麼副檔案名之檔案案, 該由什麼執行檔案來啟動, 都設在關聯中,
代碼為 HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Extensions
例如: 名稱為 ".DOC" 之資料為 "C:/Progra~1/Micros~2/Office/WINWORD.EXE ^.DOC"
名稱為 ".TXT" 之資料為 "notepad.exe ^.txt"
注二：使用 Start 之唯一缺點為 "會比直接指定執行檔案稍為慢 0.5-1 秒鐘."
注三：有一個例外就是螢幕保護程式，請看下面。
105、由程式中啟動螢幕保護程式！(一)
如果您曾在民營企業的資訊中心待過，不知您是否曾遇過一種情形，某一個高階主管 (或他的秘書) 要您幫他改一支報表，當他将有問題的報表交給您時，還千交待萬交待，不可以讓别人看到這份報表！這時您是不是覺得很好笑，其實在資訊中心，那裡還有什麼秘密可言？
話是如此說，但是如果您能夠将程式寫得讓他們覺得很安全，您也會獲得比較多的禮遇，而從程式中啟動螢幕保護程式就是技巧之一，為什麼呢？因為當他在作業中途要離開位置時，他可以不用結束作業中的程式，而直接啟動螢幕保護程式，而在螢幕保護程式中他可以設定密碼，這樣就不會不小心給人看到資料了！
要啟動螢幕保護程式可以直接使用 Shell 函數，但是上一個專題《問題 84》中我們讨論到的 Shell 二種作法對于螢幕保護程式卻有不同的意義，分别說明如下：
錯誤的作法 ==> x = Shell("c:/windows/Sheep.scr") '這種作法隻能開啟螢幕保護程式的設定畫面而已！
正确的作法 ==> Shell ("start c:/windows/sheep.scr") '這種作法才能正确啟動螢幕保護程式
106、如何讓您的電腦進入待命狀态 (Win98) 或啟動螢幕保護程式 (Win95)？
您的程式使用者會不會開啟程式後不結束應用程式，結果就離開座位，久久不回座位？使用以下的方法，您可以做到：
1、在 Windows98 中，您可以在程式中讓他的電腦進入待命狀态！ (螢幕黑黑一片)
2、在 Windows95 中，您可以啟動他電腦中預設的螢幕保護程式！
而要讓電腦進入待命狀态或啟動螢幕保護程式，隻要送一個訊息給桌面 (DeskTop Window) 就可以了！
'在聲明區中加入以下聲明：
Const WM_SYSCOMMAND = &H112&
Const SC_SCREENSAVE = &HF140&
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 Declare Function GetDesktopWindow Lib "user32" () As Long
Function gf_StartScreenSaver() As Boolean
Dim hWnd&
On Error Resume Next
hWnd& = GetDesktopWindow()
Call SendMessage(hWnd&, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
gf_StartScreenSaver = (Err.Number = 0)
End Function
'要使用時直接呼叫 gf_StartScreenSaver 即可！例如：
Private Sub Command1_Click()
gf_StartScreenSaver
End Sub
107、如何在程式中模拟按了 Windows95/98 螢幕左下方之【開始鍵】？
或許有人會問：這有什麼意義？當然有，随便舉個例子，有的程式在執行時會蓋住開始工作列，就算滑鼠移到螢幕下方，工作列也不會出現，目前這個方法就可以強迫工作列出現！當然也可以讓使用者選擇執行【開始工能表】中各群組之程式。
如果您看過了前一個問題 (86-如何讓您的電腦進入待命狀态 (Win98) 或啟動螢幕保護程式 (Win95)？)，您一定會發現這個問題的答案和上一個範例好像！沒錯！要讓程式模拟按了 Windows95/98 螢幕左下方之【開始鍵】，也隻要送一個訊息給桌面 (DeskTop Window) 就可以了！差别隻在傳入的參數不同而已：
'在聲明區中加入以下聲明：
Const WM_SYSCOMMAND = &H112&
Const SC_TASKLIST = &HF130 '-------->隻有這裡不同而已
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 Declare Function GetDesktopWindow Lib "user32" () As Long
Function gf_StartButton() As Boolean
Dim hWnd&
On Error Resume Next
hWnd& = GetDesktopWindow()
Call SendMessage(hWnd&, WM_SYSCOMMAND, SC_TASKLIST, 0&)
gf_StartButton = (Err.Number = 0)
End Function
'要使用時直接呼叫 gf_StartButton 即可！例如：
Private Sub Command1_Click()
gf_StartButton
End Sub
108、如何讓表單的标題列變成走馬燈？
說穿了，這個功能就是标準的做苦工的程式！不過效果還算不錯！
Dim C As String '存放現行視窗的标題列
Dim CO As Integer '存放标題的長度
Dim FS As Long '存放現行視窗的寬度
Private Sub Form_Load()
Timer1.Interval = 100
Me.Caption = "會移動的标題列"
C = Me.Caption
CO = Len(C) + 1
Me.Caption = ""
If Me.BorderStyle <> 2 Then
FS = Me.ScaleWidth + 250
Else
FS = Me.ScaleWidth + 500
End If
End Sub
Private Sub Form_Resize()
If Me.WindowState = 1 Then
FS = 3500
Else
FS = Me.ScaleWidth
End If
End Sub
Private Sub Timer1_Timer()
On Error GoTo ATH
Static C01 As Integer ' 第一個 Counter
Static CO2 As Integer ' 第二個 Counter
Static A As String ' to move caption
Dim R As String ' restore caption
Dim T As String ' restore caption
XX:
If CO > 0 Then
C01 = CO
T = Mid(C, C01, 1)
CO = CO - 1
R = " "
Mid(R, 1) = T
Me.Caption = R & Me.Caption
Else
A = A & " "
R = " "
Mid(R, 1) = A
Me.Caption = R & Me.Caption
End If
If CO2 >= FS Then
CO2 = 0
CO = Len(C)
Me.Caption = ""
GoTo XX
Else
CO2 = CO2 + 50
End If
Exit Sub
ATH:
End Sub
109、如何求出硬碟大小及剩餘空間大小
在我們安裝軟體的時候，在安裝選項的畫面，常常會出現如下的一些叙述：
選擇安裝項目大小..............................................10,000,000 Bytes
C 硬碟總空間大小..........................................1,847,328,768 Bytes
C 硬碟剩餘空間大小...........................................51,707,904 Bytes
後面的二項是我們硬碟的資訊，我們隻要使用一個 API，就可以同時抓到這二個資訊！
請在聲明區中放入以下聲明：
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
'第一個參數是硬碟代号，其他參數如範例中說明
'在程式中呼叫範例如下：
Private Sub Command1_Click()
Dim SectorsPerCluster As Long '參數二：每個 Cluster 的 Sector 數
Dim BytesPerSector As Long '參數三：每個 Sector 的 Byte 數
Dim NumberOfFreeClusters As Long '參數四：剩餘的 Cluster 數
Dim TotalNumberOfClusters As Long '參數五：Cluster 總數
Dim FreeBytes As Long '剩餘的 Byte 數
Dim TotalBytes As Long '總 Byte 數
Dim dummy As Long '傳回值
dummy = GetDiskFreeSpace("c:/", SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOfFreeClusters * SectorsPerCluster * BytesPerSector
TotalBytes = TotalNumberOfClusters * SectorsPerCluster * BytesPerSector
剩餘空間大小 = FreeBytes
硬碟大小 = TotalBytes
End Sub
注：在 VB6 以前的各版本 VB，隻能使用這種方法來做，但是到了 VB6 已經有了更簡單、不 要使用 API 的新作法，就是使用新物件 FileSystemObject，我們将在 《問題 99》再來探讨。
110、如何新增、移除【檔案功能表】的内容？
在 Windows95/98 環境中，當您開啟一份檔案後，Windows 便會将這份檔案記錄在最近開啟的檔案記錄中 (其實是将它放在 Windows/Recent 目錄下)。
下一次您要開啟同一份檔案時，有三種以上的方法：
1、選擇【開始】【檔案】，就可以看到【檔案功能表】的檔案清單，再選擇檔案名稱即可！
2、在檔案總管檔案所在目錄下，直接開啟該份檔案。
3、在檔案總管 Windows/Recent 目錄下選擇該份檔案。
若是您想清除這份檔案清單，有二個方法：
1、在檔案總管中，将 Windows/Recent 目錄下的檔案通通删除即可。
2、在工作列上按滑鼠右鍵，選擇【内容】，出現【工作列 内容】選單，選擇【開始功能表程式集】，在【檔案功能表】框中按【清除】按鈕即可。
以上是人工的方法及 Windows 内部之作業流程，若是我們的 VB 程式中，要做到這樣的功能，也是很簡單的，但是它有什麼作用呢？有的，舉個例子：
今天 User 在操作我們的程式中，産生了幾份檔案，可能有文字檔、Word 檔案、Excel 檔案...等，當然您可以事先和 User 約定好，産生的檔案固定放在某一個目錄下， User 再自行到該目錄下去作處理，但是，如果您将産生的檔案清單，直接放入【檔案功能表】的檔案清單中，User 根本不 知道檔案放在那裡，他隻要在【檔案功能表】中選擇即可，是不是很友善！
'請在聲明區中加入以下聲明：
Private Declare Sub SHAddToRecentDocs Lib "shell32.dll" (ByVal uFlags As Long, ByVal pv As String)
'新增 (一次增加一筆)
Private Sub Command1_Click()
Dim NewFile As String
NewFile = "c:/doc/880730訂購清單.doc" '<----- 要放到【檔案功能表】檔案清單的檔案
Call SHAddToRecentDocs(2, NewFile)
End Sub
'清除 (一次全部清除)
Private Sub Command2_Click()
Call SHAddToRecentDocs(2, vbNullString)
End Sub
111、您認識 VB 的擴充名嗎？
我不知道您已經使用 VB 多久時間了，但是今天當您面對一堆亂七八糟的檔案時，您能由擴充名來判斷那一個檔案是屬於 VB 的檔案嗎？恐怕不是每一個人都可以？
您知道以下這些擴充名都是 VB 指定給【設計階段檔案】的擴充名嗎？
擴充名 用於
VB6 VB5 VB4-32 VB4-16 VB3
.bas Basic 模組
* * * * *
.cls 物件類别模組
* * * *
.ctl 使用者控制項檔案
* *
.ctx 使用者控制項二進位檔案
* *
.dca 現用設計師快取檔案
* *
.dep 安裝精靈附屬檔案
* *
.dob 使用者檔案表單
* *
.dox 使用者檔案二進位表單檔案
* *
.dsr 現用設計師檔案
* *
.dsx 現用設計師二進位檔案
* *
.frm 表單檔案
* * * * *
.frx 二進位表單檔案
* * * * *
.log 載入錯誤的記錄檔
* * * * *
.oca 控制項 Typelib 檔案
* * * *
.pag 屬性頁檔案
* *
.pgx 二進位屬性頁檔案
* *
.res 資源檔
* * * *
.swt Visual Basic 安裝精靈範本檔案
* *
.tlb Remote Automation Typelib 檔案
* *
.vbg Visual Basic 群組專案
* *
.vbl 使用者控制項授權檔案
* *
.vbp Visual Basic 專案
* * * *
.vbr Remote Automation 注冊檔案
* * * *
.vbw Visual Basic 專案工作區
* *
.vbz 精靈啟動檔案
* * * * *
.wct Webclass 範本檔案
*
.ocx 控制項檔案 * * * *
.vbx 控制項檔案 * *
.mak Visual Basic 專案 * * * * *
112、完全模拟【開始】中的【運作...】功能
請您現在按下【開始】中的【運作...】，看看【運作...】問話框中的說明，是不是如下：
請輸入程式、資料夾、檔案或 Internet 資源的名稱，Windows 會自動開啟。
如果說您我也可以做到這種功能，隻要是可開啟的、可執行的，通通可以做到，您相信嗎？不要懷疑！不但可以做到，而且更讓您驚訝的，是程式竟然這麼短，隻要一行就可以了！
您一定認為要用 API，喔！不是！先别亂猜，這次不用聲明 API！直接來看一個例子：
在 Form 中放一個 TextBox，名稱為 Text1
Private Sub Command1_Click()
Call Shell("rundll32.exe url.dll,FileProtocolHandler " & Text1, 1)
End Sub
而其中的 Text1 可以輸入程式、資料夾、檔案或 Internet 資源的名稱，也可以輸入快捷方式 (shortcut file)，都可以正确執行！
113、模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁盤】
在【網路上的芳鄰】及【我的電腦】中都有提供【連線網路磁盤】及【中斷網路磁盤】的功能，在 VB 的程式中我們一樣可以輕易做到。
'請在聲明區中加入以下聲明及模組：
Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long
Declare Function WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" _
(ByVal lpszName As String, ByVal bForce As Long) As Long
Function AddConnection(MyShareName As String, MyPWD As String, UseLetter As String) As Integer
On Local Error GoTo AddConnection1_Err
AddConnection = WNetAddConnection(MyShareName, MyPWD, UseLetter)
AddConnection_End:
Exit Function
AddConnection1_Err:
AddConnection = Err
MsgBox Error$
Resume AddConnection_End
End Function
Function CancelConnection(DriveLetter As String, Force As Integer) As Integer
On Local Error GoTo CancelConnection_Err
CancelConnection = WNetCancelConnection(DriveLetter, Force)
CancelConnection_End:
Exit Function
CancelConnection_Err:
CancelConnection = Err
MsgBox Error$
Resume CancelConnection_End
End Function
呼叫的方法如下：
連線網路磁盤：傳回值 = AddConnection(<共享的路徑>, <密碼>, <磁盤代号>)
中斷網路磁盤：傳回值 = CancelConnection(<磁盤代号>, <強迫中斷？>)
呼叫執行個體：
連線網路磁盤：X = AddConnection("//IO/io_c", "", "H:")
中斷網路磁盤：X = CancelConnection("H:", True)
注：這個範例實際執行，連線時，NT 及 Novell 之速度相若，但是，在中斷時，Novell 之速度明顯較慢！
注：以上的方式乃是由程式中直接指定，另外的一個方法是顯示問話框由使用者自行設定，這個方法我們在以後将再說明！
114、自制 Round 函數 (取小數點幾位)
這一個問題，有網友反應在某些情形下，會造成誤差 ( 連 VB6.0 提供的 Round 函數都會造成誤差 )，我針對多種情形實際測試，結果很令人驚訝，讓人懷疑如何做才會百分之百完全正确，根據測試結果，我原本想拿掉這個單元，但後來我重新寫了一個比較笨，但是在有限小數位數内仍然會正确的式子，可是這個功能隻支援小數點，不再支援整數以上的 Round 功能，如下：
'傳入的參數和之前相同，第一個是要判斷的數字，第二個是要取小數幾位。
Public Function round(num As Double, pos As Integer) As Double
'整數以上不處理
If pos <= 0 Then
round = Format(num, "#")
Exit Function
End If
Dim i As Integer
Dim formatstr As String
'拼湊 Format 的格式
formatstr = "#."
For i = 1 To pos
formatstr = formatstr & "0"
Next
round = Format(num, formatstr)
End Function
115、如何找出 Windows 目錄的正确路徑？
有時候我們在程式中必須用到 Windows 的目錄，以存取 Windows 目錄下的檔案，照理說，這應該是最簡單的功能，前提是每個人在 Setup Windows 必須采用 Windows 的預設目錄名稱，也就是 C:/Windows，但是常常不是這樣，有時候由於要使新舊版本共存，或者其他原因，有人會将 Windows 目錄改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程式中必須用到 Windows 目錄，要找到正确的路徑，做法如下：
'在聲明區中加入以下聲明：
Const MAX_PATH = 260
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
'在程式中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您電腦中 Windows 目錄的正确路徑是： " & GetWinPath, vbInformation)
End Sub
VB問題全功略（24） [查找本頁請按Ctrl+F]
［上一頁］（24）［下一頁］
116、讓您的音樂 CD 動起來！
117、如何求出磁盤大小及剩餘空間大小 (更簡單的 VB6 新功能)
118、反向思考---怎樣讓程式跑慢一點？(二)
119、列出電腦中所有磁盤
120、模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁盤】(二)
116、讓您的音樂 CD 動起來！
之前，我們讨論過，但是隻會開啟及關閉，用處還不太大，今天，我們來看看要怎麼讓您的音樂 CD 動起來！
'請在聲明區中加入以下聲明： ( 和 "開啟及關閉CD－Rom的門" 相同的聲明)
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'在 Form 中加入二個 CommandButton，分别命名為 cmdPlay 及 cmdStop 并加入以下程式碼：
Sub cmdPlay_Click()
Dim lRet As Long
Dim nCurrentTrack As Integer
'開啟裝置
lRet = mciSendString("open cdaudio alias cd wait", 0&, 0, 0)
'設定時間格式為 Tracks ( 預設值是 milliseconds )
lRet = mciSendString("set cd time format tmsf", 0&, 0, 0)
'從頭開始播放
lRet = mciSendString("play cd", 0&, 0, 0)
'您也可以指定要從第幾首歌 (Track) 開始播放，例如以下指定從第 3 首歌開始播放
'nCurrentTrack = 3
lRet = mciSendString("play cd from" & Str(nCurrentTrack), 0&, 0, 0)
End Sub
' 記得在播放完畢時要關閉裝置
Sub cmdStop_Click()
Dim lRet As Long
'停止播放
lRet = mciSendString("stop cd wait", 0&, 0, 0)
DoEvents '給 Windows一點時間去處理其他事件
'關閉裝置
lRet = mciSendString("close cd", 0&, 0, 0)
End Sub
注：如果您想指定從第幾首歌開始播放，隻要将上面綠色那行程式之 Mark 拿掉，改掉數字即可！
注：原作者原來的聲明是在 mmsystem.dll，現在要使用 winmm.dll 才可以！
117、如何求出磁盤大小及剩餘空間大小 (更簡單的 VB6 新功能)
在《問題 91》時，我們使用了 API 來求出磁盤大小及剩餘空間大小，也就是下方資訊之後二項：
《在我們安裝軟體的時候，在安裝選項的畫面，常常會出現如下的一些叙述：》
選擇安裝項目大小..............................................10,000,000 Bytes
C 磁碟總空間大小..........................................1,847,328,768 Bytes
C 磁碟剩餘空間大小...........................................51,707,904 Bytes
在 VB6 以前我們隻能如此做，對于不熟悉 API 的人來說，很難，但是在 VB6 就變得很簡單，因為在 VB6 中提供了一個新物件：FileSystemObject
讓我們實№來自看例子：
Private Sub Command1_Click()
Dim fso As New FileSystemObject, drv As Drive
Set drv = fso.GetDrive(fso.GetDriveName("c:"))
剩餘空間大小 = drv.FreeSpace
磁盤大小 = drv.TotalSize
End Sub
使用上面的方法算出的結果和使用 GetDiskFreeSpace API 算出的結果是完全一樣的！
118、反向思考---怎樣讓程式跑慢一點？(二)
原來我們提到了使用 Sleep API 來達到讓程式暫停的方法，方法很簡單，程式碼也很簡短，但是美中不足的是，它隻能用在 32 位元的環境中！
難道在 16 位元的環境中就沒辦法了嗎？或者，一定要使用 API 嗎？
還是有辦法的，而且不用 API，最棒的是所有版本的 VB 都可使用！
'在您的程式中，加入以下的模組：
Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents '讓 windows 去處理其他事
Wend
End Sub
'在程式中隻要如下使用即可：
Private Sub Command1_Click()
Delay 5
End Sub
119、列出電腦中所有磁盤
我們曾讨論過使用 GetDriveType API 再加上回圈一個一個判斷磁盤的型态，再列在 ListBox 中供選擇。但是在實際應用程式中，有時候我們根本不需要知道各個磁盤的型态，我們的目的隻是很單純地讓使用者來挑選檔案的位置而已！例如趨勢科技的 Pccillin 要從磁盤 Upgrade 病毒碼時，它會詢問您磁盤代号，就是使用這種作法！
這時候，我們可以換一種更快的方式，(隻是有人認為不能順便列出磁盤型态仍是一種缺點) 如下：
'在聲明區中加入以下聲明：
Const LB_DIR = &H18D 'LB 即是 ListBox 的縮寫
Const DDL_DRIVES = &H4000
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
Public Function AddDrives2ListBox(lhWnd As Long)
Call SendMessage(lhWnd, LB_DIR, DDL_DRIVES, "*")
End Function
'而程式中之使用方法如下：(隻有一個參數，就是 ListBox 的 hwnd)
Private Sub Form_Load()
AddDrives2ListBox List1.hwnd
End Sub
有人問我，ListBox 的很多功能都和 ComboBox 很像，這個例子，可以使用 ComboBox 嗎？
可以的，也不難，将聲明區的聲明改成：
Const CB_DIR = &H145 'CB 即是 ComboBox 的縮寫
Const DDL_DRIVES = &H4000
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
Public Function AddDrives2ComboBox(lhWnd As Long)
Call SendMessage(lhWnd, CB_DIR, DDL_DRIVES, "*")
End Function
'而程式中之使用方法如下：(隻有一個參數，就是 ComboBox 的 hwnd)
Private Sub Form_Load()
AddDrives2ComboBox Combo1.hwnd
End Sub
120、模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁盤】(二)
對于實際的網路作業，WNet API 是非常有用的，例如：我們在《問題93》模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁盤】中我們就使用了 WNetAddConnection 及 WNetCancelConnection 這二個 API 很有效地來處理連線及中斷網路磁盤，但是我們不知道每一個使用者電腦中的實際設定，使用直接指定的強迫連線及中斷，或許會影響使用者原本電腦中的設定。
下面的方法是一個比較中性的作法，就是出現【連線 / 中斷網路磁盤】的問話框，讓使用者根據自己電腦的情形，來決定要連線的網路磁盤要對應到自己的那一個磁盤？要中斷的又是那一個對應的磁盤？其實，這個方法更接近實際模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁盤】！
請在聲明區中加入以下聲明及模組：
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Private Declare Function WNetDisconnectDialog Lib "mpr.dll" (ByVal hwnd As Long, ByVal dwType As Long) As Long
Sub ShowMapDrives(hwnd As Long)
WNetConnectionDialog hwnd, 1
End Sub
Sub ShowUnMapDrives(hwnd As Long)
WNetDisconnectDialog hwnd, 1
End Sub
'程式中使用方式如下：
Private Sub Command1_Click()
'出現 連線網路磁盤 問話框
ShowMapDrives Me.hwnd
End Sub
Private Sub Command2_Click()
'出現 中斷網路磁盤 問話框
ShowUnMapDrives Me.hwnd
End Sub
121、取得印表機的連接配接埠
在測試上一個《問題 100》模拟【網路上的芳鄰】及【我的電腦】中的【連線 / 中斷網路磁碟機】 (二) 時，我們用到了 WNetConnectionDialog API，這個 API 又讓我想到了另一個小功能！
您設定過印表機嗎，如果有，在設定印表機時，設定問話框中有一個 Tab 是【詳細資料】頁，在此頁中有一個按鈕是讓我們《取得印表機連接配接埠》，WNetConnectionDialog 這個 API 的功能之一就是叫出《取得印表機連接配接埠》問話框！
'一樣在聲明區中加入以下聲明：
Private Declare Function WNetConnectionDialog Lib "mpr.dll" (ByVal hWnd As Long, ByVal dwType As Long) As Long
Sub ShowPrinterPort(hWnd As Long)
WNetConnectionDialog hWnd, 2
End Sub
'在程式中使用方法如下：
Private Sub Command1_Click()
ShowPrinterPort Me.hWnd
End Sub
122、讀取及設定檔案的屬性
當我們在任一個檔案上按滑鼠右鍵，選擇【内容】，在檔案内容的【一般】頁簽中我們可以看到每一個檔案有四個屬性：儲存、隻讀、隐藏及系統。
使用 GetFileAttributes 及 SetFileAttributes 二個 API 我們就可以讀取及設定這四個屬性。
'請在聲明區中加入以下聲明：
'設定檔案屬性
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
'讀取檔案屬性
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Const FILE_ATTRIBUTE_READONLY = &H1 '設定為隻讀
Const FILE_ATTRIBUTE_HIDDEN = &H2 '設定為隐藏
Const FILE_ATTRIBUTE_SYSTEM = &H4 '設定為系統
Const FILE_ATTRIBUTE_ARCHIVE = &H20 '設定為儲存
Const FILE_ATTRIBUTE_NORMAL = &H80 '設定為一般 (取消前四種屬性)
'要設定二種以上的屬性可以用 or 串聯以上之屬性，來看看例子：
'設定 db1.mdb 為隻讀
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY
'設定 db1.mdb 為隻讀 + 隐藏
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN
'設定 db1.mdb 為隻讀 + 隐藏 + 系統 + 儲存
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_HIDDEN _
Or FILE_ATTRIBUTE_SYSTEM Or FILE_ATTRIBUTE_ARCHIVE
'取消 db1.mdb 所有設定
SetFileAttributes "c:/db1.mdb", FILE_ATTRIBUTE_NORMAL
'要讀取檔案目前的屬性，則是用 GetFileAttributes API，以讀取 db1.mdb 為例：
MsgBox GetFileAttributes("c:/db1.mdb")
'傳回值如上面的常數聲明值，例如：
'若傳回值為 6 ( =2+4 ) 表示此檔案為 隐藏 + 系統
'但是若傳回值為 128 表示此檔案未設定任何屬
123、避免 Null 産生的錯誤
當我們從資料庫讀出資料時，有的欄位之内容可能為 Null，若不加以處理而要将資料搬給某一欄位時，會有錯誤産生，雖然 VB 本身有提供一個 IsNull 函數以供判斷，但是您知道嗎，我寫了這麼多年的 VB 資料庫程式，從來沒有用過 IsNull 來判斷資料庫欄位值，為什麼呢？我又怎麼做呢？
其實很簡單，我不管從資料庫讀出來的是不是 Null，寫法一律如下：
Text1.text = rs1("Field1") & ""
如果這個欄位的值是 Null，加上 ( ＆ 〃 ) 之後就變成了 "" 了！
但是要小心，我的新同僚們常常會犯一個錯誤，我們看看以下二個式子：
1、Text1.text = Trim(rs1("Field1")) & "" ' ( 可能是錯的 )
2、Text1.text = Trim(rs1("Field1") & "") ' ( 這樣寫才對 )
第一個式子如果欄位值是 Null，使用 trim$ 便會産生錯誤，對於這些狀況，其實隻要記住一個原則即可：
不管從資料庫讀出之資料要做什麼動作，不管三七二十一先加上 ( ＆ 〃 ) 就對了
再來看看一個例子，以加深印象：
Text1.text = Format( (rs1("Field1") & ""), "yymmdd")
124、如何找出 Windows 目錄的正确路徑？
有時候我們在程式中必須用到 Windows 的目錄，以存取 Windows 目錄下的檔案，照理說，這應該是最簡單的功能，前提是每個人在 Setup Windows 必須采用 Windows 的預設目錄名稱，也就是 C:/Windows，但是常常不是這樣，有時候由于要使新舊版本共存，或者其他原因，有人會将 Windows 目錄改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程式中必須用到 Windows 目錄，要找到正确的路徑，做法如下：
'在聲明區中加入以下聲明：
Const MAX_PATH = 260
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
'在程式中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您電腦中 Windows 目錄的正确路徑是： " & GetWinPath, vbInformation)
End Sub
125、如何找出 System 目錄的正确路徑？
和《問題104》如何找出 Windows 目錄的正确路徑？一樣，由于有很多系統檔案都放在 System 目錄下，有時候我們在程式中必須用到 System 的目錄，以存取 System 目錄下的檔案，但是有時候由於要使新舊版本共存，或者其他原因，有人會将 Windows 目錄改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程式中必須用到 System 目錄，要找到正确的路徑，做法如下：
'在聲明區中加入以下聲明：
Const MAX_PATH = 260
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function GetSystemPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetSystemDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetSystemPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetSystemPath = ""
End If
End Function
'在程式中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您電腦中 System 目錄的正确路徑是：" & GetSystemPath, vbInformation)
End Sub
126、如何找出 Temp 目錄的正确路徑？
有時候，我們的 VB 程式在執行時，會産生一些檔案，或許隻是暫存檔，這時您可以考慮放在 Windows 的 Temp 目錄下，這個目錄在預設的情形下是在 c:/windows/temp，但是， User 有時候由于要使新舊版本共存，或者其他原因，有人會将 Windows 目錄改成 c:/win95、c:/win98、Windows95 或 Windows98......
若是程式中必須用到 Temp 目錄，要找到正确的路徑，做法如下：
'在聲明區中加入以下聲明：
Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTmpPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetTempPath(MAX_PATH, strFolder)
If lngResult <> 0 Then
GetTmpPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else: GetTmpPath = ""
End If
End Function
'在程式中使用方法如下：
Private Sub Command1_Click()
Call MsgBox("您電腦中 Temp 目錄的正确路徑是" & GetTmpPath, vbInformation)
End Sub
127、建立 Windows95/98 的快捷方式
在前面我們提到過快捷方式，不過當時提到的快捷方式是專門用于連結 Internet 的網頁使用的，現在我們要談的則是在 Windows95/98 中的一般快捷方式，也就是要放在【開始】或【桌面】上，友善使用者啟動程式的快捷方式！
'請在聲明區中加入以下的聲明：(以下為 VB4-32 / VB5)
'VB4-32
Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName as String, ByVal lpstrLinkName as String, ByVal lpstrLinkPath as String, ByVal lpstrLinkArgs as String) As Long
'VB5
Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
'參數說明：
lpstrFolderName 要放置快捷方式的位置，但是指的是對應到【開始】的【程式】的相對位置
【程式】的實際目錄位置是 C:/Windows/Start Menu/Programs
【桌面】的實際目錄位置是 C:/Windows/Desktop
是以如果想将快捷方式放在桌面上，此參數的設定值應為 "../../Desktop"
lpstrLinkName 快捷方式要顯示出來的說明文字
lpstrLinkPath 快捷方式要開啟或執行的檔案的實際位置
lpstrLinkArgs 開啟或執行的檔案若需要參數，則放在這
'在程式中使用的方法如下：
lngResult = fCreateShellLink("../../Desktop", "記事本捷徑", " c:/windows/notepad.exe","")
128、如何用 VB 呼叫出在【查找：所有檔案】中的【浏覽資料夾】問話框？
相信大家都使用過 Windows 95/98 的【開始】【查找】【檔案或資料夾...】功能，當然【查找】的功能不一定要從【開始】開始，在 Windows 的很多地方，例如【資料總管】或【我的電腦】...等，都可以按下滑鼠右鍵來使用【查找】的功能。
在【查找：所有檔案】問話框中，在【名稱及位置】頁中，有一個【浏覽】的按鈕，按下後會出現一個大家似曾相識的問話框，叫作【浏覽資料夾】問話框，在這個問話框中，您可以看到電腦中所有的磁盤及資料夾，您知道在 VB中要如何呼叫它嗎？
'請在聲明區中加入以下聲明：
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private 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
'在 Form 中放一個 CommandButton，并加入以下程式：
Private Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "請選擇要開始搜尋的資料夾" '<-- 此标題可根據 要自行更改
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
MsgBox sBuffer
End If
End Sub
'好了，執行您的程式，按下按鈕看看結果吧！
129、讓您的文字框有 Undo / Redo 的功能
很多軟體都有提供 Undo / Redo 的功能，Microsoft 的産品都可以提供多次 Undo 反悔，功能更強大！
在 VB 的程式中，我們也可以提供這樣的功能！不過隻能 Undo / Redo 一次
'在聲明區中加入以下聲明：
'32位元
'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
'Const EM_UNDO = &HC7
'16位元
Private Declare Function SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Const WM_USER = &H400
Const EM_UNDO = WM_USER + 23
'在程式中使用的方式如下： ( Undo Text1 中的輸入 )
Private Sub Command1_Click()
Dim UndoResult As Long
UndoResult = SendMessage(Text1.hwnd, EM_UNDO, 0, 0)
'傳回值 UndoResult = -1 表示 Undo 不成功
End Sub
'使用以上的方法，第一次是 Undo ，第二次就等于是 Redo
130、如何使點矩陣印表機一次隻印一行
VB 有提供一個 Printer 物件來幫我們做列印，但是，當我們使用點矩陣印表機列印時，若希望每次隻列印一行資料後，印表機不要自動跳頁，繼續等待列印！這時候往往造成很多人的困擾，因為：若不使用 NewPage 和 EndDoc 方法就不會立刻印出，但是用了又會跳頁。
這時候，我們就不能再使用 Printer 物件，然而我們可以用以前在 Dos 時代使用的方法如下：
Open "PRN" For Output As #1
Print #1,"列印内容"
但是有一點必須注意的是：上面這個方式絕對可以單行列印英文，但是若你想印中英文, 你的印表機必須有内建中文字型才行！
VB問題全功略（27） [查找本頁請按Ctrl+F]
［上一頁］（27）［下一頁］
131、Printer 物件如何控制列印機跳頁至指定的地方?
132、如何在按下 Enter 鍵之後，自動讓 Focus 移到下一個物件？
133、如何隐藏及顯示工作列？
134、取得應用程式執行的路徑
135、清除 ListBox 及 ComboBox 中重複的項目
131、Printer 物件如何控制列印機跳頁至指定的地方?
在網站上有人提出這樣的問題：
用 VB6 寫一列印程式,列印機是點矩陣的,而紙張為公司特别定做的,是以當用 EndDoc 方法列印時,無法控制列印機跳頁至指定的地方(就是可用手撕紙的那一條虛線)
VB 的 Printer 物件提供的 EndDoc 會自動根據我們設定的紙張大小，自動跳到下一頁，但是當我們所使用的紙張是特殊大小時 (很多套印的表格都是特殊大小的尺寸)，若要讓列印機的跳頁正常，并不需更改我們的程式，要更改的是我們機器上該列印機的紙張大小的設定。
1、開啟【我的電腦】，開啟【列印機】(或由【開始】或【控制台】開啟列印機)。
2、在該點矩陣列印機上按滑鼠右鍵選擇【内容】，出現該列印機的【内容】問話框。
3、選擇【紙張】頁簽。
4、紙張大小選擇【自訂】，會出現【使用者定義大小】問話框。
5、輸入紙張的寬度和長度，機關有二種 ( 0.01英寸 / 0.1公 )
用以上的方法設定好後，您就可以不用管紙張大小了，下一次它換頁時就會自動跳頁至指定的地方。
132、如何在按下 Enter 鍵之後，自動讓 Focus 移到下一個物件？
如果您希望使用者在 TextBox 中按下 Enter 鍵之後，能夠讓 Focus 在各個物件之間遊移，在 KeyPress 事件中您就必須判斷是否有按下 Enter 鍵，如果有的話，您就必須取消 Enter 鍵，并送出一個 Tab 鍵。
在 VB 中，當您送出一個 Tab 鍵後，遊标會依照 TabIndex 的順序，在各物件之間移動。
若要照 TabIndex 順序移動，指令為 SendKeys "{tab}"
若要照 TabIndex 反順序移動，指令為 SendKeys "+{tab}"
其實以上的方法不隻适用于 TextBox 物件，很多物件都适用這個原則，但是 CommandButton 就不行了！因為 CommandButton 根本就沒有 KeyPress 事件！
以下是一段範例程式：
Sub Text1_KeyPress (KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
133、如何隐藏及顯示工作列？
有時候，我們希望在我們的程式執行中，将工作列隐藏，讓桌面變得比較清爽，等到我們的程式執行完畢之後，再将工作列顯示出來，這時就要用到 SetWindowPos 這個 API 了！
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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const SWP_HIDEWINDOW = &H80 '隐藏視窗
Const SWP_SHOWWINDOW = &H40 '顯示視窗
'在程式中若要隐藏工作列
Private Sub Command1_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
'在程式中若要再顯示工作列
Private Sub Command2_Click()
Dim Thwnd As Long
Thwnd = FindWindow("Shell_traywnd", "")
Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub
134、取得應用程式執行的路徑
有時候執行我們的應用程式時，會用到一些和應用程式相關的檔案，例如資料庫、圖檔、文字檔...等，這些檔案我們通常都會放在和應用程式相同的目錄或子目錄中，于是在我們的應用程式中便有抓取應用程式現行目錄的 求，在此我們介紹二種方法：
1、App.Path：傳回值自動轉為大寫。
2、CurDir：傳回值為大小寫混合。
使用範例如下：
Private Sub Command1_Click()
Text1.text = App.Path
Text2.text = CurDir
End Sub
135、清除 ListBox 及 ComboBox 中重複的項目
當我們要将一大堆資料加入 ListBox 或 ComboBox 時，為了不讓 ListBox 或 ComboBox 中的項目重複，有些人會在将新項目加入 ListBox 或 ComboBox 時，就先作項目比對，資料沒有重複時，才将資料加入 ListBox 或 ComboBox 中。
但是如果我們将資料統統加入 ListBox 或 ComboBox 之後，再來執行比對動作，不但程式容易維護，而且速度會加快一點點，以下的模組就是做項目比對，以清除 ListBox 或 ComboBox 中重複的項目。
模組中需要傳入二個參數，說明如下：
1、控制項名稱：可傳入 ListBox 或 ComboBox 的名稱。
2、是否分别大小寫：True 表示要分别大小寫，False 則不分大小寫。
Sub RemoveDups(lst As Control, comptype As Boolean)
Dim lPos As Long '原始比對項目 index
Dim lCompPos As Long '待比對項目 index
Dim sComp As String '原始比對字串
Dim sComptype As Long '0(binary) / 1(textual) 比對
lPos = 0
If comptype Then sComptype = 0 Else sComptype = 1
Do While lPos < (lst.ListCount - 1)
sComp = lst.List(lPos)
lCompPos = lPos + 1
Do While lCompPos < lst.ListCount
If StrComp(sComp, lst.List(lCompPos), sComptype) = 0 Then
lst.RemoveItem lCompPos
lCompPos = lCompPos - 1
End If
lCompPos = lCompPos + 1
Loop
lPos = lPos + 1
Loop
End Sub
'在程式中使用方式如下：
'要分别大小寫
Private Sub Command1_Click()
RemoveDups List1, True
RemoveDups Combo1, True
End Sub
'不分别大小寫
Private Sub Command2_Click()
RemoveDups List1, False
RemoveDups Combo1, False
End Sub
136、找出電腦中已經安裝的輸入法
'在 Form 中加入一個 ListBox，在聲明區中加入以下聲明：
Private Declare Function GetKeyboardLayoutList Lib "user32" (ByVal nBuff As Long, lpList As Long) As Long
Private Declare Function ImmGetDescription Lib "imm32.dll" Alias "ImmGetDescriptionA" (ByVal HKL As Long, ByVal lpsz As String, ByVal uBufLen As Long) As Long
Private Declare Function ImmIsIME Lib "imm32.dll" (ByVal HKL As Long) As Long
'在 Form_Load 中加入以下程式碼：
Private Sub Form_Load()
Dim No As Long, i As Long
Dim hKB(24) As Long, bufflen As Long
Dim buff As String, RetStr As String, RetCount As Long
buff = String(255, 0)
No = GetKeyboardLayoutList(25, hKB(0))
For i = 1 To No
If ImmIsIME(hKB(i - 1)) = 1 Then
bufflen = 255
RetCount = ImmGetDescription(hKB(i - 1), buff, bufflen)
RetStr = Left(buff, RetCount)
List1.AddItem RetStr
Else
RetStr = "English(American)"
List1.AddItem RetStr
End If
Next
End Sub
137、如何将一串阿拉伯數字轉成中文數字字串？
在我們的應用系統中，有時候要産生一些比較正式的報表 (套表)，例如合約書、電腦開票....等，在這些報表中，關于數字的部份，尤其是金額的部份，為了防止糾紛的産生，通常都必須将阿拉伯數字轉成中文大寫數字，這種工作，人工做起來很簡單，電腦來做，可就要花點工夫了！
以下幾個 Function 就是用來處理這個工作的，其中最主要的就是 numbertoword 這個 Function，程式中要呼叫的也就是這個 Function，其他三個 Function 隻是配合這個 Function 而已。
'在程式中隻要如右使用即可：傳回中文數字 = numbertoword( 阿拉伯數字 )
程式碼如下：
Public Function numbertoword(number As String) As String
'-------------------------------------------------------------------
'目的:轉換一串阿拉伯數字為中文數字
'參數:一串阿拉伯數字
'傳回值:轉換後的一串中文數字
'---------------------------------------------------------------------------------------------------------------------------------
'注: 此一 Function 必須包含以下三個 Function
'1.mapword:轉換單一數字為國數字(0123456789->零壹貳參肆伍陸柒捌玖)
'2.StringCleaner:清除字串中不要的字元
'3.convtoword:将傳入的四個數字轉成中文數字字串(1234->壹仟貳佰參拾肆)
'---------------------------------------------------------------------------------------------------------------------------------
Dim wlength As Integer '數字字串總長度
Dim wsection As Integer '歸屬的段落 (0:萬以下/1:萬/2:億/3:兆)
Dim wcount As Integer '剩餘的數字字串長度
Dim wstr As String '暫存字串
Dim wstr1 As String '暫存字串-兆
Dim wstr2 As String '暫存字串-億
Dim wstr3 As String '暫存字串-萬
Dim wstr4 As String '暫存字串-萬以下
'未輸入或0不做
'-----------------------------------------------
If Trim(number) = "" Or Trim(number) = "0" Then
numbertoword = "零"
Exit Function
End If
'-----------------------------------------------
wlength = Len(number)
wsection = wlength / 4
wcount = wlength Mod 4
'-----------------------------------------------
'每四位一組, 分段 (兆/億/萬/萬以下)
If wcount = 0 Then
wcount = 4
wsection = wsection - 1
End If
'----------------------------------------------
'大于兆的四位數轉換
If wsection = 3 Then
'抓出大于兆的四位數
wstr = Left(Format(number, "0000000000000000"), 4)
'轉換
wstr1 = convtoword(wstr)
If wstr1 <> "零" Then wstr1 = wstr1 & "兆"
End If
'----------------------------------------------
'大于億的四位數轉換
If wsection >= 2 Then
'抓出大于億的四位數
If Len(number) > 12 Then
wstr = Left(Right(number, 12), 4)
Else
wstr = Left(Format(number, "000000000000"), 4)
End If
'轉換
wstr2 = convtoword(wstr)
If wstr2 <> "零" Then wstr2 = wstr2 & "億"
End If
'----------------------------------------------
'大于萬的四位數轉換
If wsection >= 1 Then
'抓出大于萬的四位數
If Len(number) > 8 Then
wstr = Left(Right(number, 8), 4)
Else
wstr = Left(Format(number, "00000000"), 4)
End If
'轉換
wstr3 = convtoword(wstr)
If wstr3 <> "零" Then wstr3 = wstr3 & "萬"
End If
'----------------------------------------------
'萬以下的四位數轉換
'抓出萬以下的四位數
If Len(number) > 4 Then
wstr = Right(number, 4)
Else
wstr = Format(number, "0000")
End If
'轉換
wstr4 = convtoword(wstr)
'----------------------------------------------
'組合最多四組字串(兆/億/萬/萬以下)
numbertoword = wstr1 & wstr2 & wstr3 & wstr4
'去除重複的零 ('零零'-->'零')
Do While InStr(1, numbertoword, "零零")
numbertoword = StringCleaner(numbertoword, "零零")
Loop
'----------------------------------------------
'去除最左邊的零
If Left(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 2)
End If
'----------------------------------------------
'去除最右邊的零
If Right(numbertoword, 1) = "零" Then
numbertoword = Mid(numbertoword, 1, Len(numbertoword) - 1)
End If
End Function
Public Function mapword(no As String) As String
'-----------------------------------------------------------
'目的:轉換單一數字為國數字(0123456789->零壹貳參肆伍陸柒捌玖)
'參數:數字(0123456789)
'傳回值:國數字(零壹貳參肆伍陸柒捌玖)
'-----------------------------------------------------------
Select Case no
Case "0"
mapword = "零"
Case 1
mapword = "壹"
Case "2"
mapword = "貳"
Case "3"
mapword = "參"
Case "4"
mapword = "肆"
Case "5"
mapword = "伍"
Case "6"
mapword = "陸"
Case "7"
mapword = "柒"
Case "8"
mapword = "捌"
Case "9"
mapword = "玖"
End Select
End Function
Public Function StringCleaner(s As String, Search As String) As String
'-----------------------------------------------------------
'目的:清除字串中不要的字元
'參數:1.完整字串. 2.要清除的字元(可含多字元)
'傳回值:清除後的字串
'''此段之主要目的在去除重複的 '零' ('零零'-->'零')
'-----------------------------------------------------------
Dim i As Integer, res As String
res = s
Do While InStr(res, Search)
i = InStr(res, Search)
res = Left(res, i - 1) & Mid(res, i + 1)
Loop
StringCleaner = res
End Function
Public Function convtoword(wstr As String) As String
'-----------------------------------------------------------
'目的:将傳入的四個數字轉成中文數字字串(1234->壹仟貳佰參拾肆)
'參數:4位數的數字 (前面空白補0)
'傳回值:轉換後的中文數字字串
'-----------------------------------------------------------
Dim tempword As String
'仟位數
tempword = mapword(Mid(wstr, 1, 1))
If tempword <> "零" Then tempword = tempword & "仟"
convtoword = convtoword & tempword
'佰位數
tempword = mapword(Mid(wstr, 2, 1))
If tempword <> "零" Then tempword = tempword & "佰"
convtoword = convtoword & tempword
'拾位數
tempword = mapword(Mid(wstr, 3, 1))
If tempword <> "零" Then tempword = tempword & "拾"
convtoword = convtoword & tempword
'個位數
tempword = mapword(Mid(wstr, 4, 1))
convtoword = convtoword & tempword
'去除最右邊的零
Do While Right(convtoword, 1) = "零" And Len(convtoword) > 1
convtoword = Mid(convtoword, 1, Len(convtoword) - 1)
Loop
End Function
'在程式中隻要如右使用即可：傳回中文數字 = numbertoword( 阿拉伯數字 )
'-----------------------------------------------------------
'程式中使用執行個體 ( 加上錯誤判斷 )
'在 Form 中放二個 TextBox 及一個 CommandButton
'Text1 輸入數字, Text2 顯示轉換結果
'-----------------------------------------------------------
Private Sub Command1_Click()
Text2 = ""
'去除小數點
If InStr(1, Text1, ".") <> 0 Then
Text1 = Mid(Text1, 1, InStr(1, Text1, ".") - 1)
End If
'去除逗點
Text1 = StringCleaner(Text1, ",")
'判斷不含非數字
Dim i As Integer
Dim werr As String
For i = 1 To Len(Text1)
If Asc(Mid(Text1, i, 1)) < 48 Or Asc(Mid(Text1, i, 1)) > 57 Then
werr = "Y"
Exit For
End If
Next
If werr = "Y" Then
MsgBox "不可含非數字"
'focus 回到 text1 友善輸入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
Exit Sub
End If
'主要程式隻一行-----------
Text2 = numbertoword(Text1)
'-------------------------
'focus 回到 text1 友善輸入
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)
End Sub
138、如何将一串阿拉伯數字轉成英文數字字串？
在在同樣情形下，有些情況，我們也必須将阿拉伯數字轉成英文數字，以下這個 Function 就是用來處理這個工作的。
'在程式中隻要如右使用即可：傳回英文數字 = numtoword( 阿拉伯數字 )
先看看結果：
程式碼如下：
Public Function numtoword(numstr As Variant) As String
'----------------------------------------------------
' The best data type to feed in is
' Decimal, but it is up to you
'----------------------------------------------------
Dim tempstr As String
Dim newstr As String
numstr = CDec(numstr)
If numstr = 0 Then
numtoword = "zero "
Exit Function
End If
If numstr > 10 ^ 24 Then
numtoword = "Too big"
Exit Function
End If
If numstr >= 10 ^ 12 Then
newstr = numtoword(Int(numstr / 10 ^ 12))
numstr = ((numstr / 10 ^ 12) - Int(numstr / 10 ^ 12)) * 10 ^ 12
If numstr = 0 Then
tempstr = tempstr & newstr & "billion "
Else
tempstr = tempstr & newstr & "billion, "
End If
End If
If numstr >= 10 ^ 6 Then
newstr = numtoword(Int(numstr / 10 ^ 6))
numstr = ((numstr / 10 ^ 6) - Int(numstr / 10 ^ 6)) * 10 ^ 6
If numstr = 0 Then
tempstr = tempstr & newstr & "million "
Else
tempstr = tempstr & newstr & "million, "
End If
End If
If numstr >= 10 ^ 3 Then
newstr = numtoword(Int(numstr / 10 ^ 3))
numstr = ((numstr / 10 ^ 3) - Int(numstr / 10 ^ 3)) * 10 ^ 3
If numstr = 0 Then
tempstr = tempstr & newstr & "thousand "
Else
tempstr = tempstr & newstr & "thousand, "
End If
End If
If numstr >= 10 ^ 2 Then
newstr = numtoword(Int(numstr / 10 ^ 2))
numstr = ((numstr / 10 ^ 2) - Int(numstr / 10 ^ 2)) * 10 ^ 2
If numstr = 0 Then
tempstr = tempstr & newstr & "hundred "
Else
tempstr = tempstr & newstr & "hundred and "
End If
End If
If numstr >= 20 Then
Select Case Int(numstr / 10)
Case 2
tempstr = tempstr & "twenty "
Case 3
tempstr = tempstr & "thirty "
Case 4
tempstr = tempstr & "forty "
Case 5
tempstr = tempstr & "fifty "
Case 6
tempstr = tempstr & "sixty "
Case 7
tempstr = tempstr & "seventy "
Case 8
tempstr = tempstr & "eighty "
Case 9
tempstr = tempstr & "ninety "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If
If numstr > 0 Then
Select Case numstr
Case 1
tempstr = tempstr & "one "
Case 2
tempstr = tempstr & "two "
Case 3
tempstr = tempstr & "three "
Case 4
tempstr = tempstr & "four "
Case 5
tempstr = tempstr & "five "
Case 6
tempstr = tempstr & "six "
Case 7
tempstr = tempstr & "seven "
Case 8
tempstr = tempstr & "eight "
Case 9
tempstr = tempstr & "nine "
Case 10
tempstr = tempstr & "ten "
Case 11
tempstr = tempstr & "eleven "
Case 12
tempstr = tempstr & "twelve "
Case 13
tempstr = tempstr & "thirteen "
Case 14
tempstr = tempstr & "fourteen "
Case 15
tempstr = tempstr & "fifteen "
Case 16
tempstr = tempstr & "sixteen "
Case 17
tempstr = tempstr & "seventeen "
Case 18
tempstr = tempstr & "eighteen "
Case 19
tempstr = tempstr & "nineteen "
End Select
numstr = ((numstr / 10) - Int(numstr / 10)) * 10
End If
numtoword = tempstr
End Function
'在程式中使用執行個體：Text1是輸入的阿拉伯數字，Text2 是傳回的英文字
Text2 = numtoword(Text1)
139、如何取得螢幕字型
Private Sub Combo1_Click()
Label1.Font = Combo1.List(Combo1.ListIndex)
End Sub
Private Sub Combo1_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Private Sub Command1_Click()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub
140、如何得到某年每個月的第一天是星期幾
Private Sub Command1_Click()
Dim i As Integer, A As Integer, B As Integer, C As String
A = InputBox("請輸入年份", "某年每個月的第一天是星期幾")
Form1.Cls
For i = 1 To 12
C = A & "-" & i & "-1"
B = Weekday(C)
Select Case B
Case vbSunday
Print A & "年" & i & "月1日是 星期日"
Case vbMonday
Print A & "年" & i & "月1日是 星期一"
Case vbTuesday
Print A & "年" & i & "月1日是 星期二"
Case vbWednesday
Print A & "年" & i & "月1日是 星期三"
Case vbThursday
Print A & "年" & i & "月1日是 星期四"
Case vbFriday
Print A & "年" & i & "月1日是 星期五"
Case vbSaturday
Print A & "年" & i & "月1日是 星期六"
End Select
Next i
End Sub
141、在 VB 程式中做複制磁片 (DiskCopy) 的功能
下面這一段程式并不是實際在程式中就做複制磁片的功能，而是呼叫出 Windows 系統的複制磁片問話框！
'在聲明區中加入以下聲明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一個 CommandButton 命名為 cmdDiskCopy，再加入一個 DriveListBox
Private Sub cmdDiskCopy_Click()
' DiskCopyRunDll takes two parameters- From and To
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg&
DriveLetter = UCase(Drive1.Drive) '磁盤代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盤序号，從 0 開始：A=0，B=1....
DriveType = GetDriveType(DriveLetter) '磁盤型态 ( 軟碟 / 硬碟 / CD光牒 ... )
If DriveType = 2 Then '軟碟
RetVal = Shell("rundll32.exe diskcopy.dll,DiskCopyRunDll " & DriveNumber & "," & DriveNumber, 1) 'Notice space after
Else '非軟碟
RetFromMsg = MsgBox("隻有磁盤片才可以複制磁片", 64, "複制磁片")
End If
End Sub
142、在 VB 程式中做制作格式 (Format) 的功能
下面這一段程式并不是實際在程式中就做制作格式的功能，而是呼叫出 Windows 系統的制作格式問話框！
這個範例程式是從網絡上抓下來的，原作者特别注明，這一段程式也可以格式化硬碟，是以要小心控制，程式碼中格式化硬碟的部份，我已經 Mark 起來了，若有需要，才将 Mark 拿掉吧！
軟碟格式化的部份我已測試過沒問題，硬碟的部份，我沒有空硬碟是以沒有測試，大家自己玩玩吧！若有問題再通知我！
'在聲明區中加入以下聲明
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
'在 Form 中加入一個 CommandButton 命名為 cmdFormatDrive，再加入一個 DriveListBox
Private Sub cmdFormatDrive_Click()
Dim DriveLetter$, DriveNumber&, DriveType&
Dim RetVal&, RetFromMsg%
DriveLetter = UCase(Drive1.Drive) '磁盤代号 ( A / B / C / D..... )
DriveNumber = (Asc(DriveLetter) - 65) '磁盤序号，從 0 開始：A=0，B=1....
DriveType = GetDriveType(DriveLetter) '磁盤型态 ( 軟碟 / 硬碟 / CD光牒 ... )
If DriveType = 2 Then '軟碟
RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Else '非軟碟
RetFromMsg = MsgBox("這一張磁盤不是軟碟，可能是硬碟！" & vbCrLf & _
"您還要繼續格式 (Format) 嗎?", 276, "格式化")
Select Case RetFromMsg
Case 6 'Yes：表示要格式化硬碟
' UnComment to do it...
'RetVal = SHFormatDrive(Me.hwnd, DriveNumber, 0&, 0&)
Case 7 'No：表示要取消格式化
' Do nothing
End Select
End If
End Sub
143、簡簡單單做到【剪下 / 複制 / 貼上 / 複原】的功能
在很多軟體的編輯功能表中，都有提供【剪下 / 複制 / 貼上 / 複原】的功能，在 VB 中我們隻要借用 Windows 的系統功能，很容易也可以有這樣的功能，看看以下的程式碼便能了解了！
Sub mnuEditText_Click (Index As Integer)
' 我們隻要使用 SendKeys，其他的就讓 Windows 去做吧！
Select Case Index
Case 0 '複原/UNDO
SendKeys "^Z" 'Keys Ctrl+Z
Case 1 '剪下/CUT
SendKeys "^X" 'Keys Ctrl+X
Case 2 '複制/COPY
SendKeys "^C" 'Keys Ctrl+C
Case 3 '貼上/PASTE
SendKeys "^V" 'Keys Ctrl+V
End Select
End Sub
144、如何偵測電腦目前是否正在連線中？
有些應用程式在程式中有部份功能必須和 Internet 連結溝通，這時候，偵測電腦目前是否正在連線狀态就顯得很重要了，每當在 Windows 中撥接上網之後，Windows 系統會自動在系統資料庫中做上一點記号 (改變系統資料庫中某些鍵值的資料)，而我們在 VB 程式中就可以利用這些改變的鍵值來判斷電腦目前是否正在連線狀态！
'在模組的聲明區中加入以下聲明及模組：
Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, 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
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System/CurrentControlSet/Services/RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
ActiveConnection = False
Else
ActiveConnection = True
End If
End If
RegCloseKey (hKey)
End If
End Function
'而在程式中使用執行個體如下：
If ActiveConnection = True then
Call MsgBox("您的電腦目前正在連線中！",vbInformation)
Else
Call MsgBox("您的電腦目前在離線狀态！.", vbInformation)
End If
145、如何在程式中啟動【撥号網絡連線】對話框？
要直接在 VB 程式中開啟【撥号網絡連線】對話框，要使用 Shell 函數：
Private Sub Command1_Click()
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "撥号網絡連線名稱", 1)
End Sub
其中 "撥号網絡連線名稱" 是我們事先在 【撥号網絡】中設定的【連線名稱】，例如【Hinet】。
注：以上方法隻适用于 Windows95/98。
146、如何中斷【撥号網路連線】？
要在 VB 程式中中斷【撥号網路連線】，可以使用 Remote Access Services Hangup 函數：
'在模組的聲明區中加入以下聲明及模組：
Public Const RAS_MAXENTRYNAME As Integer = 256
Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412
Public Const ERROR_SUCCESS = 0&
Public Type RasEntryName
dwSize As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
End Type
Public Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type
Public Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Public gstrISPName As String
Public ReturnCode As Long
Public Sub HangUp()
Dim i As Long
Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long
lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
If ReturnCode = ERROR_SUCCESS Then
For i = 0 To lpcConnections - 1
If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
hRasConn = lpRasConn(i).hRasConn
ReturnCode = RasHangUp(ByVal hRasConn)
End If
Next i
End If
End Sub
Public Function ByteToString(bytString() As Byte) As String
Dim i As Integer
ByteToString = ""
i = 0
While bytString(i) = 0&
ByteToString = ByteToString & Chr(bytString(i))
i = i + 1
Wend
End Function
'在程式中使用執行個體為
Call HangUp
147、資料庫的導出
在很多 VB 的資料庫書籍中，都會很完整的提到：如何由其他種類的檔案中将資料導入資料庫，但是卻很少有書提到：如何将資料庫中的資料，導出到各種不同的檔案類型的檔案中，連 VB 的 Help 中也是這樣！
或許是大家都認為資料庫主題的重點是在資料庫本身吧！
但是，在實際的資料庫程式運用中，卻常常需要将資料庫導出到各種不同的檔案類型的檔案中，這些檔案可能是 DBase檔案、文字檔案 (.Txt)、Excel 檔案、Html 檔案、Access 檔案或其他類型的資料庫檔案 (ODBC)...等。
在本專題中，考慮到并不是每一個人都有 Oracle 或 SQL Server 的環境，為了讓大家都能夠實作，我們将以 Access 資料庫來作練習，而練習的檔案也使用 VB 本身提供的 Biblio.mdb (位于各版本 VB 的目錄下)。
預計要練習導出的檔案類型有五種：DBase檔案、文字檔案 (.Txt)、Html 檔案、Excel 檔案、Access 檔案。除了這五種之外，下面的文法可以将資料庫之資料導出到任一種 VB 支援的資料庫或檔案中。
在練習之前，要将導出檔案的 SQL 文法先說明一下：
SELECT Table.Fields INTO [dbms type;DATABASE=path].[unqualified filename] FROM [Table or Tables]
SELECT Table.Fields INTO [資料庫種類;DATABASE=資料庫路徑].[資料庫檔案名稱] FROM [Table or Tables]
至于【資料庫種類】及【資料庫路徑】，視資料庫或檔案類型之不同而異，詳見【注一】。
如果上面說的都清楚了，那我們要開始這一個練習了！
在 Form 上放置一個 CommandButton，在【專案】【設定引用項目】中加入 Microsoft DAO 3.51 Object Library，我們将使用 Biblio.mdb 的 authors Table，在 Command1_Click 中加入以下程式碼：
Dim db As Database
Set db = Workspaces(0).OpenDatabase(App.Path & "/biblio.mdb")
'db.execute "SELECT Table.Fields INTO [dbms type;DATABASE=path].[unqualified filename] FROM [Table or Tables]"
在以上程式中，db.execute 指令行之指令依資料庫或檔案的種類說明如下：
一、DBase檔案
SQL 文法：SELECT * INTO [dBase III;DATABASE=資料庫路徑].[dbase檔案名稱] FROM [authors]
db.Execute "SELECT * INTO [dBase III;DATABASE=C:/test].[authors.DBF] FROM [authors]"
注意事項：
1、authors.DBF 事先不可存在，否則會産生錯誤！
2、若您沒有 Dbase，您可以使用 Access 來連結這個 Table，以便觀察結果！
二、文本檔案 (.Txt)
SQL 文法：SELECT * INTO [Text;DATABASE=文本檔案路徑].[文本檔案名稱] FROM [authors]
db.Execute "SELECT * INTO [Text;DATABASE=C:/test].[authors.TXT] FROM [authors]"
注意事項：
1、authors.TXT 事先不可存在，否則會産生錯誤！
2、此動作會産生的檔案有二個，第一個就是文本檔案 authors.TXT，第二個是 Schema.ini。
3、文本檔案之格式為 CSV 之檔案格式，即各欄位間以逗點分開，實際呈現方式如下：
"Au_ID","Author","Year Born"
1,"Jacobs, Russell",1950
2,"Metzger, Philip W.",1942
4、Schema.ini 若事先不存在會新産生一個，若已存在，則會在原檔案後面直接 Append。
5、至于 Schema.ini 的屬性為此次導出的相關資訊，格式同一般的 Ini 檔案，詳細屬性如下：
[authors.TXT]
ColNameHeader=True
CharacterSet=OEM
Format=CSVDelimited
Col1=Au_ID Integer
Col2=Author Char Width 50
Col3="Year Born" Short
三、Html 檔案
SQL 文法：SELECT * INTO [Excel 8.0;DATABASE=Html檔案路徑].[Html檔案名稱] FROM [authors]
db.Execute "SELECT * INTO [HTML Export;DATABASE=C:/test].[authors.HTM] FROM [authors]"
注意事項：
1、authors.HTM 事先不可存在，否則會産生錯誤！
2、此動作會産生的檔案有二個，第一個就是文本檔案 authors.HTM，第二個是 Schema.ini。
3、Schema.ini 若事先不存在會新産生一個，若已存在，則會在原檔案後面直接 Append。
4、至于 Schema.ini 的屬性為此次導出的相關資訊，格式同一般的 Ini 檔案，詳細屬性如下：
[authors.HTM]
ColNameHeader=True
CharacterSet=ANSI
Format=HTML
Col1=Au_ID Integer
Col2=Author Char Width 50
Col3="Year Born" Short
四、Excel 檔案
SQL 文法：SELECT * INTO [Excel 8.0;DATABASE=檔案路徑+檔案名].[工作表名稱] FROM [authors]
db.Execute "SELECT * INTO [Excel 8.0;DATABASE=C:/test/authors.XLS].[authors] FROM [authors]"
注意事項：
1、authors.XLS 可事先存在，也可以不存在，會自動産生一個。
2、工作表 authors 事先不可存在，否則會産生錯誤！
五、Access 檔案
SQL 文法：SELECT * INTO [新資料庫路徑+檔案名][新資料表名稱] FROM [authors]
'導出到同一資料庫 ( 新 Table 為 authors1 )
'新 Table authors1 事先不可存在，否則會産生錯誤！
db.Execute "SELECT * INTO [authors1] FROM [authors]"
'導出到不同的資料庫 ( 新資料庫為 db1，新 Table 為 authors )
'新資料庫 db1事先必須存在，否則會産生錯誤！
'但是其中新 Table authors 事先不可存在，否則會産生錯誤！
db.Execute "SELECT * INTO [C:/test/db1.mdb].[authors] FROM [authors]"
注一：各種可能的資料庫種類 Connect 屬性設定方式：
資料庫種類 資料庫聲明方式 資料庫路徑 (或加上檔案名)
Microsoft Jet Database [database]; drive:/path/filename.mdb
dBASE III dBASE III; drive:/path
dBASE IV dBASE IV; drive:/path
dBASE 5 dBASE 5.0; drive:/path
Paradox 3.x Paradox 3.x; drive:/path
Paradox 4.x Paradox 4.x; drive:/path
Paradox 5.x Paradox 5.x; drive:/path
Microsoft FoxPro 2.0 FoxPro 2.0; drive:/path
Microsoft FoxPro 2.5 FoxPro 2.5; drive:/path
Microsoft FoxPro 2.6 FoxPro 2.6; drive:/path
Microsoft Visual FoxPro 3.0 FoxPro 3.0; drive:/path
Microsoft Excel 3.0 Excel 3.0; drive:/path/filename.xls
Microsoft Excel 4.0 Excel 4.0; drive:/path/filename.xls
Microsoft Excel 5.0 or Microsoft Excel 95 Excel 5.0; drive:/path/filename.xls
Microsoft Excel 97 Excel 8.0; drive:/path/filename.xls
Lotus 1-2-3 WKS and WK1 Lotus WK1; drive:/path/filename.wk1
Lotus 1-2-3 WK3 Lotus WK3; drive:/path/filename.wk3
Lotus 1-2-3 WK4 Lotus WK4; drive:/path/filename.wk4
HTML Import HTML Import; drive:/path/filename
HTML Export HTML Export; drive:/path
Text Text; drive:/path
ODBC ODBC;
DATABASE=database;
UID=user;
PWD=password;
DSN= datasourcename;
[LOGINTIMEOUT=seconds;] None
Microsoft Exchange Exchange 4.0;
MAPILEVEL=folderpath; [TABLETYPE={ 0 | 1 }];[PROFILE=profile;]
[PWD=password;]
[DATABASE=database;] drive:/path/filename.mdb
148、模拟 Windows 的資源資源回收筒！
您現在将螢幕上所有的視窗全部縮小，找到資源資源回收筒，按滑鼠右鍵，選擇【屬性】，便會出現【資源資源回收筒】的屬性問話框。
其中有幾個選項如下：
1、不要将檔案移到資源資源回收筒，删除時立即移除檔案。
2、顯示删除确認對話框？
根據以上之狀況，檔案之删除有三種情形：
1、删除檔案，出現确認對話框，檔案移到資源資源回收筒。
2、删除檔案，出現确認對話框，檔案不移到資源資源回收筒。
3、删除檔案，不出現确認對話框，檔案也不移到資源資源回收筒。
模拟程式如下：
'在模組的聲明區中加入以下聲明：
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const FO_DELETE = &H3
Public Const FOF_ALLOWUNDO = &H40 '可以還原
Public Const FOF_NOCONFIRMATION = &H10 '不出現确認對話框
Public Const FOF_SILENT = &H4
'在程式中之使用方法如下：
'以下之例子會出現确認對話框，檔案也會移到資源資源回收筒。
Private Sub Command1_Click()
Dim SHop As SHFILEOPSTRUCT
Dim strFile As String '要删除的檔案(含全路徑)
strFile = "c:/test.txt"
With SHop
.wFunc = FO_DELETE
.pFrom = strFile
.fFlags = FOF_ALLOWUNDO
End With
SHFileOperation SHop
End Sub
'若要調整，隻要更改 fFlags 之值即可，如下：
.fFlags = FOF_SILENT '删除檔案，出現确認對話框，檔案不移到資源資源回收筒。
.fFlags = FOF_NOCONFIRMATION '删除檔案，不出現确認對話框，檔案也不移到資源資源回收筒。
149、如何得到檔案路徑的檔案名
Dim sFilePath As String
sFilePath = "C:/Windows/System/sytem.dll"
Dim lGetLen As Long, lNum As Long
Dim sGetFile As String, sTemp As String
lGetLen = Len(sFilePath) '得到檔案路徑長度
sTemp = lGetLen
For lNum = 1 To lGetLen
If Left(sGetFile, 1) = "/" Then Exit For
sGetFile = Mid(sFilePath, sTemp, lNum)
sTemp = sTemp - 1
Next lNum
sGetFile = Mid(sGetFile, 2) '得到檔案名
MsgBox sGetFile
150、如何用VB準确計算年齡
Function CalcAge(datEmpDateOfBirth as Variant) as Integer
CalcAge = Int(DateDiff("y",datEmpDateOfBirth,Date())/365.25)
End Function
151、如何算出螢幕的分辨率？
如果不使用 Third Party 的控制項，而希望程式的畫面能随著螢幕的分辨率而自動調整各個控制項的位置及大小，其中最重要的一件事，便是算出目前執行程式的螢幕之分辨率！
而分辨率要如何算呢？看看以下的程式便可知道！
ResWidth = Screen.Width / Screen.TwipsPerPixelX
ResHeight = Screen.Height / Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
ResWidth 就是指螢幕分辨率中的寬
ResHeight 就是指螢幕分辨率中的長
而最後算出的 ScreenRes，格式會像 800x600 一樣！
除了 800x600 之外，可能還有 640x480、1024x768....等。
152、如何産生一個多行式的提示框 (ToolTipText)？
VB5 以後的 VB 版本都有提供一個屬性 -- ToolTipText，目的是讓使用者在執行階段，滑鼠在物件上徘徊約一秒時，就将該物件的提示字串顯示在該物件下面的一個小長方形中，以協助使用者做輸入動作。
有時候說明字串太長了，于是就有人想将提示字串分行顯示，而且自然而然的使用 vbNewLine (=vbCrLf 或 =vbCr ) 來換行，因為根據以往的經驗，VB都是這樣做換行的，可是這一次很多人都踢到鐵闆了！
VB 用來顯示 ToolTipText 的提示框，其實是一個文字框，而且 MultiLine 屬性并沒有設為 True，您可以自己用一個單行式的文字框來做測試，就算您用 vbCrLf 來換行也不會有作用的！
既然 VB 提供的 Default 功能不能滿足我們的需求，而我們又想提供使用者多行式的提示框，那要怎麼辦呢？其實也不難，我們自己動手 DIY 一下就有了，而且程式碼也不長！
'首先在 Form 上放一個 Timer (如果需要的話)，以便于叫出突現式說明框
Private Function TimeOut(pInterval As Single)
Dim sngTimer As Single
sngTimer = Timer
Do While Timer < sngTimer + pInterval
DoEvents
Loop
End Function
'然後在 Form 上放一個 Label，取名為 lblToolTip，在 MouseMove 中加入以下程式：
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lbltooltip.Visible = False
End Sub
'在您想顯示說明框的物件加入以下程式碼： ( Textbox, listbox etc. )
Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
TimeOut 0.3 '滑鼠移到物件上多久後,要顯示提示框
lbltooltip.Caption = "大家好 !!" & vbCrLf & "" & vbCrLf & _
"您目前看到的黃色标簽" & vbCrLf & "是一個多行式的提示框"
lbltooltip.Left = Text1.Left + lbltooltip.Width
lbltooltip.Top = Text1.Top + Text1.Height
lbltooltip.Visible = True
End Sub
153、如何改變螢幕的分辨率？
如果希望使用者在跑我們開發的應用程式時，看到的畫面的樣子和我們在 Design Time 時一樣的話，我們往往需要處理螢幕分辨率的問題，才能使程式的畫面能随著螢幕的分辨率而自動調整各個控制項的位置及大小，但是這樣子往往會使程式複雜化！
除了以上這樣子，将就使用者螢幕分辨率大小的民主式做法之外，您還有一個選擇，那就是強制改掉使用者螢幕分辨率大小的暴權式做法，如果真的可以這麼做，您根本就不用再去處理分辨率的問題了！
在讨論區中，不時有人問到如何改變螢幕分辨率的大小，這是因為在 VB 32位元的 API 檢視員中漏掉了有關 EnumDisplaySettings、ChangeDisplaySettings 的常數及宣告。
'在模組中加入以下宣告、常數、型态：
Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
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
'假設現在我們希望将分辨率改成 800X600，但是不要改變色闆 ，程式如下：
'注：色闆指的就是 16色 / 256色 / High Color (16Bit) / True Color (24Bit)
Private Sub Command1_Click()
Dim DevM As DEVMODE '将取得的訊息存放在 DevM
erg& = EnumDisplaySettings(0&, 0&, DevM)
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL
DevM.dmPelsWidth = 800 '想要設定的螢幕寬度
DevM.dmPelsHeight = 600 '想要設定的螢幕高度
'我們不更改色闆，因為一旦更改色闆就必須重新開機！
'DevM.dmBitsPerPel = 32 (could be 8, 16, 32 or even 4) '此行可用于改變色闆
'以下這行指令會暫時更改螢幕的分辨率，是測試性的，不一定成功，
'不過因為沒将設定值寫到系統資料庫，是以雖然可能更改成功，
'但是一旦重新開機後，會自動恢複成更改前的設定值
erg& = ChangeDisplaySettings(DevM, CDS_TEST)
'上面的指令若成功，而且您想永久性的更改使用者的螢幕分辨率，
'您還必須使用下一行指令，将資料寫到系統資料庫
'erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
'但是如果您隻是想暫時更改使用者的螢幕分辨率，就不需要了.
'當然并不是您随便設定一個值，就一定會成功的更改螢幕分辨率,
'是以還需要檢查是否更改成功！下面的程式就是檢查是否更改成功
Select Case erg&
Case DISP_CHANGE_RESTART
'通常如果有更改到色闆，或者較老的闆子，會要求重新開機
an = MsgBox("您必須重新開機！", vbYesNo + vbSystemModal, "訊息")
If an = vbYes Then
erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
'如果更改成功且不需重新開機，您就可以将設定值寫到系統資料庫中
erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
MsgBox "分辨率更改成功！", vbOKOnly + vbSystemModal, "成功！"
Case Else
'更改不成功
MsgBox "不支援此一模式！", vbOKOnly + vbSystemModal, "錯誤！"
End Select
End Sub
154、如何在程式中啟動 NT 的【撥号網絡連接配接】對話框？
在【問題125】如何在程式中啟動【撥号網絡連接配接】對話框？我告訴大家如何在 VB 中用 Shell 去叫出【撥号網絡連接配接】對話框，程式碼如下：
Private Sub Command1_Click()
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " & "撥号網絡連接配接名稱", 1)
End Sub
但是有網友反應，用上述的方法隻有在 Windows 95/98 中才行得通，一碰到 Windows NT 可就沒辄了！今天，我要告訴大家在 Windows NT 中，要如何做到相同的事情。不難，方法如下：
Private Sub Command1_Click()
Dim res
res = Shell("rasphone.exe [-d 撥号網絡連接配接名稱]", 1)
End Sub
155、如何使用 ADO 來壓縮或修複 Microsoft Access 檔案
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來壓縮 Microsoft Access 檔案，RepairDatabase Method 來修複損壞的 Microsoft Access 檔案，。可是自從 ADO 出來之後，好像忘了提供相對的壓縮及修複 Microsoft Access 檔案的功能。
現在 Microsoft 發現了這個問題了，也提供了解決方法，不過有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
這個功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 檔案在您安裝了 MDAC 2.1 之後就有了，您可以在以下的網頁中下載下傳 MDAC 的最新版本！
Universal Data Access Web Site
在下載下傳之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已經是 2.1 以上的版本，您就可以不用下載下傳了！
在您安裝了 MDAC 2.1 或以上的版本之後，您就可以使用 ADO 來壓縮或修複 Microsoft Access 檔案，下面的步驟告訴您如何使用 CompactDatabase Method 來壓縮 Microsoft Access 檔案：
1、建立一個新表單，選擇功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适當的地方加入以下的程式代碼，記得要修改 data source 的內容及目地檔案的路徑：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://nwind2.mdb", _ '來源檔案
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d://abbc2.mdb;Jet OLEDB:Engine Type=4" '目的檔案
在 DAO 3.60 之後，RepairDatabase Method 已經無法使用了，以上的程式代碼顯示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
156、如何建立可卷動的圖形框？
在各網站的讨論區中常有人問到這個問題，其實答案就在 Msdn 中！以下資料由 Msdn 節錄：
除了圖檔方塊控制項之外，也可用水準、垂直卷軸來建立可卷動的圖形框應用程式。當所包含的圖形超過控制項範圍時，單獨一個圖檔方塊控制項無法制作卷動功能─ 因為圖檔方塊控制項無法自動新增卷軸。應用程式使用兩個圖檔方塊。稱第一個為平穩的父圖檔方塊控制項。第二個為子圖檔方塊控制項，它包含在父圖檔方塊中。子圖檔方塊中包含圖形影像，可用卷軸控制項在父圖檔方塊中搬動子圖檔方塊。
先建立一個新工程，然後在表單上繪制兩個圖檔方塊、一個水準卷軸和一個垂直卷軸。位置随便放，這裡，用表單的 Form_Load 事件設定比例模型，在父圖檔方塊中調整子圖檔方塊的大小，水準、垂直卷軸，搜尋并調整它們的大小，然後載入點陣圖圖形。将下列程式碼新增到表單的 Form_Load 事件程式中：
修正：避開 Form_Resize 産生的錯誤，将程式模組化，并加上範例程式。
Private Sub init_object()
'初始化兩個圖檔方塊的位置。
Picture1.Move 0, 0, ScaleWidth - VScroll1.Width, ScaleHeight - HScroll1.Height
Picture2.Move 0, 0
'将水準卷軸搜尋。
HScroll1.Top = Picture1.Height
HScroll1.Left = 0
HScroll1.Width = Picture1.Width
'将垂直卷軸搜尋。
VScroll1.Top = 0
VScroll1.Left = Picture1.Width
VScroll1.Height = Picture1.Height
'設定卷軸的 Max 屬性。
HScroll1.Max = Picture2.Width - Picture1.Width
VScroll1.Max = Picture2.Height - Picture1.Height
'判斷子圖檔方塊是否将充滿螢幕。若如此，則無需使用卷軸。
VScroll1.Visible = (Picture1.Height < Picture2.Height)
HScroll1.Visible = (Picture1.Width < Picture2.Width)
End Sub
Private Sub Form_Load()
'設定 ScaleMode 為像素。
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
'将 Autosize 設定為 True，以使 Picture2 的邊界延伸到實際的點陣圖大小。
Picture2.AutoSize = True
'将每個圖檔方塊的 BorderStyle 屬性設定為 None。
Picture1.BorderStyle = 0
Picture2.BorderStyle = 0
'載入點陣圖。 此處請自行更改圖檔
'Picture2.Picture = LoadPicture("c:/Windows/ham.bmp")
'初始化各物件
init_object
End Sub
水準和垂直卷軸的 Change 事件，用在父圖檔方塊中上、下、左、右移動子圖檔方塊。請将下列程式碼新增到兩個卷軸控制項的 Change 事件中：
Private Sub HScroll1_Change()
Picture2.Left = -HScroll1.Value
End Sub
Private Sub VScroll1_Change()
Picture2.Top = -VScroll1.Value
End Sub
将子圖檔方塊的 Left 和 Top 屬性分别設定成水準和垂直卷軸數字的負值，這樣，當上、下、左、右卷動時，圖形可以正确移動。
執行階段中，顯示的圖形如上圖所示。
在執行階段調整表單大小
在上例中，表單的初始大小限制圖形的可視大小。在執行階段中，當使用者調整表單大小時，為了調整圖形視域應用程式的大小，可将下列程式碼新增到表單的 Form_Resize 事件程式中：
Private Sub Form_Resize()
'重新初始化各物件
'避開表單最小化的情況
If Me.WindowState <> 1 Then init_object
End Sub
157、如何偵測目前文字框中共有幾行？
要判斷文字框中目前有幾行，可以使用回圈判斷共有幾個換行字元來取得，但是在這兒我們要使用 API 來做到這個功能！
'請在 Form 中放一個 TextBox 及一個 label，在聲明區中加入以下聲明：
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
Const EM_GETLINECOUNT = &HBA
'在 Text1 的 Change 事件中加入以下程式碼：
Sub Text1_Change()
Dim lineCount As Long
On Local Error Resume Next
'立刻偵測目前文字框中共有幾行
lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
Label1 = "文字框中共有 " & Format$(lineCount, "##,###") & " 行"
End Sub
158、如何判斷使用者電腦中系統字型大小？
在【問題】如何算出螢幕的分辨率？我們提到：如果希望使用者在跑我們開發的應用程式時，看到的畫面的樣子和我們在 Design Time 時一樣的話，我們往往需要處理螢幕分辨率的問題。
除了螢幕的分辨率之外，電腦中設定的字型大小是大字型 ( Large Font ) 或小字型 ( Small Font ) 或其他大小的自訂字型，也是一個影響的因素，要如何偵測電腦中的字型大小呢？
由【控制台】的【顯示器】【設定】頁簽中，我們可以得知以下訊息：
大字型 ( Large Font )：120 dpi
小字型 ( Small Font )：96 dpi
以下之程式可以判斷系統是否使用小字型，當然大字型之判斷方式也相同：
請在模組中加入以下聲明及模組：
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Const LOGPIXELSX = 88
Public Function IsScreenFontSmall() As Boolean
Dim hWndDesk As Long
Dim hDCDesk As Long
Dim logPix As Long
Dim r As Long
hWndDesk = GetDesktopWindow()
hDCDesk = GetDC(hWndDesk)
logPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)
r = ReleaseDC(hWndDesk, hDCDesk)
IsScreenFontSmall = (logPix = 96)
End Function
在程式中呼叫 IsScreenFontSmall 若傳回值為 True 即為小字型。
159、使用 Label 模拟資料總管左右視窗中的調整杆 ( Splitter )
要模拟這個功能，有很多種不同的作法，今天我們要使用一個 Label 控制項來分割分别放在左右的 TreeView 及 ListView，整個動作的重點在于，當我們在分隔線上按下滑鼠左鍵時，就準備調整視窗中各控制項的大小，當我們放開滑鼠左鍵時，就停止調整的動作！
'在 Form 中放入一個 Label，一個 TreeView 及 一個 ListView，位置不拘，并加入以下程式碼：
Private mbResizing As Boolean '判斷是否按下滑鼠左鍵 (準備調整大小)
Private Sub Form_Load()
'設定 TreeView1 為螢幕 1/3,ListView1 為螢幕 2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3, Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0, (Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth / 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End Sub
Private Sub Form_Resize()
'設定 TreeView1 為螢幕 1/3,ListView1 為螢幕 2/3
TreeView1.Move 0, 0, Me.ScaleWidth / 3, Me.ScaleHeight
ListView1.Move (Me.ScaleWidth / 3) + 50, 0, (Me.ScaleWidth * 2 / 3) - 50, Me.ScaleHeight
Label1.Move Me.ScaleWidth / 3, 0, 100, Me.ScaleHeight
Label1.MousePointer = vbSizeWE
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'準備調整大小
If Button = vbLeftButton Then mbResizing = True
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'按下滑鼠左鍵并移動時, 自動調整各控制項大小
If mbResizing Then
Dim nX As Single
nX = Label1.Left + X
If nX < 500 Then Exit Sub
If nX > Me.ScaleWidth - 500 Then Exit Sub
TreeView1.Width = nX
ListView1.Left = nX + 50
ListView1.Width = Me.ScaleWidth - nX - 50
Label1.Left = nX
End If
End Sub
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'停止調整大小
mbResizing = False
End Sub
160、【萬用檔案搜尋器】--- 将 Windows 的【尋找檔案】功能套進 VB 中
這個 Walkdir 模組可以讓您從任何一個目錄往下所有目錄中找尋符合您要求的所有檔案！根據實際測試的結果，搜尋檔案的速度和 Windows 的【尋找檔案】功能不相上下，有時甚至更快呢！
共有三個參數說明如下：
1、檔案類型：可接受萬用字元 *，可同時設定多個類型(中間用分号隔開)，例如 ( OLE*.DLL; *.TLB )
2、開始目錄：可以是根目錄。
3、字串陣列：用來存放符合的檔案名稱 (全路徑檔案名)，是一個動态陣列。
這個模組會使用遞回的方式一層一層的搜尋所有的子目錄，找出所有符合條件的檔案，并将檔案名稱 (含全路徑) 放入字串陣列中，這個陣列的大小會自動根據找到的檔案個數而自動調整，最後陣列的大小就是找到的檔案個數！
要實際使用這個模組，您必須先在 Form 中放入一個 DirListBox 及一個 FileListBox，分别取名為 Dir1 及 File1，最好将這二個控制項的 Visible 屬性設成 False，可以大大加快搜尋的速度。
'以下是使用的範例： ( 要一個 CommandButton 及一個 ListBox )
Private Sub Command1_Click()
ReDim sarray(0) As String
'找尋 Windows 目錄下檔案類型為 OLE*.DLL 的所有檔案
Call DirWalk("OLE*.DLL", "C:/windows", sarray)
'将陣列的資料放到 List1 中
Dim i As Integer
For i = LBound(sarray) To UBound(sarray) - 1
List1.AddItem sarray(i)
Next
End Sub
'模組内容如下：
Sub DirWalk(ByVal sPattern As String, ByVal CurrDir As String, sFound() As String)
Dim i As Integer
Dim sCurrPath As String
Dim sFile As String
Dim ii As Integer
Dim iFiles As Integer
Dim iLen As Integer
If Right$(CurrDir, 1) <> "/" Then
Dir1.Path = CurrDir & "/"
Else
Dir1.Path = CurrDir
End If
For i = 0 To Dir1.ListCount
If Dir1.List(i) <> "" Then
DoEvents
Call DirWalk(sPattern, Dir1.List(i), sFound())
Else
If Right$(Dir1.Path, 1) = "/" Then
sCurrPath = Left(Dir1.Path, Len(Dir1.Path) - 1)
Else
sCurrPath = Dir1.Path
End If
File1.Path = sCurrPath
File1.Pattern = sPattern
If File1.ListCount > 0 Then
'在目錄中找到符合的檔案
For ii = 0 To File1.ListCount - 1
ReDim Preserve sFound(UBound(sFound) + 1)
sFound(UBound(sFound) - 1) = sCurrPath & "/" & File1.List(ii)
Next ii
End If
iLen = Len(Dir1.Path)
Do While Mid(Dir1.Path, iLen, 1) <> "/"
iLen = iLen - 1
Loop
Dir1.Path = Mid(Dir1.Path, 1, iLen)
End If
Next i
End Sub
161、如何移除 MDIForm 的 Max/Min Button？
不像其他的 Form 一樣，MDIForm 并沒有提供 MaxButton 及 MinButton 的屬性來讓我們移除最大化及最小化的按鈕，如果您想移除 MDIForm 的最大化及最小化的按鈕，您可以在 MDIForm 中加入以下的程式，但是如果您隻想移除其中的一個，則隻要将對應的程式碼加上注解符号即可。
'請在 MDIForm 的聲明區中加入以下聲明
#If Win32 Then
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
#Else
Private Declare Function SetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
#End If
Const WS_MINIMIZEBOX = &H20000 '最小化
Const WS_MAXIMIZEBOX = &H10000 '最大化
Const GWL_STYLE = (-16)
'在 MDIForm 的 MDIForm_Load 事件中加入以下程式碼
Sub MDIForm_Load()
Dim lWnd As Long
lWnd = GetWindowLong(Me.hwnd, GWL_STYLE)
lWnd = lWnd And Not (WS_MINIMIZEBOX) '最小化
lWnd = lWnd And Not (WS_MAXIMIZEBOX) '最大化
lWnd = SetWindowLong(Me.hwnd, GWL_STYLE, lWnd)
End Sub
162、如何防止 Form 被移動？
有些應用程式，我們希望固定 Form 的位置，不希望使用者移動它，在 VB5 以上的版本，我們可以直接在屬性表中設定 Form 的 Moveable 屬性為 False 即可。
但是 VB4 以下的版本卻沒有這個功能，這時就得借助 API 的功能了！而我們實際要做的，就是移除系統功能表 ( ControlBox ) 中的【移動】的功能，您可以檢查一下您現在使用的浏覽器左上方的系統功能表，【移動】的位置是第二個，是以 Index = 1 ( index 由 0 算起 )。
'請在表單的聲明區中加入以下聲明
Private Declare Function GetSystemMenu Lib "User" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
Private Declare Function RemoveMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Const MF_BYPOSITION = &H400
'在 Form_Load 事件中加入以下程式碼
Private Sub Form_Load()
SystemMenu% = GetSystemMenu(hWnd, 0)
Res% = RemoveMenu(SystemMenu%, 1, MF_BYPOSITION) <--- 第二個參數是 Index
End Sub
163、如何設定 ComboBox 之最大長度？
在文字框 (TextBox) 中，我們可以設定 MaxLength 屬性來設定文字框可輸入的最大長度，但是同樣具有一個文字框的 ComboBox，卻沒有提供這樣的功能！要做到這個功能，必須自己寫程式來判斷。
'下面就是一個範例程式：
'我們在 Key_Press 事件來處理，程式中假設最大長度為 10，并已将倒退鍵排除在外
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Const MAXLENGTH = 10 '設定最大長度為 10
If Len(Combo1.Text) >= MAXLENGTH And KeyAscii <> vbKeyBack Then
KeyAscii = 0
End If
End Sub
164、如何撰寫沒 Form 的程式？
一般在撰寫 VB 的程式時，由于一進入 VB 的環境時就會自動産生一個 Form1，而 VB 本身又是一種事件驅動程式，是以有些人一直認為 VB 的程式一定會有一個以上的 Form 存在。其實 VB 也可以撰寫一些完全沒有表單 (Form) 的程式。
撰寫的方法如下：
1、啟動一個新的工程 (Project)
2、移除 Form1
3、開啟一個 Module (名稱可自取，或使用 Default 名稱 Module1)
4、在 Module 中加入一段名為 Main 的 SubRoutine (名稱一定要取為 Main)
'例：下面的程式執行時會開啟 c:/test.txt 并寫入一個數字，然後直接結束，沒有任何表單。
Public Sub Main()
Open "c:/test.txt" For Output As #3
Print #3, 6666
Close #3
End '可有可無,會自動結束
End Sub
165、别讓 MsgBox 中斷了一些 Background 的處理作業
在 VB 中，一旦您呼叫了 MsgBox，您正在執行的一些 Background 的處理作業，例如計數器或時鐘...等，都會停下來，直到您回應了 MsgBox 之後，一切才會恢複正常！或許您并不希望如此，這也有可能造成一些不必要的錯誤！
要解決這個問題，您必須使用 Windows API 去呼叫 MessageBox Function，它的使用方法、外觀和 MsgBox 的結果完全相同，但是它卻不會中斷一些 Background 的處理作業！
在以下的範例中，您要在 Form 中加入一個 Label、二個 CommandButton 及一個 Timer，不更改任何屬性。
'在聲明區中加入以下聲明：
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
'加入以下程式碼：
Private Sub Command1_Click()
MsgBox "計時器停掉了！", 64, "VB 的訊息框"
End Sub
Private Sub Command2_Click()
MessageBox Me.hwnd, "注意！計時器還在跑！", "API 的訊息框", 64
End Sub
Private Sub Form_Load()
Timer1.Interval = 1000
Label1.Caption = "目前的時間是：" & Time
End Sub
Private Sub Timer1_Timer()
Label1.Caption = "目前的時間是：" & Time
End Sub
166、如何找出 Windows / System / Temp 目錄的正确路徑？(二)
記得我們分三個單元來說明如何找出 Windows / System / Temp 目錄的正确路徑？
當時我們都是使用 API 來做，使用的 API 分别是：
問題 如何找出 Windows 目錄的正确路徑？
使用 GetWindowsDirectory Function
問題 如何找出 System 目錄的正确路徑？
使用 GetSystemDirectory Function
問題 如何找出 Temp 目錄的正确路徑？
使用 GetTempPath Function
有的人不太喜歡使用 API，一來有的 API 有點難，一來比較不容易找到完整的資料說明或完整的範例。不過以上三個題目都可以不使用 API 就得到答案的！原因如下：
在我們啟動電腦的同時，我們的作業系統，會挪出一個區塊，用來存放一些系統環境變量，或許您會問，到底存了哪些東西呢？其實說來不外乎幾個來源：
1、Autoexec.bat：TMP / TEMP / PATH / PROMPT .....
2、Config.sys：COMSPEC .....
3、Msdos.sys：WinDir / WinBootDir .....
4、當然您的電腦中不一定有 Autoexec.bat 或 Config.sys，不過沒關系，系統自己會給定一些初始值！
而這些環境變量，在 VB 中隻要使用 ENVIRON Statement 就可以抓得到！文法如下：
Environ[$](environmentstring)
其中 environmentstring 是一個環境變量的字串，例如：〈TEMP〉、〈WinDir〉、〈PATH〉...等。
是以，如果您 .....
要得到 TEMP 的路徑，隻要使用 Environ("TEMP") 即可，結果可能為 C:/WINDOWS/TEMP。
要得到 Windows 的路徑，隻要使用 Environ("Windows") 即可，結果可能為 C:/WINDOWS。
而如果您想找到 System 的路徑，我想有了 Windows 路徑之後，應該不是難事了吧！
167、如何将長檔案名轉成短檔案名格式 (MS-DOS 8.3)
雖然在 Windows95/98 中已經都可以使用長檔案名/目錄 (最長可以到255個字元)，但是在您将長檔案名的檔案或目錄存檔時，系統同時給了它一個可以相容于以前 MS-DOS 時代的 8.3 格式的檔案名稱！
到目前為止，還是有些軟體會使用 8.3 格式的檔案名稱，在安裝這些軟體時，它們寫到系統資料庫中的資料，仍然采用 8.3 格式的檔案名稱，是以有時候，您在維護系統時，必須知道目前這時長檔案的檔案，轉成 8.3 格式的檔案名稱之後是什麼檔案。
以下這個範例會讓您在 DirListBox 及 FileListBox 中選擇目錄及檔案名稱，然後将您選出的(長)檔案名轉成 8.3 格式的檔案名稱，如果您有注意到的話，它不但是将檔案名稱轉掉，連長檔案的目錄名稱也會一起轉成 8.3 格式的檔案名稱。
由于程式碼較長，我不再列出程式碼，而直接将檔案壓縮下載下傳：
Source Code 下載下傳
168、清除畫面中各欄位資料
當一個 Form 中隻有二、三個物件的時候，您要清除其中的資料，您會一個欄位一個欄位來清除，反正就是那麼幾個物件，二三行指令也就解決了！
但是，若您的 Form 中有二、三十個，甚至五、六十個以上的物件時，可就要想想辦法了！以下的這個模組就在這種情形下産生了，一般要清除資料，最重要的二個屬性就是 .Text 及 .LisIndex。
Public Sub ClearAllControls(frmFORM As Form)
Dim ctlControl As Object
On Error Resume Next
For Each ctlControl In frmFORM.Controls
ctlControl.Text = ""
ctlControl.ListIndex = -1
DoEvents
Next
End Sub
而在程式中要呼叫這個模組隻要如下使用即可：
call ClearAllControls(Me)
169、為您精心設計的畫面拍張快照吧！( Taking a screenshot )
我們在設計系統時，有時候會保留讓使用者做螢幕 HardCopy 的功能。
以前，我總是要求使用者自己去按鍵盤上的【Print Screen】按鈕，将畫面的影像留在【剪貼闆】中，并要求使用者自己到 Windows95/98 提供的【小畫家】或【小作家】中，先做【貼上】的動作後，再将畫面影像存成 .BMP 檔或直接由印表機中印出。
上面這些動作，對一個程式開發者，或一個熟練的操作者并不困難，但是，很可悲的，大部份的使用者都不屬于以上所描述的二種人，例如：我曾經寫過一個系統是給大樓清潔維護公司的人員用的，其中有很多使用者甚至是一些學曆不高的『歐巴尚』，不但程式的設計都要簡化操作，連系統上線都是高難度的，更别說螢幕的 HardCopy 列印、存檔的動作了！
不過，以上的動作，我們都可以直接在 VB 的程式中做到，要做到這個功能有二個方法：
方法一：直接模拟按【Print Screen】按鈕，再将【剪貼闆】中的圖像抓到 Picture 中。
方法二：完全使用 API 來處理。
下面來看看第二種做法：
'請在聲明區中加入以下聲明：
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc 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 Const SRCCOPY = &HCC0020
'在 Form 中加入二個 CommandButton，及一個 PictureBox，不必更改屬性，加入以下程式碼：
Private Sub Form_Load()
'将 Picture1 之長寬設定成和螢幕一樣大小
Picture1.Width = Screen.Width
Picture1.Height = Screen.Height
End Sub
Private Sub Command1_Click()
'将螢幕畫面抓下後放到 Picture1 中
Dim lngDesktopHwnd As Long
Dim lngDesktopDC As Long
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
lngDesktopHwnd = GetDesktopWindow
lngDesktopDC = GetDC(lngDesktopHwnd)
Call BitBlt(Picture1.hdc, 0, 0, Screen.Width, Screen.Height, lngDesktopDC, 0, 0, SRCCOPY)
Picture1.Picture = Picture1.Image
Call ReleaseDC(lngDesktopHwnd, lngDesktopDC)
End Sub
Private Sub Command2_Click()
'将 Picture1 中的螢幕畫面存成 .BMP 檔
SavePicture Picture1, "C:/TEST.BMP"
End Sub
在以上的範例中，隻要按下 Command1 就會将螢幕的畫面截取下來放到 Picture1 中，按下 Command2 之後，就會将 Picture1 中的圖檔存成檔案 ( 檔案名稱可自行更改 )，如果您想列印，也可以直接使用 PaintPicture 将圖檔丢到列印機中打出！
至于圖檔的列印，以後會另有單元介紹。
170、随心所欲地移除表單左上方的系統功能表的某幾個項目
針對這個主題，其實以前已經讨論過二次了，隻不過不是以這樣直接了當的方式點出在題目中而已，不知道大家是否有印象？
這二次分别是：
問題：如何移除 Form 右上方之『X』按鈕？
對應到系統功能表的【關閉】選項
問題：如何防止 Form 被移動？
對應到系統功能表的【移動】選項
而我在網路上閑逛時，看到有個外國人用了一個很笨的方法寫了一個模組，不過對于不想研究 API 的人來說應該是很好用的模組，可以讓您用選擇的方式随便您想移除系統功能表的任一個項目！
完整程式碼如下，說明加在其中：
'在聲明區中加入以下聲明：
'抓取系統 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
'移除系統 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
'第一個參數是系統 Menu 的 hwnd
'第二個參數是要移除選項的 Index
Private Const MF_BYPOSITION = &H400&
'模組内容如下：
Private Sub RemoveMenus(frm As Form, remove_restore As Boolean, remove_move As Boolean, remove_size As Boolean, remove_minimize As Boolean, remove_maximize As Boolean, remove_seperator As Boolean, remove_close As Boolean)
Dim hMenu As Long
' 抓取系統 Menu 的 hwnd
hMenu = GetSystemMenu(hWnd, False)
If remove_close Then RemoveMenu hMenu, 6, MF_BYPOSITION '是否移除【關閉】選項
If remove_seperator Then RemoveMenu hMenu, 5, MF_BYPOSITION '是否移除【分隔線】
If remove_maximize Then RemoveMenu hMenu, 4, MF_BYPOSITION '是否移除【放到最大】選項
If remove_minimize Then RemoveMenu hMenu, 3, MF_BYPOSITION '是否移除【縮到最小】選項
If remove_size Then RemoveMenu hMenu, 2, MF_BYPOSITION '是否移除【大小】選項
If remove_move Then RemoveMenu hMenu, 1, MF_BYPOSITION '是否移除【移動】選項
If remove_restore Then RemoveMenu hMenu, 0, MF_BYPOSITION '是否移除【還原】選項
End Sub
這個模組共有八個參數，第二個到第八個參數分别對應到系統功能表的七個選項！ ( True / False )
今天如果我想做到和問題如何移除 Form 右上方之『X』按鈕？一樣的結果，表示我要将對應到系統功能表的【關閉】選項移除，則我隻要将相對應的參數設成 True 即可，其他要保留的則為 False。
範例如下：
Private Sub Form_Load()
RemoveMenus Me, False, False, False, False, False, True, True
End Sub
VB問題全功略（35） [查找本頁請按Ctrl+F]
［上一頁］（35）［下一頁］
171、如何防止使用者按下 CTRL + ALT + DEL
172、如何将 Excel 的資料表導入 Access資料庫？
173、取得個人電腦中的設定資訊
174、您想知道有誰正在使用您的 Access 資料庫嗎？
175、為何聲明資料庫型态變量時出現《編譯錯誤：使用者自訂型态尚未定義》
171、如何防止使用者按下 CTRL + ALT + DEL
有些時候，我們的應用程式執行時，不希望使用者按下 CTRL + ALT + DEL 來異常結束程式或關機，這時候我們可以在啟動程式時，将 CTRL + ALT + DEL 功能鍵之功能取消，然後在結束程式之前，再從新恢複 CTRL + ALT + DEL 之功能。
在模組聲明區中加入以下聲明及模組：
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SCREENSAVERRUNNING = 97
Public Sub Disable_Ctrl_Alt_Del()
'讓 CTRL+ALT+DEL 失效
Dim AyW As Integer
Dim TurFls As Boolean
AwY = SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, TurFls, 0)
End Sub
Public Sub Enable_Ctrl_Alt_Del()
'讓 CTRL+ALT+DEL 恢複功能
Dim AwY As Integer
Dim TurFls As Boolean
AwY = SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, TurFls, 0)
End Sub
'實際使用時，在 Form 中加入以下程式碼：
Private Sub Form_Load()
Disable_Ctrl_Alt_Del
End Sub
Private Sub Form_Unload(Cancel As Integer)
Enable_Ctrl_Alt_Del
End Sub
172、如何将 Excel 的資料表導入 Access資料庫？
将程式碼做成模組，隻要傳入必要之參數即可！
此一模組共有四個參數：
1、sSheetName：要導出資料的資料表名稱 (Sheet name)，例如 Sheet1
2、sExcelPath：要導出資料的 Excel 檔案路徑名稱 (Workbook path)，例如 C:/book1.xls
3、sAccessTable：要導入的 Access Table 名稱，例如 TestTable
4、sAccessDBPath：要導入的 Access 檔案路徑名稱，例如 C:/Test.mdb
在聲明區中加入以下聲明：
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table exported successfully.", vbInformation, "Yams"
End Sub
使用範例如下：将 C:/book1.xls 中的 Sheet1 導入 C:/Test.mdb 成為 TestTable
ExportExcelSheetToAccess "Sheet1", "C:/book1.xls", "TestTable", "C:/Test.mdb"
173、取得個人電腦中的設定資訊
許多在控制台中的設定，如果在 VB 的程式中需要知道的話，我們都可以透過 GetLocaleInfo 這個 API 來取得！以下我們已經将它模組化 (WinLocaleInfo)，隻 傳入一個參數即可得到解答！
在聲明區中加入以下的聲明及模組：
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Public Function WinLocaleInfo(ByVal lnfoType As Long) As String
Dim sLCData As String
Dim nRet As Long
nRet = GetLocaleInfo(0, lnfoType, sLCData, 0)
If nRet Then
sLCData = Space$(nRet)
nRet = GetLocaleInfo(0, lnfoType, sLCData, Len(sLCData))
If nRet Then
WinLocaleInfo = Left$(sLCData, nRet)
End If
End If
End Function
實際在運用時，可傳入的參數相當多，連我也不知道到底有多少個，不過别擔心，隻要在 VB 附的 API 檢視員中就可以找到所有可以傳入的參數了！這些參數有一個共通點，都是以 "LOCALE_" 為開頭字串，以下舉幾個例子給大家看看：
LOCALE_SCURRENCY = &H14 ' 貨币符号
LOCALE_SDATE = &H1D ' 日期分隔字元
LOCALE_SDAYNAME1 = &H2A ' 完整星期名稱
LOCALE_SDECIMAL = &HE ' 小數點符号
'以下是一個執行個體：
Private Sub Command1_Click()
Text1 = WinLocaleInfo(&H14) '可能傳回 NT$
Text2 = WinLocaleInfo(&H1D) '可能傳回 /
Text3 = WinLocaleInfo(&H2A) '可能傳回 星期一
Text4 = WinLocaleInfo(&HE) '可能傳回 .
End Sub
174、您想知道有誰正在使用您的 Access 資料庫嗎？
如果您使用 Access 建立了一個多人使用的資料庫環境，有時候您必須要知道有誰正在使用程式連進這個共享的資料庫，但是您又不想因為如此而要建立一套完整的 Access 安全系統，您有二個選擇：
第一個：
您可以在資料庫中建立一個 "Login Table"，每次使用者進入或離開系統時就 Update 這個 Table.
第二個：
較好一點，您可以使用 msldbusr.dll，它可以告訴您目前正連進資料庫的電腦名稱 (Computer Name)，這些資料其實是存放在擴充名為 LDB 的檔案中。一旦您從 DLL 中抓到這些資料，您便可以送出訊息，通知 Client 端的使用者 (Remote User) 結束應用程式，以中斷和資料庫的連結，然後您便可以使用 Exclusive Mode 來維護資料庫了。
在這裡，我們要說明的是第二種方法，也就是使用 msldbusr.dll。它提供了二個 Function，說明如下：
1、LDBUser_GetUsers：呼叫後會傳回二部份，一個是使用者陣列，一個是連結到資料庫的使用者數。
Declare Function LDBUser_GetUsers Lib "MSLDBUSR.DLL" (lpszUserBuffer() _
As String, ByVal lpszFilename As String, ByVal nOptions As Long) As Integer
lpszUserBuffer()：傳回使用者陣列，注意！必須使用 ReDim 聲明成變動陣列！
lpszFilename：資料庫名稱 ( .mdb 完整路徑 )，若 .ldb 檔案不存在，會傳回錯誤代碼。
nOptions：下參數聲明資料回傳的型态。可以使用的參數有四個，如下：
1=傳回自從 .ldb 産生後，所有曾經使用資料庫的使用者機器名稱 (Computer Name) 及數目。
2=隻傳回目前正在使用資料庫的使用者機器名稱 (Computer Name) 及數目。
4=隻傳回導緻目前資料庫損毀的使用者機器名稱 (Computer Name)。
8=隻傳回使用者的總數，但是并不傳回使用者陣列。
2、LDBUser_GetError：呼叫 LDBUser_GetUsers 若有錯誤産生，可根據傳回的錯誤代碼找到說明。
Declare Function LDBUser_GetError Lib "MSLDBUSR.DLL" (ByVal nErrorNo As Long) As String
nErrorNo：呼叫 LDBUser_GetUsers 産生錯誤所傳回的代碼，介于 -1 至 -14 之間。說明如下：
-1 = Can't open the LDB file. ( 無法開啟 LDB 檔案 )
-2 = No user connected. ( 沒有使用者在使用資料庫 )
-3 = Can't create an array. ( 無法建立陣列 )
-4 = Can't redimension array. ( 無法重建立立陣列 )
-5 = Invalid argument passed. ( 傳入無效的參數 )
-6 = Memory allocation error. ( 記憶體配置錯誤 )
-7 = Bad index. ( 無效的索引 )
-8 = Out of memory. ( 記憶體不足 )
-9 = Invalid argument. ( 無效的參數 )
-10= LDB is suspected as corrupted. ( LDB 檔案可能損毀 )
-11= Invalid argument. ( 無效的參數 )
-12= Unable to read MDB file. ( 無法讀取 MDB 檔案 )
-13= Can't open the MDB file. ( 無法開啟 MDB 檔案 )
-14= Can't find the LDB file. ( 找不到 LDB 檔案 )
'範例程式：( 移除所有的 Form，請将以下程式複制到 .bas 檔案中即可執行 )
Option Explicit
Declare Function LDBUser_GetUsers Lib "MSLDBUSR.DLL" (lpszUserBuffer() _
As String, ByVal lpszFilename As String, ByVal nOptions As Long) As Integer
Declare Function LDBUser_GetError Lib "MSLDBUSR.DLL" (ByVal nErrorNo As Long) As String
Sub MAIN()
Dim psMDBFilename As String
psMDBFilename = InputBox("請輸入資料庫名稱：")
If Len(psMDBFilename) Then
ShowUsers psMDBFilename
End If
End Sub
Sub ShowUsers(psFilename As String)
ReDim lpszUserBuffer(1) As String
Dim psError As String
Dim cUsers As Long
Dim iLoop As Long
'呼叫 LDBUser_GetUsers 傳回使用者陣列
cUsers = LDBUser_GetUsers(lpszUserBuffer(), psFilename, 1)
'确認是否傳回使用者陣列
If (cUsers = 0) Then
Debug.Print "No Users."
GoTo Exit_ShowUsers
End If
'若有錯誤則顯示錯誤訊息
If (cUsers < 0) Then
psError = LDBUser_GetError(cUsers)
Debug.Print "Error #:"; cUsers; "--"; psError
GoTo Exit_ShowUsers
End If
'顯示使用者陣列
For iLoop = 1 To cUsers
Debug.Print "User "; iLoop; ":"; lpszUserBuffer(iLoop)
Next iLoop
Exit_ShowUsers:
End Sub
'除了上面的範例之外，Microsoft 也提供了一個更完整的範例，它有一個容易了解的介面設計：
如果您在這個主題中想要更多的資訊，或想取得 Microsoft 提供的更多的工具程式，您可以參考：
http://support.microsoft.com/support/kb/articles/q176/6/70.asp
175、為何聲明資料庫型态變量時出現《編譯錯誤：使用者自訂型态尚未定義》
很多人在學習用 VB 撰寫資料庫程式時，都會從使用 VB 提供的 Data Control 加上各種資料庫感覺控制項 ( Data Aware Control ) 開始，因為這樣子的組合，您甚至一行程式都不用寫就可以完成一支簡單的資料庫程式了！
然而，為了程式控制的靈活度或其他原因，您會開始想要自己聲明資料庫物件，自己控制各種資料的處理動作，于是您在程式中加入了類似以下的聲明： ( 因為書上及 Help 都這麼寫 )
Dim DB As Database
Dim SS As Snapshot
:
寫了一支很簡單的程式之後，當您想看看成果，而按下【開始執行】的按鈕時，卻從電腦中發出了一聲令人驚心動魄、代表錯誤的聲響！ (如果您有裝 Sound Card 的話) 您一遍一遍的檢查程式，已經是最簡單的程式了，怎麼可能會錯誤呢！讓我們來看看錯誤訊息：《編譯錯誤：使用者自訂型态尚未定義》
其實您的程式并沒有錯，您聲明的資料型态也都是對的，隻是定義它的物件程式庫或型态程式庫并沒有在 Visual Basic 中注冊而已。解決方法如下：
從【專案】功能表中選擇【設定引用項目】，在【可引用的項目】欄中選擇【Microsoft DAO x.x Object Library】【Microsoft DAO x.x/x.x Compatibility Library】即可。
其中 x.x 代表的是某一個資料庫引擎的版本，x.x/x.x 則代表相容于好幾個版本的資料庫引擎！
如果您的公司中有人使用 Access2.0 / Access95 / Access97 ...等多個不同的版本時，您可以使用 【Microsoft DAO 2.5/3.5 Compatibility Library】。
176、模拟 VB 程式執行時産生的錯誤訊息
VB 程式執行時若有錯誤産生，而程式中又沒有錯誤控制的話，便會出現 VB 内定的錯誤編号及錯誤訊息，但是這個錯誤訊息通常都很簡短，是以使用者和寫程式的人反應時，有時候也不知道是什麼意思及該如何處理。而且這種錯誤有時候在開發人員的機器上不會發生，隻有在使用者的機器上才會發生，是以開發人員也模拟不出來！
雖然 VB 的錯誤編号及訊息都很簡短，但是在 VB 的線上說明中都有比較詳細的錯誤分析及解決方法，隻是有些人找不到，是以常常有人在問 VB 産生的錯誤訊息是什麼意思及該如何處理。
VB 的 Err 物件其實就可以讓我們模拟錯誤，以下的 Sample 是從 VB 的 HELP 中節錄出來的：
' If an error occurs, construct an error message
On Error Resume Next ' Defer error handling.
Err.Clear
Err.Raise 6 ' Generate an "Overflow" error.
' Check for error, then show message.
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
以上的程式加了 On Error Resume Next，是以并不會中斷跳出來，而出現的訊息框内容如下，有錯誤編号及錯誤訊息，而且錯誤訊息很簡短，而且它隻有一個【确定】按鈕，對我們幫助不大：
Error # 6 was generated by Project1
OverFlow
今天如果在 Design Time 時将 On Error Resume Next 拿掉，出現的訊息框如下：
Run-time error '6'
OverFlow
除了以上的訊息外，它有四個按鈕，分别是【Continue】、【End】、【Debug】、【Help】，而最後一個按鈕【Help】就可以讓我們直接進到 Help 看到以下的詳細說明：
Overflow (Error 6)
An overflow results when you try to make an assignment that exceeds the limitations of the target of the assignment. This error has the following causes and solutions:
The result of an assignment, calculation, or data type conversion is too large to be represented within the range of values allowed for that type of variable.
Assign the value to a variable of a type that can hold a larger range of values.
An assignment to a property exceeds the maximum value the property can accept.
Make sure your assignment fits the range for the property to which it is made.
For additional information, select the item in question and press F1.
是以，下一次您就可以使用這個方法來友善找到詳細的錯誤說明！
177、如何取得檔案大小？
VB6 提供了一個新的物件模型，叫做 FSO (File System Object) 物件模型，運用它，我們可以很友善的處理磁盤、資料夾和檔案的一些動作。
FSO 物件模型含有好幾個物件，其中有一個 File 物件是用來求得檔案的相關資訊，在目前這個主題，我們就可以使用 File 物件！它有一個屬性是 Size，對檔案來說就是指檔案的大小 (機關為位元組)。 (注一)
雖然使用 File 物件的 Size 屬性就可以求得檔案的大小，但是它有以下二個缺點：
1、隻能用于 VB6 以後的版本。
2、它不是 VB6 内定的功能，必須另外引用 Scrrun.dll (Microsoft Scripting Runtime) 才可以！
以下的二個方法就可以使用在所有的 VB 版本中 (含 VB6)，而且是 VB 内定的功能：
1、FileLen 函數：傳回一個 Long，代表一個檔案的長度，機關是位元組。
文法：FileLen(pathname) ' pathname 是全路徑之檔案名稱
适用：取得一個尚未開啟的檔案的長度大小 (注二)
2、LOF 函數：傳回一個 Long ，機關為位元組，用來代表由 Open 陳述式所開啟的檔案之大小。
文法：LOF(filenumber) ' filenumber 是一個檔案代碼
适用：取得一個已開啟的檔案的長度大小
注一：File 物件的 Size 屬性除了可以求得一個檔案的大小，也可以用來取得整個目錄的所有檔案大小！
注二：使用 FileLen 函數時，如果所指定的檔案正在開啟中，則所傳回的值是這個檔案在開啟前的大小。
178、如何一次讀取整個檔案的内容？
通常我們要讀取整個檔案的内容時，都是一行一行讀進來，再使用變數來累加。除了這種方法之外，您還可以使用 GET Function，隻要呼叫一次就可以讀入一整個檔案了！而且速度更快！
以下這個模組就是使用 GET 來讀入整個檔案，參數隻有一個，就是含路徑的檔案名：
Function FileContent(FileName As String) As String
Dim FileNo As Integer
Dim FileString As String
FileNo = FreeFile
Open FileName For Binary As #FileNo
FileString = Space(FileLen(FileName))
Get #FileNo, , FileString
Close #FileNo
FileContent = FileString
End Function
使用執行個體如下：
Private Sub Command1_Click()
RichTextBox1 = FileContent("C:/Test.txt") (注)
End Sub
注：
當檔案大小小于 64K 時可使用 TextBox
當檔案大小大于 64K 時請使用 RichTextBox
若是 VB6 您還可以使用 FSO 物件模型中的 TextStream 物件的 ReadAll 方法來讀一個完整的 TextStream 檔案并傳回得到的字串。
對于太大的檔案，使用以上的方法浪費記憶體資源。應使用其它的技術去輸入一個檔案，比如一列一列地讀取檔案。
179、如何使用文本檔案來存取 ListBox 内的資料？
當我第一次在網路上的讨論區中看到有人提到以下的二個問題時：
1、請問如何将 TextBox 或 ListBox 的資料存到文本檔案中？
2、請問如何将文本檔案中的資料一行一行讀出放到 ListBox 中？
我真的有一點驚訝，因為我一直都是待在民營企業的 MIS 部門，所有的系統都要使用到資料庫，像這樣的問題，我們在系統設計時，都會在資料庫中用一個片語檔案來存放，不管系統大小，都可以将這一類的資料存在片語檔案中，再依類别來區分，還可以依使用者 要來加以編号排序，除此之外，也友善統一管理。
不過，不管是國内或國外的讨論區中，這樣的問題卻一直不斷的有人在問，而且頻率不低，這讓我體會到，基于各種理由，并不是所有人都一定要使用資料庫來存放這些資料！
若要使用文本檔案來存放這些資料，其實最需要了解的，就是文本檔案的存取方法！
在以下的範例中，我使用到二個 ListBox 及二個 CommandButton，不需更改任何屬性！按下 Command1 時，會将 List1 中的資料放到暫存檔案中，按下 Command2 時，再将暫存檔案中的資料放到 List2 中。
Private Sub Command1_Click()
'将 ListBox 資料放到文本檔案中
Dim i As Integer
Open "c:/temp.txt" For Output As #1
For i = 0 To List1.ListCount - 1
Print #1, List1.List(i)
Next
Close #1
End Sub
Private Sub Command2_Click()
'将文本檔案中資料讀出放到 ListBox 中
Dim wstr As String
Open "c:/temp.txt" For Input As #1
Do While Not EOF(1) '執行回圈直到檔案尾為止。
Input #1, wstr
List2.AddItem wstr
Loop
Close #1
End Sub
不過如果您的系統有使用到資料庫，而您之前沒有想到要使用資料庫的片語檔案來存放這些資料的話，我建議您試試看，您會發現片語檔案真的很友善，不管什麼雜七雜八的資料，隻要一個檔案就解決了！
180、字串取代之【全部取代】
在一般的應用軟體中，例如 Word、小作家、Excel....等，都會提供字串取代【全部取代】的功能，這個功能很簡單，就是将整篇文章從頭到尾找一遍，碰到您要找的字串，就将它轉換成您要取代的字串。
當然，或許您會說 VB6 不是己經有提供這個功能了嗎？沒錯！VB6 己經有提供這個功能了，但是據我所知，目前企業界實際在使用 VB6 的比例并不高！大部份還是使用 VB5 / VB4-32，這個模組就是專為 VB6 以前的版本寫的。
以下這個模組 myReplaceString ，它共有三個參數，說明如下：
1、hString：您要搜尋的一篇文章。
2、hSource：要搜尋到的子字串。
3、hTarget：用來取代的子字串。
整個模組的程式碼很短，如下：
Public Function myReplaceString(ByVal hString As String, ByVal hSource As String, ByVal hTarget As String) As String
tLen = Len(hSource)
tChk = (Len(hTarget) = Len(hSource))
tLoc = 1
Do
tLoc = InStr(tLoc, hString, hSource)
If tLoc <> 0 Then
If tChk Then
Mid(hString, tLoc, tLen) = hTarget
Else
hString = Left(hString, tLoc - 1) + hTarget + _
Mid(hString, tLoc + tLen)
End If
tLoc = tLoc + Len(hTarget)
Else
Exit Do
End If
Loop
myReplaceString = hString
End Function
而傳回值就是已經經過轉換後的新文章！
181、如何在 VB5 中打開 VB6 的工程？
如果您用 VB5 打開 VB6 撰寫的工程，會出現一個類似以下的訊息：
"Retained 為不正确的鍵。無法載入檔案 C:/Windows/Desktop/Project1.vbp。"
"Retained is an invalid key. The file C:/Windows/Desktop/Project1.vbp can't be loaded".
那是因為在 VB6 的工程的 .vbp 檔案中，多了一個之前的 VB 版本不認得的鍵值 "Retained" 的緣故！
要解決這個問題很簡單，您隻要依照以下的幾個步驟：
1、使用記事本 (Notepad.exe) 打開 VB6 的工程的 .vbp 檔案。
2、在這個檔案中找到包含 "Retained" 字串的那一行，将那一整行移除。
3、存檔案。
這樣子您就可以使用 VB5 來打開之前使用 VB6 開發的工程了！很簡單吧！
注：我在别的網站上看到有人說，這樣子做了之後不一定百分之百成功，不過我自己試了之後，倒是沒有出現錯誤，各位也自己試試吧！
182、VB6.0 的 Help 在那裡？MSDN 是什麼？
很多人在安裝了 VB6.0 ，開始撰寫程式之後，遇到了問題，按下【F1】，卻出現了錯誤訊息，告訴您：
【MSDN 不存在......，請重新安裝 MSDN】
有的人還會覺得很奇怪，VB6.0 的 Help 出了什麼問題了？MSDN 又是什麼？為什麼要重新安裝 MSDN？
其實，從 VB6.0 以後，Microsoft 已經将它所有的開發軟體，合并成 Microsoft Visual Studio 6.0，一起出售 ( 當然，也有分開獨立販售的版本 )，在合并軟體的同時，Microsoft 也将每一個開發軟體的 Help 挪出來，統一放在 MSDN CD光牒中，是以，現在不管您買的是合并軟體的 Microsoft Visual Studio 6.0 或是獨立販售的 VB6.0 版本，都會另外附上二片 Microsoft MSDN Library CD光牒。
今天，如果您購買的是獨立販售的 VB6.0 版本，在您安裝完 VB6.0 之前，安裝程式會要求您放入 MSDN CD光牒，它會繼續幫您安裝 MSDN (也就是新版的 Help)。至于安裝的注意事項，請參考
問題10:不友善的 Msdn -- VB6.0 的 Help
如果您安裝 VB6.0 時，沒有同時安裝 MSDN，也沒關系，您隻要找到 MSDN CD光牒，将第一片放入光驅，直接執行 Setup.exe 即可！
注：VB6 及 Microsoft Visual Studio 6.0 所附之 MSDN Library CD光牒其實隻是一個特殊版本，是專門針對 Microsoft Visual Studio 6.0 所推出的！MSDN Library CD光牒在 VB6 及 Microsoft Visual Studio 6.0 出現之前就已經存在很久了，是微軟針對程式開發人員的官方的技術資源，它定期提供産品操作手冊、範例程式、技術文章、公用程式及許多最新的技術資料。而随 VB6 及 Microsoft Visual Studio 6.0 所附之 MSDN Library CD光牒内容包含 VB6 及 Microsoft Visual Studio 6.0 的最新産品手冊 (電子書) 及技術資料。
183、如何判斷資料庫中某一個 Table 是否存在？(ADO)
要判斷資料庫中某一個 Table 是否存在？最簡單的方法就是錯誤嘗試法！什麼叫做錯誤嘗試法呢？就是先假設它存在，直接去打開它，如果它真的存在，不會有錯誤産生，但是如果它不存在的話，就會有錯誤産生！做法大緻如下：
1、設定 On Error Resume Next
2、直接打開要檢查的 Table
3、如果檔案存在，則 err.Number=0
我們就以 Access 為例，資料庫使用 VB 内附的 Biblio.mdb，程式碼如下：
On Error Resume Next '1
Set Conn = CreateObject("ADODB.Connection")
Conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=C:/Biblio.mdb"
Set rs = Conn.execute("Titles") '2
If Err.Number <> 0 Then MsgBox "Table 不存在" Else MsgBox "Table 存在" '3
184、如何移除或更改桌面背景的底色圖案 (Wallpaper)？
SystemParametersInfo 這個 API 可以設定許多 Windows 系統的功能參數，而其中一個參數就是桌面底圖！通常一般的使用者會透過控制台中的【顯示器】來設定桌面底圖。
在底下的範例中，我們使用 SPI_SETDESKWALLPAPER 這個參數及圖檔檔案名稱來設定新的桌面底圖，同時使用 SPIF_SENDWININICHANGE 來通知各個視窗這個改變。
'在表單的聲明區中加入以下聲明及常數：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Const SPIF_SENDWININICHANGE = &H2
'在表單上加入一個 CommandButton (Command1) 來移除桌面底圖，程式碼如下：
Private Sub Command1_Click()
Dim X As Long
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
MsgBox "桌面底圖 (Wallpaper) 已經被移除"
End Sub
'在表單上加入另一個 CommandButton (Command2) 來更改桌面底圖，程式碼如下：
Private Sub Command2_Click()
Dim FileName As String
Dim X As Long
FileName = "c:/windows/test.bmp"
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, FileName, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
MsgBox "桌面底圖 (Wallpaper) 已經被更改"
End Sub
185、如何在不開啟檔案的情況下列印各類檔案？
您還記得或懷念以前 DOS 時代，在 DOS 的指令列就可以直接下指令列印檔案嗎？
其實這個題目的标題，就如同當今的報紙标題一般，有點誇張，因為要列印檔案，勢必要先開啟檔案！
但是您也不用失望，既然标題會這樣訂，表示我也有好方法 (其實應該說 Microsoft 有提供好方法)！您隻要使用 ShellExecuteAny 這個 API，對于各種不同格式不同類型的檔案，您都不用自己先去啟動開啟該類檔案的應用程式，再開啟檔案，再列印檔案！
看到上面的說明，是否讓您回想起之前我們提到過的二個主題：
如何用 VB 啟動其他程式或開啟各類檔案？
完全模拟【開始】中的【運作...】功能
在這二個主題中，我們都有提到，不必管檔案的擴充名是什麼？格式是什麼？您都可以使用如下面
Shell("Start C:/Test.txt")
Call Shell("rundll32.exe url.dll,FileProtocolHandler " & Text1, 1)
的方式來啟動程式或開啟檔案。今天，我們要提到的 API 也可以開啟或執行各種不同類型的檔案，但是那不是我們今天的重點 (如果各位有興趣的話，請自行研究！)，今天的重點是 ShellExecuteAny 這個 API 它可以：
1、自動依檔案型态幫我們在 Background 啟動應用程式。
2、自動列印檔案。
3、自動再關閉檔案。
應用在我們的 VB 程式中的話，使用者隻要輸入或選擇檔案，不管什麼檔案 (當然是指在系統資料庫中曾經注冊過的檔案類型)，都可以列印！
'以下是完成的模組：
Private Declare Function ShellExecuteAny Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As Any, ByVal lpDirectory As Any, ByVal nShowCmd As Long) As Long
Const SW_SHOWMINNOACTIVE = 7
Sub PrintAnyFile(FileToPrint As String)
Dim Ret As Long
Ret = ShellExecuteAny(Me.hwnd, "print", FileToPrint, ByVal 0&, ByVal 0&, SW_SHOWMINNOACTIVE)
End Sub
'實際使用案例如下：
Private Sub Command1_Click()
PrintAnyFile Text1.Text
End Sub
其實上面這種列印檔案的方式，它的作用方式，和我們直接将檔案檔案拖拉到列印機的圖示上去列印檔案是一樣的道理！ (如果您之前尚不知道這個功能的話，您現在可以試試看将一份檔案直接拖拉放到列印機的圖示上，看看結果如何！)
186、誰終結了我的程式？
您開發的應用程式或許寫得非常完整，您也很滿意，但有時候卻莫名其妙地出現了一點問題，在不該結束程式的時候，它被強迫結束了！可能使用者是按下了 Ctrl + Alt + Del，使用 Microsoft Windows 工作管理者關閉應用程式，或者強迫關機了！然而您的程式卻沒有考慮到這一點。
在正常情況下要結束一個表單，會經過三個事件 (當您使用 End 結束程式時是例外！)，順序如下：
1、Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
2、Private Sub Form_Unload(Cancel As Integer)
3、Private Sub Form_Unload(Cancel As Integer)
在這三個事件中都允許您設定 Cancel=True 來避免表單被結束，但是它們是不分青紅皂白的，唯一能讓您分辨表單為什麼被結束的，就是在 Form_QueryUnload 中的 UnloadMode 參數！
unloadmode 參數傳回下列的值：
常數 值 描述
vbFormControlMenu 0 使用者從表單上的控制功能表中選取「關閉」指令。
vbFormCode 1 Unload 陳述式被程式代碼呼叫。
vbAppWindows 2 目前 Microsoft Windows 作業環境任務結束。
vbAppTaskManager 3 Microsoft Windows 工作管理者正在關閉應用程式。
vbFormMDIForm 4 因為 MDI 表單正在關閉的緣故，MDI 子表單正在關閉。
vbFormOwner 5 表單因其擁有人關閉而關閉。
是以下次您就可以在 Form_QueryUnload 中利用 UnloadMode 參數來判斷程式是否 要做什麼特别處理！
187、完全模拟【開始】中的【關機】功能
在【問題：如何從您的應程式中結束 Windows 重開機？】我們曾經提到過，如何由程式中強迫關機、重開機，但是在這個主題中，我們要告訴您的，是如何模拟按下了【開始】中的【關機】選項，螢幕變成灰灰一片，并且在螢幕中央出現【關閉 Windows】問話框！
在聲明區中加入以下聲明：
Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal lType As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const EWX_POWEROFF = 8
要 Show 出【關閉 Windows】問話框時用法如下：
SHShutDownDialog EWX_SHUTDOWN
188、如何将桌面上所有的視窗最小化？
有很多好用的桌面工具軟體都有提供這個功能，将桌面上所有的視窗最小化，也會提供将它們複原的功能，當然，要提供這種功能的軟體，執行後都是将程式縮到桌面右下角的工具列中，使用 Menu 來操控，否則，将桌面上所有的視窗最小化，也包括它自己的程式本身的視窗的！
'請在視窗聲明區中加入以下聲明及模組：
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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_COMMAND As Long = &H111
Private Const MIN_ALL As Long = 419
Private Const MIN_ALL_UNDO As Long = 416
Public Sub MinimizeAll()
Dim lngHwnd As Long
lngHwnd = FindWindow("Shell_TrayWnd", vbNullString)
Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL, 0&)
End Sub
Public Sub RestoreAll()
Dim lngHwnd As Long
lngHwnd = FindWindow("Shell_TrayWnd", vbNullString)
Call PostMessage(lngHwnd, WM_COMMAND, MIN_ALL_UNDO, 0&)
End Sub
'而實際使用之範例如下：
Private Sub Command1_Click()
MinimizeAll '将桌面上所有的視窗最小化
End Sub
Private Sub Command2_Click()
RestoreAll '将最小化的視窗還原
End Sub
189、如何動态新增、移除 ODBC DSN？
一般我們建立 Client 端 DSN 都是在使用者的機器上進入【控制台】【ODBC 資料來源管理者】去建立，但是如果我們開發的 APP 使用者很多時，這就有點累人了，是以我們可以将這個動作放在程式中！
新增 DSN 的方法有二種：
1、使用 DBEngine 物件的 RegisterDatabase 方法
2、呼叫 SQLConfigDataSource API
不管使用以上任何一種方法新增 DSN，一共會寫入二個地方，一個是系統資料庫，一個是 ODBC.INI。
而删除 DSN 的方法同上面的第二種方法，呼叫 SQLConfigDataSource API。
以下之模組以 Oracle73 Ver 2.5 為例，在 Form 的聲明區中加入以下聲明及模組：
Private Const ODBC_ADD_DSN = 1 ' Add data source
Private Const ODBC_CONFIG_DSN = 2 ' Configure (edit) data source
Private Const ODBC_REMOVE_DSN = 3 ' Remove data source
Private Const vbAPINull As Long = 0& ' NULL Pointer
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Public Sub CreateDSN(sDSN As String)
Dim nRet As Long
Dim sDriver As String
Dim sAttributes As String
sDriver = "Oracle73 Ver 2.5"
sAttributes = "Server=Oracle8" & Chr$(0)
sAttributes = sAttributes & "DESCRIPTION=" & sDSN & Chr$(0)
'sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
sAttributes = sAttributes & "DATABASE=DBFinance" & Chr$(0)
sAttributes = sAttributes & "Userid=Scott" & Chr$(0)
'sAttributes = sAttributes & "PWD=myPassword" & Chr$(0)
DBEngine.RegisterDatabase sDSN, sDriver, True, sAttributes '注一
'nRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, sDriver, sAttributes) '注二
End Sub
Public Sub DeleteDSN(sDSN As String)
Dim nRet As Long
Dim sDriver As String
Dim sAttributes As String
sDriver = "Oracle73 Ver 2.5"
sAttributes = sAttributes & "DSN=" & sDSN & Chr$(0)
nRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, sDriver, sAttributes)
End Sub
'假設要産生的 DSN 為 Test，實際使用範例如下：
Private Sub Command1_Click()
CreateDSN "Test"
End Sub
Private Sub Command2_Click()
DeleteDSN "Test"
End Sub
'而寫到系統的資料如下：
1、ODBC.INI
[ODBC 32 bit Data Sources]
Test=Oracle73 Ver 2.5 (32 bit)
[Test]
Driver32=C:/ORAWIN95/ODBC250/sqo32_73.dll
2、系統資料庫
機碼：HKEY_CURRENT_USER/Software/ODBC/ODBC.INI/ODBC Data Sources
名稱：Test 資料：Oracle73 Ver 2.5
機碼：HKEY_CURRENT_USER/Software/ODBC/ODBC.INI/Test
名稱：Description 資料：Test
名稱：Driver 資料：C:/ORAWIN95/ODBC250/sqo32_73.dll
名稱：Server 資料：Oracle8
名稱：UserId 資料：Scott
※注一及注二可任選一種，隻要将不使用的方法 Mark 起來即可！
※若您想使用其他之資料庫，隻要将以上模組稍作修改即可！
190、如何從全路徑檔案名中分别抓出路徑及檔案名？
這是一個很簡單很常碰到的問題，隻要有用到檔案的程式常常都會需要處理這樣的問題！既然很簡單為什麼還要提出這樣的問題呢？沒錯，是很簡單，但是我的着眼點是：它太常出現了，值得做成模組！
要解決這個問題，第一個要了解的就是全路徑檔案名稱的構成要素：磁盤代号、目錄名稱、檔案名稱，而這三個組成要素之間，都是使用反斜線符号 (即 "/") 分開！
是以，要從全路徑檔案名中分别抓出路徑及檔案名，第一件事就是要找到從右邊倒數的第一個反斜線符号！
不多說，直接來看看模組及執行個體：
'模組：抓出路徑
Function ExtractDirName(PathName As String) As String
Dim X As Integer
For X = Len(PathName) To 1 Step -1
If Mid$(PathName, X, 1) = "/" Then Exit For
Next
ExtractDirName = Left$(PathName, X - 1)
End Function
'模組：抓出檔案名
Function ExtractFileName(PathName As String) As String
Dim X As Integer
For X = Len(PathName) To 1 Step -1
If Mid$(PathName, X, 1) = "/" Then Exit For
Next
ExtractFileName = Right$(PathName, Len(PathName) - X)
End Function
'使用執行個體：
Private Sub Command1_Click()
Dim PathName As String
PathName = "C:/倪匡小說原稿/未整理小說/黃金故事.txt"
Text1.Text = ExtractFileName(PathName) ' 黃金故事.txt
Text2.Text = ExtractDirName(PathName) ' C:/倪匡小說原稿/未整理小說
End Sub
196、如何一次關閉 MDIForm 内的所有子表單？
以下這段程式可以讓您一次關閉 MDIForm 内的所有子表單，首先在 MDIForm 中建立一個 Menu，假設取名為 mnuCloseAll，則程式碼如下：
Private Sub mnuCloseAll_Click()
'Screen.MousePointer = vbHourglass
Do While Not (Me.ActiveForm Is Nothing)
Unload Me.ActiveForm
Loop
'Screen.MousePointer = vbDefault
End Sub
197、按下 CommandButton 之前後，如何讓滑鼠停留在同一個物件中？
在一般表單輸入畫面中，使用者輸入了一筆資料後，會去按 '存檔' 按鈕，當然他也可能去按任一個按鈕，但是不管他是按那一個按鈕，如果您不在程式中将滑鼠移到下一筆輸入的第一個欄位，或其他特定的欄位，使用者便必須自己去移動滑鼠，如果這個使用者是使用鍵盤輸入，那更是麻煩！他必須使用 Tab 鍵一個物件一個物件移動光标。
下面這個範例将示範如何做到在按下 CommandButton 之前後，讓滑鼠停留在同一個物件中！請在表單中放入二個 TextBox 及一個 CommandButton，不必更改任何屬性，将以下之程式複制到表單中：
Dim mCtl As Control
Private Sub Command1_Click()
' 在這一個段落中可以執行您想做的動作, 例如存檔動作
' 然後将滑鼠移回按下 Command1 之前滑鼠停留的物件上
On Error Resume Next
mCtl.SetFocus
End Sub
Private Sub Text1_GotFocus()
Set mCtl = Text1
End Sub
Private Sub Text2_GotFocus()
Set mCtl = Text2
End Sub
198、您用過【符号字型】嗎？
有時候您是否覺得，同樣的開發環境，為什麼 Microsoft 寫出來的程式，畫面總是在某些地方看來特别一點點，例如 CommandButton 的樣子就是和我們自己寫的不一樣，您總是感覺他們的 CommandButton 上放的是圖形，其實，在 CommandButton 上的不是圖形，隻不過是某一種字型而已！而且這些字型在每一台 Windows95 / Windows98 / NT 上都有，如果沒有，您隻要安裝了 IE4 或 IE5 就有了。
舉個例子好了，如果您要在 CommandButton 上放一個向右或向左的箭頭，不使用圖檔的話，您會使用【>】【<】，但是您在 Microsoft 寫出來的程式中看到的是【4】【3】，為什麼呢？因為它用的是一種符号字型，就是 Marlett 字型的 3 【4】及 4【3】！
這些字型在那裡呢？在本頁的下方列了七種符号字型，每一種字型分别列出了 0-9 / a-z / A-Z 共 62 個字元，如果在某些欄位中您看到的仍然是 0-9 / a-z / A-Z，表示您的電腦中沒有這種字型，當然，符号字型不隻這七種而已，如果您想知道您的電腦中暗藏多少種符号字型的話，方法如下：
在任何可以設定字型的應用程式中，叫出【字型】設定對話框，我們就用 VB 的開發環境來舉例好了：
1、在表單上放一個 Label，Caption 随意輸入 0-9 / a-z / A-Z 的字元，在屬性表中設定字型 (Font)。
2、在【字型】設定對話框的左上方，您随便選擇一種【字型】。
3、看看【字型】設定對話框的右下方，【字集】也會跟著改變！每一種字型會包含一種以上的字集。
4、如果字集中出現的是 symbol，表示這種字型就是符号字型！
5、按下确定按鈕，看看 Label 上面的字有何改變，很令人驚訝吧！
6、Marlett 字型的 012345 變成了 012345了！
這些符号字型有的非常精美，下一次要使用圖檔之前，記得找一找符号字型，使用符号字型不但美觀，而且可以避免使用圖檔，讓程式瘦身！
注：符号字型範例
( 由于此頁檔案太大，怕影響速度，是以移除了部份英文字元，若有需要，請自行測試 )
字型 Marlett Monotype Sorts r_symbol MT Extra Wingdings Wingdings 2 Wingdings 3
0 0 0 0 0 0 0 0
1 1 1 1 1 1 1 1
2 2 2 2 2 2 2 2
3 3 3 3 3 3 3 3
4 4 4 4 4 4 4 4
5 5 5 5 5 5 5 5
6 6 6 6 6 6 6 6
7 7 7 7 7 7 7 7
8 8 8 8 8 8 8 8
9 9 9 9 9 9 9 9
a a a a a a a a
: : : : : : : :
A a A A A A A A
: : : : : : : :
Z Z Z Z Z Z Z Z
199、避免使用沒有效率的 IIF Function 及 Choose Function！
IIF Function 的功能是根據邏輯判斷，傳回給定的二個值中的一個 (二選一)；
Choose Function 的功能是從引數串列中選擇并傳回一個值 (多選一)。
二個函數的文法如下：
IIf(expr, truepart, falsepart)
Choose(index, choice-1[, choice-2, ... [, choice-n]])
這二個函數乍看之下，好像和 IF....Else IF....Else....End IF 是一樣的，沒錯，結果好像是一樣的，但是事實上 IF....Else....End IF 卻比較有效率和安全多了，為什麼呢？
1、IIf 會計算 truepart 以及 falsepart，雖然它隻傳回其中的一個，是以您應該要留意這項副作用，
例如，如果 falsepart 會産生除以零的錯誤，那麼程式就會發生錯誤，即使 expr 為 True。
2、Choose 會計算串列中的每個選擇項，即使它隻傳回一個選項值。是以您應該注意這項副作用，
例如，當您在每個選擇項中使用了 MsgBox 函數，那麼每計算一個選擇項，就會顯示一次訊息方塊。
而 IF....Else....End IF 卻沒有上述的缺點！
是以，雖然 IIF 及 Choose Function 的程式碼看起來相當簡潔，但效率不見得比較好，最重要的，是可能還會導緻錯誤産生。我的建議就是：能不用就不用！
200、如何用TextBox打開和儲存檔案
作為輕量級的控件，TextBox控件使用率很高，但相關的資料極少談及如何用TextBox控件打開和儲存檔案，大都采用回避的态度，對VB初學者帶來很多不便。筆者近日為友人做一個英文朗讀軟體，按友人的要求，軟體要能象MS的記事本那樣能打開和儲存文檔。其實實作方法并不複雜，現将心得寫出來，希望對大家有幫助。如果您有更好的方法，請來信：[email protected]。
'建立标準EXE，加入一個TextBox控件，一個公共對話框，兩個菜單。
'打開
Private Sub mnuOpen_Click()
CommonDialog1.Filter = "文檔檔案(*.txt)|*.txt|所有檔案(*.*)|*.*"
CommonDialog1.ShowOpen
Open CommonDialog1.FileName For Input As #1
Text1.Text = StrConv(InputB$(LOF(1), 1), vbUnicode)
Close #1
End Sub
'儲存
Private Sub mnuSave_Click()
On Error Resume Next
CommonDialog1.Filter ="文檔檔案(*.txt)|*.txt|所有檔案(*.*)|*.*"
CommonDialog1.ShowSave
Open CommonDialog1.FileName For Output As #1
Print #1, Text1.Text
Close 1
End Sub
TextBox隻支援打開64K以下的檔案，建議最好設定出錯處理。
以上程式在PWin98、VB6.0下調試通過。
201、避免使用沒有效率的 IIF Function 及 Choose Function！
IIF Function 的功能是根據邏輯判斷，傳回給定的二個值中的一個 (二選一)；
Choose Function 的功能是從引數串列中選擇并傳回一個值 (多選一)。
二個函數的文法如下：
IIf(expr, truepart, falsepart)
Choose(index, choice-1[, choice-2, ... [, choice-n]])
這二個函數乍看之下，好像和 IF....Else IF....Else....End IF 是一樣的，沒錯，結果好像是一樣的，但是事實上 IF....Else....End IF 卻比較有效率和安全多了，為什麼呢？
1、IIf 會計算 truepart 以及 falsepart，雖然它隻傳回其中的一個，是以您應該要留意這項副作用，
例如，如果 falsepart 會産生除以零的錯誤，那麼程式就會發生錯誤，即使 expr 為 True。
2、Choose 會計算串列中的每個選擇項，即使它隻傳回一個選項值。是以您應該注意這項副作用，
例如，當您在每個選擇項中使用了 MsgBox 函數，那麼每計算一個選擇項，就會顯示一次訊息方塊。
而 IF....Else....End IF 卻沒有上述的缺點！
是以，雖然 IIF 及 Choose Function 的程式碼看起來相當簡潔，但效率不見得比較好，最重要的，是可能還會導緻錯誤産生。我的建議就是：能不用就不用！
202、使用一個指令建立目錄 (巢狀目錄)
假設您需要建立目錄，不管是在根目錄或者是好幾層的目錄，例如：C:/Dir1/Dir2/Dir3/Dir4 下面這個模組都可以滿足您的需求！它隻需要一個參數，就是完整的目錄名稱 (指全路徑)，例如："C:/Dir1/Dir2/Dir3/Dir4"。
如果您給的目錄中，前幾層目錄都已經存在，例如："C:/Dir1/Dir2/"，則它隻會幫您再往下建立 Dir3 及 Dir4 二層目錄而己。除了本機的磁盤之外，您已經 Mapped 的網路磁盤也可以做到！而如果您沒有給定磁盤代号，它會将目錄建立在應用程式的預設目錄之下！
Public Function MkDirs(ByVal PathIn As String) As Boolean
Dim nPos As Long
MkDirs = True '先假設成功
If Right$(PathIn, 1) <> "/" Then PathIn = PathIn + "/"
nPos = InStr(1, PathIn, "/")
Do While nPos > 0
If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
On Error GoTo Failed
MkDir Left$(PathIn, nPos)
On Error GoTo 0
End If
nPos = InStr(nPos + 1, PathIn, "/")
Loop
Exit Function
Failed:
MkDirs = False
End Function
'使用範例如下：在 Text1 中輸入要建立的目錄 (指全路徑)
Private Sub Command1_Click()
Dim istrue As Boolean
istrue = MkDirs(Text1)
If istrue Then
MsgBox "目錄已成功建立！", 64, "建立目錄"
Else
MsgBox "建立目錄失敗！", 16, "建立目錄"
End If
End Sub
'或許您在測試時找不到失敗的範例，給您一個提示：将目錄建在隻讀CD光牒驅動器試試！
203、如何在資料庫中存入單引号？
當您想要新增一筆資料到 Access 或 Oracle 時，若文字欄位中含有單引号，便會産生錯誤！
在以下的例子中，我們告訴您如何使用 Chr$(34) 将含有單引号之字串存入 Jet database engine 中！
Private Sub CmdAddNew_Click()
Dim dbCustomer As Database ' 聲明資料庫
Dim strSql As String ' SQL 字串
Dim strodbc As String ' ODBC 字串
' 以下為資料庫中客戶檔之三個欄位變量聲明
Dim strCustID As String ' 客戶代碼
Dim strFirstName As String ' 客戶名稱
Dim strAddress As String ' 客戶位址
strodbc = "odbc;uid=scott;pwd=tiger;dsn=myconnect"
Set dbCustomer = OpenDatabase("myconnect", dbDriverNoPrompt, False, strodbc)
strCustID = "A003"
strFirstName = "Annie"
strAddress = "Reflection's"
strSql = "insert into CUSTOMER values('" & strCustID & "'"
strSql = strSql & ",'" & strFirstName & "',"
strSql = strSql & Chr(34) & strAddress & Chr(34) & ")"
dbCustomer.Execute (strSql)
dbCustomer.Close
End Sub
'如果您還想要更詳細的資料，您可以參考 Microsoft Knowledge Base 中的 Q147687。
204、如何算出 TextBox 中目前光标是在第幾行？
在很多文字編輯器中，都可以告訴您，目前您的光标是在文字編輯器的第幾行，我們也來實作一下！
在 Form 中放入一個 TextBox 并将 Multiline 屬性設為 True，放入一個 Label 用來顯示目前光标所在的行數，在表單聲明區中加入以下聲明及模組：
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
Const EM_LINEFROMCHAR = &HC9
Function LineNo(txthwnd As Long) As Long
On Local Error Resume Next
LineNo = SendMessageLong(txthwnd, EM_LINEFROMCHAR, -1&, 0&) + 1
LineNo = Format$(lineno, "##,###")
End Function
'呼叫這個模組時要導入的是 TextBox 的 hwnd
'實際使用時，必須在 TextBox 的以下幾個事件中呼叫這個模組，才會完全正确：
'1. Change事件：輸入資料時可偵測計算
'2. Click 事件：用滑鼠移動光标時可偵測計算
'3. KeyUp 事件：用上下左右鍵移動光标時可偵測計算
Sub Text1_Change()
Label1 = LineNo(Text1.hwnd)
End Sub
Private Sub Text1_Click()
Label1 = LineNo(Text1.hwnd)
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
Label1 = LineNo(Text1.hwnd)
End Sub
205、目前作業系統的語言集
聲明：
Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
例子：
Dim LocaleID As Long
LocalID = GetSystemDefaultLCID
= &H404 中文繁體（台灣）
= &H804 中文簡體（大陸）
= &H409 英文 ...
206、如何算出 TextBox 的總行數？
在很多文字編輯器中，都可以告訴您，目前在編輯器中的文字總共有幾行，我們也來實作一下！
有人問我說，要計算文字框中有多少行，隻要将光标移到最後方 (Text1.SelLength=Len(Text1)),再使用前一個主題：問題180：如何算出 TextBox 中目前光标是在第幾行？的模組就可以算出來了，沒錯！不過，二種方法都差不了多少，可以任君選擇！
在 Form 中放入一個 TextBox 并将 Multiline 屬性設為 True，放入一個 Label 用來顯示目前 TextBox 中總共有幾行，在表單聲明區中加入以下聲明及模組：
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
Const EM_GETLINECOUNT = &HBA
Function LineCount(txthwnd As Long) As Long
On Local Error Resume Next
LineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
LineCount = Format$(lineCount, "##,###")
End Function
'呼叫這個模組時要傳入的是 TextBox 的 hwnd
'實際使用時，用法如下：
Private Sub Command1_Click()
Label1 = LineCount(Text1.hwnd)
End Sub
207、如何預先算出目前在 TextBox 中的資料存檔後的檔案大小？
之前在問題156: 如何取得檔案大小？ 我們讨論過已存檔檔案大小的算法，但是在一筆新資料尚未存檔前，我們其實也可以先算出它存檔後檔案會有多大！作法如下：
在 Form 中放入一個 TextBox 并将 Multiline 屬性設為 True，放入一個 Label 用來顯示目前 TextBox 中總共有幾行，在表單聲明區中加入以下聲明及模組：
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
Const EM_GETLINECOUNT = &HBA
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Function TextSize(txthwnd As Long) As Long
Dim lineCount As Long
Dim ChrsUpToLast As Long
Dim DocumentSize As Long
On Local Error Resume Next
'首先，算出 TextBox 的總行數
lineCount& = SendMessageLong(txthwnd, EM_GETLINECOUNT, 0&, 0&)
'接著 ，算出 TextBox 的位元組數
ChrsUpToLast& = SendMessageLong(txthwnd, EM_LINEINDEX, lineCount& - 1, 0&)
If ChrsUpToLast& = 0 Then
DocumentSize& = 0
ElseIf ChrsUpToLast& < 65000 Then
DocumentSize& = SendMessageLong(txthwnd, _
EM_LINELENGTH, ChrsUpToLast&, 0&) + ChrsUpToLast
End If
TextSize = Format$(DocumentSize&, "##,###")
End Function
'呼叫這個模組時要傳入的是 TextBox 的 hwnd
'實際使用時，用法如下：
Private Sub Command1_Click()
Label1 = TextSize(Text1.hwnd)
End Sub
208、如何以桌面上的背景圖來設定 Form 的背景？
這個功能是由網友 jimmy 所提供，它的功能就是将 User 桌面的圖檔直接拿來當作我們表單的背景圖。
PaintDesktop API 隻 要傳入一個數值，就是表單的 hDC 屬性值。
請直接将以下之程式碼複制到表單中即可：
Private Declare Function PaintDesktop Lib "user32" (ByVal hDC As Long) As Long
Private Sub Form_Paint()
PaintDesktop Me.hDC
End Sub
注:
hDC 屬性是 Windows 執行環境的周邊設定内容物件代碼。在 Windows 執行環境，系統透過給 Printer 物件和應用程式中每個表單和 PictureBox 控制項配置設定一個周邊設定内容，來管理系統顯示。可以用 hDC 屬性參考物件的周邊設定内容代碼。這提供了一個傳遞給 Windows API 呼叫的值。
209、改變 ListIndex而不發生 Click 事件
在修改 Combo 或 Listview 的ListIndex 時， 會發生 Click 事件， 下面的函數可以阻止該事件。
聲明：
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
Const CB_GETCURSEL = &H147
Const CB_SETCURSEL = &H14E
Const LB_SETCURSEL = &H186
Const LB_GETCURSEL = &H188
函數：
Public Function SetListIndex(lst As Control, ByVal NewIndex As Long) As Long
If TypeOf lst Is ListBox Then
Call SendMessage(lst.hWnd, LB_SETCURSEL, NewIndex, 0&)
SetListIndex = SendMessage(lst.hWnd, LB_GETCURSEL, NewIndex, 0&)
ElseIf TypeOf lst Is ComboBox Then
Call SendMessage(lst.hWnd, CB_SETCURSEL, NewIndex, 0&)
SetListIndex = SendMessage(lst.hWnd, CB_GETCURSEL, NewIndex, 0&)
End If
End Function
210、調整 Combo 下拉部分的寬度
聲明：
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_GETDROPPEDWIDTH = &H15F
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_ERR = -1
函數：
' 取得 Combo 下拉的寬度
' 可以利用該函數比例放大或縮小寬度
Public Function GetDropdownWidth(cboHwnd As Long) As Long
Dim lRetVal As Long
lRetVal = SendMessage(cboHwnd, CB_GETDROPPEDWIDTH, 0, 0)
If lRetVal <> CB_ERR Then
GetDropdownWidth = lRetVal
'機關為 pixels
Else
GetDropdownWidth = 0
End If
End Function
'設定 Combo 下拉的寬度
'機關為 pixels
Public Function SetDropdownWidth(cboHwnd As Long, NewWidthPixel As Long) As Boolean
Dim lRetVal As Long
lRetVal = SendMessage(cboHwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)
If lRetVal <> CB_ERR Then
SetDropdownWidth = True
Else
SetDropdownWidth = False
End If
End Function
004 把所有的字型名稱放到 Combo 98-6-07
For I = 0 To Screen.FontCount - 1
cboFont.AddItem Screen.Fonts(I)
Next I
211、如何将短檔案名格式轉成長檔案名？
雖然在 Windows95/98 中已經都可以使用長檔案名/目錄 (最長可以到255個位元組)，但是在您将長檔案名的檔案或目錄存檔案時，系統同時給了它一個可以相容于以前 MS-DOS 時代的 8.3 格式的檔案名稱！
到目前為止，還是有些軟體會使用 8.3 格式的檔案名稱，在安裝這些軟體時，它們寫到注冊檔案中的資料，仍然采用 8.3 格式的檔案名稱，是以有時候，您在維護系統時，必須知道目前這些已經轉成 8.3 格式的檔案名稱，原來的長檔案名是什麼。
在 問題：如何将長檔案名轉成短檔案名格式 (MS-DOS 8.3) ，我們已經講過長檔案名轉成短檔案名，當時是使用 API 來做，過程上還蠻麻煩的，但是相反的，要從短檔案名轉成長檔案名，過程卻比較簡單，也不需要用到 API，隻要使用 Dir( ) 就可以了！
'請将以下的模組放到聲明區中：
Public Function GetLongFilename(ByVal sShortName As String) As String
Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer
'在短檔案名之後加上倒斜線 "/"，避免 Instr 造成錯誤
sShortName = sShortName & "/"
'略過磁盤代号，從第四碼開始
iSlashPos = InStr(4, sShortName, "/")
'從檔案名之第四碼之後，一段一段處理在二個倒斜線 "/"之間的字串轉換
While iSlashPos
sTemp = Dir(Left$(sShortName, iSlashPos - 1), vbNormal + vbHidden + vbSystem + vbDirectory)
If sTemp = "" Then 'Error 52 - Bad File Name or Number
GetLongFilename = ""
Exit Function
End If
sLongName = sLongName & "/" & sTemp
iSlashPos = InStr(iSlashPos + 1, sShortName, "/")
Wend
'将轉換後的檔案名加上原先略過的磁盤代号，變成完整的全路徑檔案名
GetLongFilename = Left$(sShortName, 2) & sLongName
End Function
'實際使用範例如下：
Private Sub Command1_Click()
'假設 C:/Program Files/Common Files 是一個正确的全路徑檔案名或目錄
Print GetLongFilename("C:/PROGRA~1/COMMON~1")
End Sub
'結果就是 C:/Program Files/Common Files。
212、如何将桌面上的圖示排列整齊？
您的或您的使用者的桌面是否有一大堆亂亂的圖示，您可以使用 VB 來将這些圖示排列整 ！
程式碼如下：
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd 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 Long) As Long
Private Const GW_CHILD = 5
Private Const LVA_ALIGNLEFT = &H1
Private Const LVM_ARRANGE = &H1016
Private Sub Command1_Click()
Dim hWnd1 As Long
Dim hWnd2 As Long
Dim Ret As Long
hWnd1 = FindWindow("Progman", vbNullString)
hWnd2 = GetWindow(hWnd1, GW_CHILD)
hWnd1 = GetWindow(hWnd2, GW_CHILD)
Ret = SendMessage(hWnd1, LVM_ARRANGE, 0, 0)
End Sub
執行完以上的程式碼後，桌面上的所有圖示便會自動的靠左對齊！
213、VB 的 SDI / MDI 開發環境切換
如果您使用過 Windows 應用程式，也許已經注意到并不是每個程式的使用者介面看上去都一樣，也不見得同樣的介面做的事就一樣。使用者介面樣式主要有兩種：單一檔案介面 (SDI) 和多重檔案介面 (MDI)。SDI 介面的一個典型就是 Microsoft Windows 中的 WordPad 程式 (圖 6.1)。在WordPad 中，使用者一次隻能開啟一個檔案 (檔案)，想要開啟另一個檔案時，就必須先關上已開啟的檔案。
像 Microsoft Excel 和 Microsoft Word for Windows 這樣的應用程式，就是 MDI 介面；它們允許同時顯示多個檔案，每個檔案都顯示在自己的視窗中 (圖 6.2)。從程式的「視窗」功能表 ，可以看出它是否為一個 MDI 應用程式。如果「視窗」功能表中含有已開啟的檔案清單，可以讓使用者藉此來切換要顯示或編輯的檔案，這個程式就是一個 MDI 應用程式。
Visual Basic IDE 也有這兩種不同的型态：單一檔案介面 (SDI) 或多重檔案介面 (MDI)。對 SDI 選項來說，隻要 Visual Basic 是目前作用中的應用程式，則所有 IDE 視窗都可在螢幕上的任何地方自由移動，并且會保持在其它的應用程式之上；而對 MDI 選項來說，所有 IDE 視窗則都包含在一個可調整大小的父視窗内。
在 VB5 或 VB6 剛安裝好時，預設的開發環境是多重檔案介面 (MDI)，它最麻煩的地方是，當您的表單大小比較大時，或者您的表單是最大化時，您必須在 MDI 開發環境中使用卷動杆來移動表單，對設計者來說，不能一次看到表單的全貌，是相當不友善的，是以您需要将開發環境改成 SDI，但是要如何改呢？有的人找來找去，就是找不到從那裡改，其實很簡單，方法如下：
SDI 和 MDI 模式的切換 ：
1、在「工具」功能表中選取「選項」。 此時會顯示「選項」對話方塊。
2、再選取「進階」頁簽。
3、核取或取消核取「SDI 開發環境」核取方塊。
-或-
1、在指令行使用 /sdi 或 /mdi 參數來執行 Visual Basic。
設定好之後，不會馬上生效！但是當您下次啟動 Visual Basic 時，IDE 将以您選取的模式啟動。
214、Combo的自動查詢技術
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 CB_FINDSTRING = &H14C
Private Sub Combo1_Change()
Dim iStart As Integer
Dim sString As String
Static iLeftOff As Integer
iStart = 1
iStart = Combo1.SelStart
If iLeftOff <> 0 Then
Combo1.SelStart = iLeftOff
iStart = iLeftOff
End If
sString = CStr(Left(Combo1.Text, iStart))
Combo1.ListIndex = SendMessage(Combo1.hwnd, B_FINDSTRING, -1, ByVal CStr(Left(ombo1.Text, iStart)))
If Combo1.ListIndex = -1 Then
iLeftOff = Len(sString)
combo1.Text = sString
End If
Combo1.SelStart = iStart
iLeftOff = 0
End Sub
靜态變量 iLeftOff 指定了字元長度。
215、如何改變 TreeView 的背景
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 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_STYLE = -16&
Private Const TVM_SETBKCOLOR = 4381&
Private Const TVM_GETBKCOLOR = 4383&
Private Const TVS_HASLINES = 2&
Dim frmlastForm As Form
Private Sub Form_Load()
Dim nodX As Node
Set nodX = TreeView1.Nodes.Add(, , "R", "Root")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3")
Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4")
nodX.EnsureVisible
TreeView1.style = tvwTreelinesText ' Style 4.
TreeView1.BorderStyle = vbFixedSingle
End Sub
Private Sub Command1_Click()
Dim lngStyle As Long
Call SendMessage(TreeView1.hWnd, TVM_SETBKCOLOR, 0, ByVal RGB(255, 0, 0))
'改變背景到紅色
lngStyle = GetWindowLong(TreeView1.hWnd, GWL_STYLE)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle - TVS_HASLINES)
Call SetWindowLong(TreeView1.hWnd, GWL_STYLE, lngStyle)
End Sub
![GridView終極用法(一)[圖]](data:image/gif;base64,R0lGODlhAQABAIAAAP///wAAACwAAAAAAQABAAACAkQBADs=)