Visual Basic/程式碼片段
以下程式碼在您希望保持應用程式視窗置頂或在應用程式視窗保持置頂視窗和像標準視窗一樣行為之間切換時很有用。將以下程式碼貼上到程式碼模組中，並根據需要呼叫這兩個例程中的任何一個。
要使您的應用程式保持置頂，請使用以下呼叫
MakeTopMost Me.hwnd
要使您的應用程式視窗像普通視窗一樣行為，請使用以下呼叫
MakeNormal Me.hwnd
' Created by E.Spencer - This code is public domain.
'
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, y, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Public Sub MakeTopMost(Handle As Long)
SetWindowPos Handle, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeNormal(Handle As Long)
SetWindowPos Handle, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
這是由 Ben Baird 釋出到 misc VB 新聞組的。我在這裡包含它主要是為了方便起見，它詳細說明了停用窗體關閉按鈕（視窗右上角的小 x 按鈕）所需的程式碼，同時仍然保持按鈕可見。要測試它，請開啟一個新的 VB 專案，新增一個命令按鈕，貼上以下程式碼並執行它。
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private Const MF_DISABLED = &H2&
Public Sub DisableX(Frm As Form)
Dim hMenu As Long
Dim nCount As Long
hMenu = GetSystemMenu(Frm.hwnd, 0)
nCount = GetMenuItemCount(hMenu)
Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION)
DrawMenuBar Frm.hwnd
End Sub
Private Sub Command1_Click()
DisableX Me
End Sub
以下程式碼演示瞭如何透過程式碼擴充套件和隱藏組合框列表。要測試它，請建立一個新的 VB 專案，在窗體上放置一個命令按鈕和組合框，然後貼上以下程式碼。當您執行專案並使用 Tab 鍵將焦點從組合框移動到命令按鈕時，您應該注意到組合框會擴充套件和隱藏。
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const CB_SHOWDROPDOWN = &H14F
Private Sub Combo1_GotFocus()
SendMessageLong Combo1.hwnd, CB_SHOWDROPDOWN, True, 0
End Sub
Private Sub Combo1_LostFocus()
SendMessageLong Combo1.hwnd, CB_SHOWDROPDOWN, False, 0
End Sub
Sub Form_Load()
Combo1.AddItem "Item 1"
Combo1.AddItem "Item 2"
Combo1.AddItem "Item 3"
End Sub
此程式碼演示了一個小函式，該函式反轉字串的內容。要測試它，請設定一個帶有單個命令按鈕和兩個文字框的窗體，然後貼上以下程式碼。如果您現在在文字框 1 中輸入文字“dlroW olleH”並按下命令按鈕，您將在文字框 2 中看到反轉結果，它應該顯示“Hello World”。
Option Explicit
Private Sub Command1_Click()
Text2 = ReverseStr(Text1.Text)
End Sub
Private Function ReverseStr(ByVal IPStr As String) As String
Dim i As Integer
For i = Len(IPStr) To 1 Step -1
ReverseStr = ReverseStr & Mid(IPStr, i, 1)
Next
End Function
控制元件在更新時閃爍是一個常見問題。這可能是由於 Windows 在更新期間多次更新控制元件的螢幕影像，或者 Windows 在監視器垂直重新整理期間更新控制元件。以下技術使您能夠在更新期間鎖定單個控制元件或整個窗體視窗，這使您可以指示 Windows 何時應該進行螢幕更新。減少閃爍的另一種方法是將窗體的 ClipControl 屬性設定為 false，這將強制 Windows 整體繪製窗體螢幕，而不是嘗試保留各個控制元件的外觀（它還可以提高應用程式的速度）。對於那些在閃爍圖形方面遇到問題的人，您應該考慮使用 API 呼叫 BitBlt（位塊傳輸）而不是像 Paintpicture 這樣的方法。
要測試以下程式碼，請建立一個新的 VB 專案，並在窗體上放置兩個命令按鈕和一個組合框。第一個按鈕將在控制元件被鎖定期間填充組合框。第二個按鈕將解鎖控制元件並允許 Windows 重新整理它。將 Hwnd 更改為反映您要鎖定的控制元件或窗體的名稱。
Private Declare Function LockWindowUpdate Lib "User32" (ByVal hWnd As Long) As Long
Private Sub Command1_Click()
Dim i As Integer
Combo1.Clear ' Clear and refresh the control to show the changes
Combo1.Refresh
' Lock the control to prevent redrawing
LockWindowUpdate Combo1.hWnd
' Update the control
For i = 0 To 200
Combo1.AddItem "Entry " & i, i
Next
Combo1.ListIndex = 150
End Sub
Private Sub Command2_Click()
' Unlock
LockWindowUpdate 0
End Sub
除了 Lastofmonth（Elliot Spener 的）之外，所有這些函式都是由 Simon Faulkner 傳送到 PCW 雜誌的。我發現這些日期函式非常方便，如果您還有其他有用的函式，請告訴我，我會將它們新增進來。
Firstofmonth = Now() - Day(Now()) + 1
Lastofmonth = DateAdd("m", 1, Date - Day(Date))
Firstofyear = Now() - Datepart("y", Now()) + 1
Lastofyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now()))
Daysinmonth = Datepart("d", Dateadd("m", 1, Now() - Day(Now))))
Daysleftinyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - Now()
Daysleftuntilchristmas = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - Now() - 7
Daysinyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - (Now() - Datepart("y", Now()))
Leapyear = IIf((Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - (Now() - Datepart("y", Now()))) = 366, True, False)
在圖片框上產生圓形爆炸效果，確保將其重新命名為 pic。X 和 Y 是圓心的座標，R 是爆炸效果的半徑。
For angle=1 to 360
pic.line (x,y) - (x + r * cos(angle*3.14159265358979/180),y + r * sin(angle*3.14159265358979/180))
next angle
如果您想將程式置於特定時間段的等待狀態，這將很有用。只需將以下程式碼貼上到新窗體中以測試它，並將其附加到命令按鈕，然後執行它 - 您可以在除錯視窗中檢視時間。1000 毫秒 = 1 秒（但您可能已經知道這一點）。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
Debug.Print "Started - " & Time()
Sleep 1000
Debug.Print "Ended - " & Time()
End Sub
如果隨機數生成器沒有啟動，隨機數就不是真正的隨機數，因此您需要在使用 Rnd() 之前啟動它。
Randomize()
用您自己的範圍替換 HighestNumber 和 LowestNumber。
X=Int((HighestNumber - LowestNum + 1) * Rnd + LowestNumber)
以下程式碼演示瞭如何將滑鼠游標從基本游標更改為動畫游標之一。開啟一個新專案，向窗體新增一個下拉列表和一個命令按鈕，然後新增以下程式碼並執行它。
Option Explicit
Public Const GCL_HCURSOR = -12
Declare Function ClipCursor Lib "user32" _
(lpRect As Any) _
As Long
Declare Function DestroyCursor Lib "user32" _
(ByVal hCursor As Any) _
As Long
Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
(ByVal lpFileName As String) _
As Long
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) _
As Long
Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) _
As Long
Private mhAniCursor As Long
Private mhBaseCursor As Long
Private lresult As Long
Private Sub Command1_Click()
' Sort out the user selection
If Combo1.ListIndex = 0 Then
lresult = SetClassLong((Form1.hwnd), GCL_HCURSOR, mhBaseCursor)
lresult = DestroyCursor(mhAniCursor)
Else
If Combo1.ListIndex = 1 Then
mhAniCursor = LoadCursorFromFile("C:\windows\cursors\hourglas.ani")
Else
mhAniCursor = LoadCursorFromFile("C:\windows\cursors\globe.ani")
End If
lresult = SetClassLong((Form1.hwnd), GCL_HCURSOR, mhAniCursor)
End If
End Sub
Private Sub Form_Load()
' Set up the list of cursor options
Combo1.AddItem "Normal", 0
Combo1.AddItem "HourGlass", 1
Combo1.AddItem "Globe", 2
Combo1.ListIndex = 0
' Grab the current base cursor
mhBaseCursor = GetClassLong((hwnd), GCL_HCURSOR)
End Sub
以下程式碼演示瞭如何將 13x13 點陣圖圖片（不是圖示）新增到每個選單項的左側。您可以為選中和未選中狀態定義不同的點陣圖（如所示），或者將這些值之一設定為零，如果您不想在特定狀態下顯示點陣圖。
該專案使用 2 個圖片框（每個圖片框都包含一個所需的點陣圖，並設定為不可見）、一個按鈕和任意數量的選單和子選單。
Private Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) _
As Long
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) _
As Long
Private Declare Function GetMenuItemID Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) _
As Long
Private 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
Private Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) _
As Long
Private Const MF_BITMAP = &H4&
Private Sub AddIconToMenus_Click()
Dim i1 As Long, i2 As Long, Ret As Long
Dim MnHndl As Long
Dim SMnHndl As Long
Dim MCnt As Long
Dim SMCnt As Long
Dim SMnID As Long
MnHndl = GetMenu(Form1.hwnd)' Get the menu handle for the current form
MCnt = GetMenuItemCount(MnHndl) ' Find out how many menus there are
For i1 = 0 To MCnt - 1 ' Process each menu entry
SMnHndl = GetSubMenu(MnHndl, i1) 'Get the next submenu handle for this menu
SMCnt = GetMenuItemCount(SMnHndl) 'Find out how many entries are in this submenu
For i2 = 0 To SMCnt - 1 'Process each submenu entry
SMnID = GetMenuItemID(SMnHndl, i2) 'Get each entry ID for the current submenu
' Add two pictures - one for checked and one for unchecked
Ret = SetMenuItemBitmaps(MnHndl, SMnID, MF_BITMAP, Picture2.Picture, Picture1.Picture)
Next i2
Next i1
End Sub
這段程式碼演示瞭如何將數字在十進位制、二進位制、八進位制和十六進位制之間進行轉換。
Public Function BinToDec(Num As String) As Long
Dim n As Integer
n = Len(Num) - 1
A = n
Do While n > -1
X = Mid(Num, ((A + 1) - n), 1)
BinToDec = IIf((X = "1"), BinToDec + (2 ^ (n)), BinToDec)
n = n - 1
Loop
End Function
Public Function OctToDec(Num As String) As Long
Dim n As Integer
Dim Y As Integer
n = Len(Num) - 1
A = n
Do While n > -7
X = Mid(Num, ((A + 1) - n), 1)
For Y = 1 To 7
OctToDec = IIf((X = CStr(Y)), OctToDec + (Y * (8 ^ (n))), OctToDec)
Next
n = n - 1
Loop
End Function
Public Function HexToDec(Num As String) As String
Dim n As Integer
Dim Y As Integer
Dim X As String
n = Len(Num) - 1
A = n
Do While n > -15
X = Mid(Num, ((A + 1) - n), 1)
For Y = 1 To 15
HexToDec = IIf((X = CStr(Y)), HexToDec + (Y * (8 ^ (n))), HexToDec)
Next
n = n - 1
Loop
End Function
Public Function DecToBin(DeciValue As Long, Optional NoOfBits As Integer = 8) As String
Dim i As Integer
On Error Resume Next
Do While DeciValue > (2 ^ NoOfBits) - 1
NoOfBits = NoOfBits + 8
Loop
DecToBin = ""
For i = 0 To (NoOfBits - 1)
DecToBin = CStr((DeciValue And 2 ^ i) / 2 ^ i) & DecToBin
Next i
End Function
Public Function DecToOct(Num as Long) as Long
DecToOct = Oct$(Num)
End Function
Public Function DecToHex(Num as String) as String
DecToHex = Hex$(Num)
End Function
以下程式碼演示瞭如何啟動任何給定檔案的預設“開啟”操作（通常意味著啟動處理該型別資料檔案的應用程式）。我還包括一個 ShellExecute 的變體，它允許您啟動預設的系統 Internet 瀏覽器，並讓它立即跳轉到指定的網站。
' Required declarations
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) _
As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Const SW_SHOWDEFAULT = 10
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOWNORMAL = 1
Private Sub Command1_Click()
' Open the browser and goto a specified site
Dim DWHdc As Long, Ret As Long
Dim PathAndFile As String
PathAndFile = File1.Path & "\" & File1.filename
' Use the desktop window as the parent
DWHdc = GetDesktopWindow()
Ret = ShellExecute(DWHdc, "Open", Text1.Text, "", "c:\", SW_SHOWMAXIMIZED)
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_DblClick()
' Launch the default "Open" action for the file
Dim DWHdc As Long, Ret As Long
Dim PathAndFile As String
PathAndFile = File1.Path & "\" & File1.filename
' Use the desktop window as the parent
DWHdc = GetDesktopWindow()
Ret = ShellExecute(DWHdc, "Open", PathAndFile, "", File1.Path, SW_SHOWNORMAL)
End Sub
如果您厭倦了矩形表單上的矩形控制元件，請嘗試以下程式碼。開啟一個新專案，在其上放置一個命令按鈕，將此程式碼貼上進去，然後執行它。您應該在圓形表單上看到一個圓形按鈕，它適用於大多數控制元件。程式碼相當簡單，您計算所需的橢圓大小，然後將其透過兩個 API 呼叫傳遞。只要玩一玩，您就可以獲得一些非常奇特的效果。
Private hwndDest As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" _
(ByVal hWnd As Long, ByVal hRgn As Long, _
ByVal bRedraw As Long) As Long
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim hr&, dl&
Dim usew&, useh&
hwndDest = Me.hWnd
usew& = Me.Width / Screen.TwipsPerPixelX
useh& = Me.Height / Screen.TwipsPerPixelY
hr& = CreateEllipticRgn(0, 0, usew&, useh&)
dl& = SetWindowRgn(hwndDest, hr, True)
hwndDest = Command1.hWnd
usew& = Command1.Width / Screen.TwipsPerPixelX
useh& = Command1.Height / Screen.TwipsPerPixelY
hr& = CreateEllipticRgn(0, 0, usew&, useh&)
dl& = SetWindowRgn(hwndDest, hr, True)
End Sub
這是一個客戶端-伺服器點對點 TCP 透過 Winsock 片段，其設定是硬編碼的。該片段將透過迴環介面卡透過埠 50000 連線到伺服器，對話將是客戶端傳送“Hello World”訊息給伺服器，伺服器將在 MsgBox 上顯示該訊息。伺服器只能接受來自一個客戶端的一個連線，如果來自另一個客戶端的第二個連線請求，它將斷開第一個連線（因此，點對點）。有關點對多點程式碼（伺服器允許來自多個客戶端的多個連線），請參見下文。
新增以下控制元件
- Winsock 控制元件 - 名稱="sckClient"
- 命令按鈕 - 名稱="Command1"，標題="說“Hello World”"
- 命令按鈕 - 名稱="Command2"，標題="建立連線"
- (可選) 計時器 - 名稱="Timer1"，間隔="1"，啟用="True"
Option Explicit
Private Sub Command1_Click()
' If connected, send data, if not, popup a msgbox telling to connect first
If sckClient.State <> sckConnected Then
MsgBox "Connect First"
Else
sckClient.SendData "Hello World"
End If
End Sub
Private Sub Command2_Click()
' If there is already a connection, close it first,
' failure of doing this would result in an error
If sckClient.State <> sckClosed Then sckClient.Close
' OK, the winsock is free, we could open a new connection
sckClient.Connect "127.0.0.1", 50000
End Sub
Private Sub Timer1_Timer()
' Code for seeing the status of the winsock in the form window.
' For the meaning of the Status Code, go to the Object Browser (F2) and search for Winsock
Me.Caption = sckClient.State
End Sub
新增以下控制元件
- Winsock 控制元件 - 名稱="sckServer"
- (可選) 計時器 - 名稱="Timer1"，間隔="1"，啟用="True"
Option Explicit
Private Sub Form_Load()
' Listen to port 50000 for incoming connection from a client
sckServer.LocalPort = 50000
sckServer.Listen
End Sub
Private Sub sckServer_Close()
' If the connection is closed, restart the listening routine
' so other connection can be received.
sckServer.Close
sckServer.Listen
End Sub
Private Sub sckServer_ConnectionRequest(ByVal requestID As Long)
' If the connection is not closed close it first before accepting a connection
' You can alter this behaviour, like to refuse the second connection
If sckServer.State <> sckClosed Then sckServer.Close
sckServer.Accept requestID
End Sub
Private Sub sckServer_DataArrival(ByVal bytesTotal As Long)
Dim Data As String
' Receive the data (GetData),
' Clear the data buffer (automatic with calling GetData),
' Display the data on a MsgBox
sckServer.GetData Data
MsgBox Data
End Sub
Private Sub Timer1_Timer()
' Code for seeing the status of the winsock in the form window.
' For the meaning of the Status Code, go to the Object Browser (F2) and search for Winsock
Me.Caption = sckServer.State
End Sub
此片段與上面的 TCP/Winsock - 點對點連線相同，但此程式碼允許伺服器同時接收來自多個客戶端的多個連線。此行為是透過使用控制陣列實現的。Winsock 控制元件陣列索引 0 是一個特殊的索引，因為它從不開啟，它只會監聽傳入的連線，並在有傳入的連線時分配給另一個 Winsock 控制元件。伺服器程式碼被編碼為重用已關閉的現有 WinSock 控制元件以接收新連線。客戶端程式碼與點對點片段相同。客戶端永遠不會解除安裝已開啟的 Winsock 控制元件。在嘗試實現點對多點連線之前，您應該瞭解點對點連線。
與點對點客戶端程式碼的客戶端程式碼相同
新增以下控制元件
- Winsock 控制元件 - 名稱="sckServer"，索引="0"
- (可選) 計時器 - 名稱="Timer1"，間隔="1"，啟用="True"
Private Sub Form_Load()
' Open a listening routine on port 50000
sckServer(0).LocalPort = 50000
sckServer(0).Listen
End Sub
Private Sub sckServer_Close(Index As Integer)
' Close the WinSock so it could be reopened if needed
sckServer(Index).Close
End Sub
Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
Dim sock As Winsock
' If there is any closed Winsock, accept on that Winsock
For Each sock In sckServer
If sock.State = sckClosed Then
sock.Accept requestID
Exit Sub
End If
Next
' Else make a new Winsock
Load sckServer(sckServer.UBound + 1)
sckServer(sckServer.UBound).Accept requestID
End Sub
Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim Data As String
' Receive the data (GetData) for the connection that is receiving,
' Clear the data buffer (automatic with calling GetData) of the receiving connection,
' Display the data on a MsgBox with the index of the receiving Winsock
sckServer(Index).GetData Data, vbString
MsgBox Data & vbCrLf & Index
End Sub
Private Sub Timer1_Timer()
Dim conn As Winsock
' Display the status for all connection on the window bar
' The status code is space-separated
Me.Caption = ""
For Each conn In sckServer
Me.Caption = Me.Caption & " " & conn.State
Next
End Sub
| 先前: 最佳化 Visual Basic | 目錄 | 接下來: 語言 |