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 | 目录 | 接下来: 语言 |