Visual Basic 技巧库
第 4 部分 (31-40)
打开和关闭其他应用 打开和关闭其他应用 Declare Function FindWindow Lib
"user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As
String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal
hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As
Long 打开应用: Private Sub Command1_Click() Shell "Calc.exe",
vbNormalFocus End Sub 关闭应用: Private Sub Command2_Click() Dim
lpClassName As String Dim lpCaption As String Dim Handle As Long
Const NILL = 0& Const WM_SYSCOMMAND = &H112 Const SC_CLOSE
= &HF060&
lpClassName = "SciCalc" lpCaption = "Calculator" '* Determine the
handle to the Calculator window. Handle = FindWindow(lpClassName$,
lpCaption$) '* Post a message to Calc to end its existence. Handle =
SendMessage(Handle, WM_SYSCOMMAND, SC_CLOSE, NILL) End Sub
打开浏览器并进入指定网址 打开浏览器并进入指定网址 声明:
Private Declare Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile
As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal
nShowCmd As Long) As Long
例子: Dim ret& ret& = ShellExecute(Me.hwnd, "Open",
"http://vbmw.yeah.net", "", App.Path, 1) End Sub 也可以直接发送 Mail,只要把以上的 http
地址换为 "mailto:vvv123@163.net"
代码块注释和块取消注释 代码块注释和块取消注释 VB5
的新功能,你可以成块地将代码注释或取消注释,在调试时特别有用。请使用 注释块/取消注释块
命令对。 “注释块”和“取消注释块”命令可以在“编辑”工具栏中找到。使用这些命令使多行代码成为注释块,或从一块代码中删除注释字符:
1.
添加“编辑”工具栏。在“编辑”菜单上选择“工具栏”命令,然后选择“编辑”;或将光标放在工具栏上,按右鼠标键,然后选择“编辑”。 2.
打开代码模块,并且突出显示希望创建注释块的代码,或希望从中删除注释字符的代码。 3.
按“编辑”工具栏上的“注释块”或“取消注释块”按钮。
或者代码将移入一个块,并且添加了注释字符;或者被分离成独立的代码片段,并且从中删除了注释字符。
弹出驱动器 below is example for how to open
& close CD-ROM drive.
'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
'Open CD drive door retvalue =
mciSendString("set CDAudio door open", returnstring, 127, 0)
'Close CD drive door retvalue =
mciSendString("set CDAudio door closed", returnstring, 127,0)
当前系统目录 当前系统目录 声明: Declare Function
GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer
As String, ByVal nSize As Long) As Long Declare Function GetSystemDirectory
Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal
nSize As Long) As Long 例子: Dim S As String * 80, Length As Long Dim
WinPath As String, SysPath As String Length = GetWindowsDirectory(S, Len(S))
WinPath = Left(S, Length) Length = GetSystemDirectory(S, Len(S))
SysPath = Left(S, Length)
WinPath 为 Windows 的所在目录,SysPath 为 System 所在目录。
得到鼠标位置 得到鼠标位置 声明: Private Type POINTAPI
x As Long y As Long End Type
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
例子: Dim p As POINTAPI Call GetCursorPos( p ) ' ( p.x, p.y
)为鼠标位置
动态改变屏幕设置 动态改变屏幕设置 Private Declare Function lstrcpy
Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any)
As Long Const CCHDEVICENAME = 32 Const CCHFORMNAME = 32 Private Type
DEVMODE dmDeviceName As String * CCHDEVICENAME 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
* CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As
Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As
Long dmDisplayFrequency As Long End Type Private Declare Function
_ ChangeDisplaySettings Lib _ "User32" Alias "ChangeDisplaySettingsA"
(_ ByVal lpDevMode As Long, _ ByVal dwflags As Long) As
Long '函数 Public Function SetDisplayMode(Width As _ Integer,Height As
Integer, Color As _ Integer) As Long Const DM_PELSWIDTH =
&H80000 Const DM_PELSHEIGHT = &H100000 Const DM_BITSPERPEL =
&H40000 Dim NewDevMode As DEVMODE Dim pDevmode As Long With
NewDevMode .dmSize = 122 If Color = -1 Then .dmFields = DM_PELSWIDTH Or
DM_PELSHEIGHT Else .dmFields = DM_PELSWIDTH Or _ DM_PELSHEIGHT Or
DM_BITSPERPEL End If .dmPelsWidth = Width .dmPelsHeight = Height
If Color <> -1 Then .dmBitsPerPel = Color End If End
With pDevmode = lstrcpy(NewDevMode, NewDevMode) SetDisplayMode =
ChangeDisplaySettings(pDevmode, 0) End Function 例子调用:改变为 640x480x24位:
i = SetDisplayMode(640, 480, 24) 如果成功返回 0 。
断开所有的数据连接 断开所有的数据连接 98-8-21 如果在代码中使用了数据控件如 DAO, RDO, 或
ADO, 在退出时应该关闭所有打开的 recordset, database,和 workspace 。
虽然对象能自动注销, 但是数据连接不会马上断开, 可能会导致一些内存不能被系统重新分配。
下面的代码可以关闭所有打开的 DAO workspace, 并释放所占的内存。
Private Sub Form_Unload(Cancel As Integer) On Error
Resume Next ' Dim ws As
Workspace Dim db As Database Dim rs As
Recordset ' For Each ws In
Workspaces For Each db In
ws.Databases For
Each rs In
db.Recordsets rs.Close Set
rs =
Nothing Next db.Close Set
db =
Nothing Next ws.Close Set
ws = Nothing Next ' End Sub
断开与 Internet
的连接 断开与 Internet 的连接 98-7-20 声明: 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 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
对ListView中的列排序 001 对ListView中的列排序 设置 ListView 控件到
report 视图。下面的代码允许你使用 任何的列进行排序,主要在列头上点击。 如果已经排序,顺序将反一下。
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As
ColumnHeader) With ListView1 If (ColumnHeader.Index - 1) = .SortKey
Then .SortOrder = (.SortOrder + 1) Mod 2 Else .Sorted =
False .SortOrder = 0 .SortKey = ColumnHeader.Index - 1 .Sorted =
True End If End With End Sub
|