肛周脓肿排脓后:VB技巧集锦

VB技巧集锦
━━━━━━━━━━━━━━━━━━━━━━━━━━
'按字母或数字顺序排列列表框中的列表项.
'将以下代码加入到你的程序中.
Sub ReSort(L As Control)
Dim P%, PP%, c%, Pre$, s$, V&, NewPos%, CheckIt%
Dim TempL$, TempItemData&, S1$
For P = 0 To L.ListCount - 1
s = L.List(P)
For c = 1 To Len(s)
V = Val(Mid$(s, c))
If V > 0 Then Exit For
Next
If V > 0 Then
If c > 1 Then Pre = Left$(s, c - 1)
NewPos = -1
For PP = P + 1 To L.ListCount - 1
CheckIt = False
S1 = L.List(PP)
If Pre <> "" Then
If InStr(S1, Pre) = 1 Then CheckIt = True
Else
If Val(S1) > 0 Then CheckIt = True
End If
If CheckIt Then
If Val(Mid$(S1, c)) < V Then NewPos = PP
Else
Exit For
End If
Next
If NewPos > -1 Then
TempL = L.List(P)
TempItemData = L.ItemData(P)
L.RemoveItem (P)
L.AddItem TempL, NewPos
L.ItemData(L.NewIndex) = TempItemData
P = P - 1
End If
End If
Next
Exit Sub
'---------------------------------------------------
'Tag属性的妙用.
'在VB编程中,我们经常要动态的控制很多不同控件的属性,例如我们要将一个CommandButton阵列共20各控件中的第1、4、6、7、8、11、18、20号删除。该怎么半呢？这时只要将要删除的控件的Tag属性设置为1，然后加入以下代码就可以了。
For i = 1 To 20
If command1(i).Tag = 1 Then
Unload command1(i)
End If
Next i
'-----------------------------------------------------
'利用VB产生屏幕变暗的效果.
'想利用VB编程实现屏幕变暗的效果（向关闭Win95时的效果），只要按下面的步骤来做
'1、在FORM1中加入两个CommandButton和一个PictureBox.
'2 Print 在FORM1的代码窗口中添加以下代码:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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 CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long
Private hDesktopWnd As Long
Private Sub Command1_Click()
Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Long
hdc5 = GetDC(0)
width5 = Screen.Width \ Screen.TwipsPerPixelX
height5 = Screen.Height \ Screen.TwipsPerPixelY
rop = &HA000C9
Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop)
Call DeleteObject(hBrush)
res = ReleaseDC(0, hdc5)
End Sub
Private Sub Command2_Click()
Dim aa As Long
aa = InvalidateRect(0, 0, 1)
End Sub
Private Sub FORM_Load()
Dim ary
Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0)
For i = 1 To 16
bybits(i) = ary(i - 1)
Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
Picture1.ForeColor = #000000
Picture1.BackColor = #ffffff
Picture1.ScaleMode = 3
End Sub
'运行程序，按Command1就可以使屏幕暗下来，按Command2恢复。
'--------------------------------------------------
'使两个列表框(ListBox)的选项同步步骤1
'在FORM中添加两个ListBox和一个CommandButton一个Timer,不要改动他们的属性.
步骤2
在FORM中添加如下代码:
Private Sub FORM_Load()
Dim x As Integer
For x = 1 To 26
list1.AddItem Chr$(x + 64)
Next x
For x = 1 To 26
List2.AddItem Chr$(x + 64)
Next x
Timer1.INTERVAL = 1
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
End
End Sub
Private Sub Timer1_Timer()
Static PrevList1
Dim TopIndex_List1 As Integer
TopIndex_List1 = list1.TopIndex
If TopIndex_List1 <> PrevList1 Then
List2.TopIndex = TopIndex_List1
PrevList1 = TopIndex_List1
End If
If list1.ListIndex <> List2.ListIndex Then
List2.ListIndex = list1.ListIndex
End If
End Sub
'运行程序,当选中其中一个列表框中的某一项后,另外一个列表框中的相应项就会被选中.
'-------------------------------------------------
'获得Win9X下文件的短文件名(8.3文件名)
'步骤一　在FORM中加入一个FileListBox,一个DirListBox,一个Label.
'步骤二 在FORM中加入以下代码:
'Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal
'lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Sub Dir1_Change()
File1 = dir1.path
End Sub
Private Sub Drive1_Change()
dir1 = drive1
End Sub
Private Sub File1_Click()
Label1.Caption = GetShortFileName(dir1 & "\" & File1)
End Sub
Public Function GetShortFileName(ByVal FileName As String) As String
'converts a long file and path name to old DOS FORMat
'PARAMETERS
' FileName = the path or filename to convert
'RETURNS
' String = the DOS compatible name for that particular FileName
Dim rc As Long
Dim ShortPath As String
Const PATH_LEN& = 164
'get the short filename
ShortPath = String$(PATH_LEN + 1, 0)
rc = GetShortPathName(FileName, ShortPath, PATH_LEN)
GetShortFileName = Left$(ShortPath, rc)
End Function
'---------------------------------------------------------------------
使指定窗口总处于其他窗口之上
'将以下代码加入到FORM中,这个FORM就成为一个在其他所有窗口之上的窗口了.
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 HWND_TOPMOST = -1
Private Sub FORM_Load()
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX _
, Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
Me.Height \ Screen.TwipsPerPixelY, 0
End Sub
'--------------------------------------------------
获得位图文件的信息
在FORM中添加一个Picture控件和一个CommandButton控件 , 在Picture控件中加入一个位图文件, 将下面代码加入其中:
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Sub Command1_Click()
Dim hBitmap As Long
Dim res As Long
Dim bmp As BITMAP
Dim byteAry() As Byte
Dim totbyte As Long, i As Long
hBitmap = Picture1.Picture.Handle
res = GetObject(hBitmap, Len(bmp), bmp) '取得BITMAP的结构
totbyte = bmp.bmWidthBytes * bmp.bmHeight '总共要多少BYTE来存图
ReDim byteAry(totbyte - 1)
'将Picture1中的图信息存到ByteAry
res = GetBitmapBits(hBitmap, totbyte, byteAry(0))
Debug.Print "Total Bytes Copied :"; res
Debug.Print "bmp.bmBits "; bmp.bmBits
Debug.Print "bmp.bmBitsPixel "; bmp.bmBitsPixel '每相素位数
Debug.Print "bmp.bmHeight "; bmp.bmHeight '以相素计算图象高度
Debug.Print "bmp.bmPlanes "; bmp.bmPlanes
Debug.Print "bmp.bmType "; bmp.bmType
Debug.Print "bmp.bmWidth "; bmp.bmWidth '以相素计算图形宽度
Debug.Print "bmp.bmWidthBytes "; bmp.bmWidthBytes '以字节计算的每扫描线长度
End Sub
'---------------------------------------------------
'获得驱动器的卷标
'在FORM中添加一个CommandButton控件 , 再加入一下一段代码:
Private Declare Function GetVolumeInFORMation Lib "kernel32" Alias "GetVolumeInFORMationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Const FILE_VOLUME_IS_COMPRESSED = &H8000
Public Sub GetVolInfo(ByVal path As String)
Dim aa As Long
Dim VolName As String
Dim fsysName As String
Dim VolSeri As Long, compress As Long
Dim Sysflag As Long, Maxlen As Long
'初试化字符串的长度
VolName = String(255, 0)
fsysName = String(255, 0)
aa = GetVolumeInFORMation(path, VolName, 256, VolSeri, Maxlen, Sysflag, fsysName, 256)
VolName = Left(VolName, InStr(1, VolName, Chr(0)) - 1)
fsysName = Left(fsysName, InStr(1, fsysName, Chr(0)) - 1)
compress = Sysflag And FILE_VOLUME_IS_COMPRESSED
If compress = 0 Then
Me.Print "未压缩驱动器"
Else
Me.Print "压缩驱动器"
End If
Me.Print "驱动器卷标 :", VolName
Me.Print "驱动器标号 : ", Hex(VolSeri)
Me.Print "驱动器文件系统 (FAT, HPFS, or NTFS)", fsysName
Me.Print "支持的文件名长度", Maxlen
End Sub
Private Sub Command1_Click()
FORM1.Caption = "c:驱动器信息"
Call GetVolInfo("c:\")
End Sub
'---------------------------------------------------
将包含有Null结尾的字符串转换为VB字符串
在VB编程调用Windows API函数时, 经常会碰到以Null结尾的字符串, 下面是一段将Null结尾字符串转换到VB字符串的函数:
Public Function LPSTRToVBString$(ByVal s$)
Dim nullpos&
nullpos& = InStr(s$, Chr$(0))
If nullpos > 0 Then
LPSTRToVBString = Left$(s$, nullpos - 1)
Else
LPSTRToVBString = ""
End If
End Function
'---------------------------------------------------
启动控制面板命令
控制面板
模块: Control.Exe
命令: rundll32.Exe shell32.dll, Control_RunDLL
结果: 显示控制面板窗口?
例子:
Dim x
x = Shell("rundll32.exe shell32.dll,Control_RunDLL")
辅助选项
模块: access.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5
'结果： 显示辅助选项/常规。
'命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1
'结果： 显示辅助选项/键盘。
'命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2
'结果： 显示辅助选项/声音。
'命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3
'结果： 显示辅助选项/显示。
'命令： rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4
'结果： 显示辅助选项/鼠标。
'添加新硬件
'模块: sysdm.cpl
'命令：rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1
'增加新的打印机
'模块: shell32.dll
'命令：rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter
'添加/删除程序
'模块: appwiz.cpl
'命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1
'结果：显示安装/卸载。
'命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1
'结果：显示安装/卸载。
'命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2
'结果: 显示Windows 安装?
'命令：rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3
'结果: 显示启动盘?
'复制磁盘
'模块: diskcopy.dll
'命令: rundll32.Exe diskcopy.dll, DiskCopyRunDll
'时间/日期
'模块: timedate.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,0
'结果： 显示设置日期/时间。
'命令： rundll32.exe shell32.dll,Control_RunDLL timedate.cpl,,1
'结果: 显示设置时间区域?
'拨号连接 (DUN)
'模块: rnaui.dll
'命令： rundll32.exe rnaui.dll,RnaDial 连接_名称
'结果: 打开指定的拨号连接?
'例子:
x = Shell("rundll32.exe rnaui.dll,RnaDial " & "连接_名称", 1)
'显示器
'模块: desk.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0
'结果: 背景设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1
'结果: 屏幕保护设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2
'结果: 外观设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3
'结果: 设置窗口?
'操纵杆
'模块: joy.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL joy.cpl
'邮件/传真
'模块: mlcfg32.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL mlcfg32.cpl
'结果： 出现 MS Exchange 属性设置。
'邮局设置
'模块: wgpocpl.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL wgpocpl.cpl
'结果： 显示 MS Postoffice Workgroup Admin 设置。
'主设置
'模块: Main.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @0
'结果: 显示鼠标属性?
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1
'结果： 显示键盘/速度属性。
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,1
'结果： 显示键盘/语言属性。
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @1,,2
'结果： 显示键盘/常规属性。
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @2
'结果: 显示打印机属性?
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @3
'结果: 显示字体属性?
'命令： rundll32.exe shell32.dll,Control_RunDLL main.cpl @4
'结果: 显示电源管理属性?
'增加 modem
'模块: modem.cpl
'命令：rundll32.exe shell32.dll,Control_RunDLL modem.cpl,,add
'多媒体
'模块: mmsys.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0
'结果: 声音?
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,1
'结果: 视频?
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2
'结果: 声音 MIDI?
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,3
'结果：CD/音乐。
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,4
'结果: 高级?
'命令： rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1
'结果: 声音?
'网络
'模块: netcpl.cpl
'命令：rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl
'打开方式窗口(Open With)
'模块: shell32.dll
'命令：rundll32.exe shell32.dll,OpenAs_RunDLL path\filename
'口令
'模块: password.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL password.cpl
'区域设置
'模块: intl.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0
'结果: 区域设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,1
'结果: 数字格式设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,2
'结果: 金额格式设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,3
'结果: 时间格式设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,4
'结果: 日期格式设置?
'屏幕保护
'模块: appwiz.cpl
'命令： rundll32.exe desk.cpl,InstallScreenSaver c:\win\system\Flying Windows.scr
'结果: 安装屏幕保护并显示预览属性页?
'系统设置
'模块: sysdm.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0
'结果: 显示常规设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1
'结果: 显示设备管理设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2
'结果: 显示硬件设置?
'命令： rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3
'结果: 显示性能设置?
'IE4 设置
'模块: inetcpl.cpl
'命令： rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl
'----------------------------------------------------------
'音效档播放程式
'所需物件：PictureBox(1),Label(6),CommandButton(2),CommonDialog(1),MMControl(1)。
Const INTERVAL = 1000
Dim CurVal As Double
Private Sub CmdEnd_Click()
MMControl1.Command = "stop"
MMControl1.Command = "close"
End
End Sub
Private Sub CmdOpen_Click()
MMControl1.Command = "stop"
MMControl1.Command = "close"
Close #1
On Error GoTo errhandler
CMDlg.Filter = "音效档(*.wav;*.mid) |*.wav;*.mid"
CMDlg.FilterIndex = 1
CMDlg.Action = 1
Open CMDlg.FileName For Input As #1
If Right$(CMDlg.FileName, 3) = "wav" Then
MMControl1.DeviceType = "waveaudio"
Else
MMControl1.DeviceType = "sequencer"
End If
MMControl1.FileName = CMDlg.FileName
MMControl1.Command = "open"
CurVal = 0#
MMControl1.UpdateInterval = 0
errhandler:
Exit Sub
End Sub
Private Sub FORM_Load()
Label1.Caption = "音效档名："
Label2.Caption = "总共时间："
Label3.Caption = "目前位置："
MMControl1.UpdateInterval = 0
End Sub
Private Sub FORM_Unload(Cancel As Integer)
Const MCI_MODE_NOT_OPEN = 524
If Not MMControl1.Mode = MCI_MODE_NOT_OPEN Then
MMControl1.Command = "close"
End If
End Sub
Private Sub MMControl1_PauseClick(Cancel As Integer)
MMControl1.UpdateInterval = 0
CurVal = CurVal
End Sub
Private Sub MMControl1_PlayClick(Cancel As Integer)
MMControl1.UpdateInterval = INTERVAL
End Sub
Private Sub MMControl1_PrevClick(Cancel As Integer)
CurVal = 0#
End Sub
Private Sub MMControl1_StatusUpdate()
MMControl1.TimeFORMat = 0
CurVal = CurVal + MMControl1.UpdateInterval + 54
Now_position = CurVal
Now_Min = Int(Now_position / 1000 / 60)
Now_Sec = Int(Now_position / 1000) Mod 60
Total_Min = Int(MMControl1.Length / 1000 / 60)
Total_Sec = Int(MMControl1.Length / 1000) Mod 60
Label4.Caption = MMControl1.FileName
Label5.Caption = Format(Total_Min, "00") + ":" + Format(Total_Sec, "00")
Label6.Caption = Format(Now_Min, "00") + ":" + Format(Now_Sec, "00")
If MMControl1.PlayEnabled = False And Now_Min = Total_Min And Now_Sec = Total_Sec Then
CurVal = 0#
MMControl1.UpdateInterval = 0
MMControl1.Command = "prev"
MMControl1.Command = "stop"
End If
End Sub
Private Sub MMControl1_StopClick(Cancel As Integer)
CurVal = 0#
MMControl1.UpdateInterval = 0
MMControl1.Command = "prev"
End Sub
'--------------------------------------------------
如何播放WAV文件
Sub PlayWav(SoundName As String)
Dim tmpSoundName As String
Dim wFlags%, x%
' declare statements (Place in a bas module.)
''**********************************
'#If Win32 Then
'Public Declare Function sndPlaySound& Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long)
'#Else
'Public Declare Function sndPlaySound% Lib "mmsystem.dll" (ByVallpszSoundName As String, ByVal uFlags As Integer)
'#End If 'WIN32
' **********************************
' WAV Sound values
'Global Const SND_SYNC = &H0
'Global Const SND_ASYNC = &H1
'Global Const SND_NODEFAULT = &H2
'Global Const SND_LOOP = &H8
'Global Const SND_NOSTOP = &H10
' **********************************
' *** pathWavFiles is a var with the subDir where
' the sound files are stored
tmpSoundName = pathWavFiles & SoundName
wFlags% = SND_ASYNC Or SND_NODEFAULT
x% = sndPlaySound(tmpSoundName, wFlags%)
End Sub
'--------------------------------------------------
如何用API及MMSYSTEM.DLL播放WAV文件
Declare Function sndPlaySound% Lib "MMSYSTEM.DLL" (ByVal lpszSoundName$, ByVal wFlags%)
Global Const SND_SYNC = &H0
Global Const SND_ASYNC = &H1
Global Const SND_NODEFAULT = &H2
Global Const SND_LOOP = &H8
Global Const SND_NOSTOP = &H10
' Paramaters:
' lpszSoundName$
'　 Specifies the name of the sound to play. The function first
' searches the [sounds] section of the WIN.INI file for an entry
' with the specified name, and plays the associated waveFORM sound
' file. If no entry by this name exists, then it assumes the
' specified name is the name of a waveFORM sound file. If this
' parameter is NULL, any currently playing sound is stopped.
' That is, use a 0& to provide a NULL value.
' wFlags%
'　 Specifies options for playing the sound using one or more
' of the following flags:
' SND_SYNC: The sound is played synchronously and the function
' does not return until the sound ends.
' SND_ASYNC: The sound is played asynchronously and the function
' returns immediately after beginning the sound.
' SND_NODEFAULT: If the sound cannot be found, the function returns
' silently without playing the default sound.
' SND_LOOP: The sound will continue to play repeatedly until
' sndPlaySound is called again with the lpszSoundName$ parameter
' set to null.
' You must also specify the SND_ASYNC flag to loop sounds.
' SND_NOSTOP: If a sound is currently playing, the function will
' immediately return False without playing the requested sound.
' Add the following code to the appropriate routine:
Dim SoundName$
Dim wFlags%
Dim x%
SoundName$ = "c:\windows\tada.wav" ' The file to play
wFlags% = SND_ASYNC Or SND_NODEFAULT
x% = sndPlaySound(SoundName$, wFlags%)
'---------------------------------------------------
怎样检查声卡的存在
Declare Function auxGetNumDevs% Lib "MMSYSTEM" ()
' In the appropriate routine:
Dim i As Integer
i = auxGetNumDevs()
If i > 0 Then ' There is at least one sound card on the system
MsgBox "A Sound Card has been detected."
Else ' auxGetNumDevs returns a 0 if there is no sound card
MsgBox "There is no Sound Card on this system."
End If
'---------------------------------------------------
如何用API及MMSYSTEM.DLL播放AVI文件
Declare Function mciSendString& Lib "MMSYSTEM" (ByVal pstrCommand$, ByVal lpstrReturnStr As Any, ByVal wReturnLen%, ByVal CallBack%)
'Add this code to the appropriate event:
Dim CmdStr$
Dim ReturnVal&
' Modify path and filename as necessary
CmdStr$ = "play G:\VFW_CINE\AK1.AVI"
ReturnVal& = mciSendString(CmdStr$, 0&, 0, 0&)
' To play the AVI 'fullscreen' append to CmdStr$:
CmdStr$ = "play G:\VFW_CINE\AK1.AVI fullscreen"
'----------------------------------------------------
'如何从"SOUND.DRV"中提取声音
Declare Function OpenSound% Lib "sound.drv" ()
Declare Function VoiceQueueSize% Lib "sound.drv" (ByVal nVoice%, ByVal nByteS)
Declare Function SetVoiceSound% Lib "sound.drv" (ByVal nSource%, ByVal Freq&, ByVal nDuration%)
Declare Function StartSound% Lib "sound.drv" ()
Declare Function CloseSound% Lib "sound.drv" ()
Declare Function WaitSoundState% Lib "sound.drv" (ByVal State%)
' Add this routine, to be used with SirenSound1 routine
Sub Sound(ByVal Freq As Long, ByVal Duration As Integer)
Dim s As Integer
' Shift frequency to high byte.
Freq = Freq * 2 ^ 16
s = SetVoiceSound(1, Freq, Duration)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
End Sub
' Here are the 4 sound routines:
'* Attention Sound #1 *
Sub AttenSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 1500 * 2 ^ 16, 50)
s = SetVoiceSound(1, 1000 * 2 ^ 16, 50)
s = SetVoiceSound(1, 1500 * 2 ^ 16, 100)
s = SetVoiceSound(1, 1000 * 2 ^ 16, 100)
s = SetVoiceSound(1, 800 * 2 ^ 16, 40)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
'* Click Sound #1 *
Sub ClickSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 200 * 2 ^ 16, 2)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
'* Error Sound #1 *
Sub ErrorSound1()
Dim Succ, s As Integer
Succ = OpenSound()
s = SetVoiceSound(1, 200 * 2 ^ 16, 150)
s = SetVoiceSound(1, 100 * 2 ^ 16, 100)
s = SetVoiceSound(1, 80 * 2 ^ 16, 90)
s = StartSound()
While (WaitSoundState(1) <> 0): Wend
Succ = CloseSound()
End Sub
'* SirenSound #1 *
Sub SirenSound1()
Dim Succ As Integer
Dim j As Long
Succ = OpenSound()
For j = 440 To 1000 Step 5
Call Sound(j, j / 100)
Next j
For j = 1000 To 440 Step -5
Call Sound(j, j / 100)
Next j
Succ = CloseSound()
End Sub
'---------------------------------------------------
如何用API播放CD
Declare Function mciSendString& Lib "MMSYSTEM" (ByVal lpstrCommand$, ByVal lpstrReturnStr As Any, ByVal wReturnLen%, ByVal hCallBack%)
'Add the code below to appropriate routines
Sub cmdPlay_Click()
Dim lRet As Long
Dim nCurrentTrack As Integer
'Open the device
lRet = mciSendString("open cdaudio alias cd wait", 0&, 0, 0)
'Set the time FORMat to Tracks (default is milliseconds)
lRet = mciSendString("set cd time FORMat tmsf", 0&, 0, 0)
'Then to play from the beginning
lRet = mciSendString("play cd", 0&, 0, 0)
'Or to play from a specific track, say track 4
nCurrentTrack = 4
lRet = mciSendString("play cd from" & Str(nCurrentTrack), 0&, 0, 0)
End Sub
' Remember to Close the device when ending playback
Sub cmdStop_Click()
Dim lRet As Long
'Stop the playback
lRet = mciSendString("stop cd wait", 0&, 0, 0)
DoEvents 'Let Windows process the event
'Close the device
lRet = mciSendString("close cd", 0&, 0, 0)
End Sub
'---------------------------------------------------
获得系统中的所有字体列表
'在FORM1中加入一个ListBox，并在FORM1中加入如下代码：
Private Sub FORM_Load()
Dim counter As Integer
For counter = 0 To Screen.FontCount - 1
list1.AddItem Screen.Fonts(counter)
Next
End Sub
Private Sub List1_Click()
Static tempheight As Single
If tempheight = 0 Then tempheight = list1.Height
list1.Font.Name = list1.List(list1.ListIndex)
list1.Height = tempheight
End Sub
'------------------------------------------------
如何关闭一个程序
下面演示如何利用FindWindow函数找到窗口并利用SendMessage函数关闭窗口
在FORM1中加入如下代码:
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, lParam As Any) As Long
Const WM_CLOSE = &H10
Private Sub FORM_Click()
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "FORM1")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "发送消息错误."
End If
Else
MsgBox "FORM1窗口不存在"
End If
End Sub
'运行程序，点击FORM1，窗口就被关闭
'----------------------------------------------
'获得当前用户名
'在FORM1中加入如下代码:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub FORM_Load()
Dim s As String
Dim cnt As Long
Dim dl As Long
Dim CurUser As String
cnt = 199
s = String$(200, 0)
dl = GetUserName(s, cnt)
If dl <> 0 Then CurUser = Left$(s, cnt) Else CurUser = ""
Debug.Print CurUser
End Sub
'-----------------------------------------------
'获得Windows启动方式
'在FORM1中加入一个CommandButton?一个Label并加入如下代码
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" ByVal nIndex As Long) As Long
Const SM_CLEANBOOT = 67
Private Sub Command1_Click()
Select Case GetSystemMetrics(SM_CLEANBOOT)
Case 1: Label1 = "安全模式."
Case 2: Label1 = "支持网络的安全模式."
Case Else: Label1 = "Windows运行在普通模式."
End Select
End Sub
点击Command1就可以看到Windows是以何种方式启动的?
'-----------------------------------------------
如何交换鼠标按键
在程序中定义如下API函数
Declare Function SwapMouseButton& Lib "user32" (ByVal bSwap As Long)
'要交换鼠标按键，将bSwap参数设置为True。要恢复正常设置，将bSwap设置为False。
'然后调用函数就可以交换和恢复鼠标按键了?
'------------------------------------------------
'怎样关闭Windows
'使用ExitWindowsEx函数，函数有两个参数确定如何关闭Windows，其中第二个参数未使用设置为0
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" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
'If you wanted to forcefully reboot the computer use the following code:
'如果想强制重新启动计算机，函数应该这样使用：
T& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
'-----------------------------------------------
'如何获得Windows95已经运行的时间
'要获得Windows95运行的时间，使用以下函数：
Declare Function GetTickCount& Lib "kernel32" ()
'函数返回的是以毫秒计算的时间?
'在16位Windows下，使用GetCurrentTime 函数。
'----------------------------------------------
'翻转一个字符串
'下面的函数利用递归原理获得字符串的翻转字符串
Function reversestring(revstr As String) As String
' revstr: 要翻转的字符串
' 返回值:翻转后的字符串
Dim doreverse As Long
reversestring = ""
For doreverse = Len(revstr) To 1 Step -1
reversestring = reversestring & Mid$(revstr, doreverse, 1)
Next
End Function
'------------------------------------------------
'获得?设置鼠标双击间隔时间
'获得鼠标双击间隔时间:
Public Declare Function GetDoubleClickTime Lib "user32" Alias GetDoubleClickTime" () As Long
'函数返回以毫秒为单位的鼠标双击间隔时间?
'设置鼠标双击间隔时间
Declare Function SetDoubleClickTime Lib "user32" (ByVal wCount As Long) As Long
'其中的参数wCount为以毫秒为单位的新的时间间隔的长度?
'-----------------------------------------------
'获得系统中鼠标的键数
'获得系统中鼠标支持的键数（两键或三键），首先在程序中做如下定义：
Declare Function GetSystemMetrics Lib "user32" Alias GetSystemMetrics" (ByVal nIndex As Long) As Long
Public Const SM_CMOUSEBUTTONS = 43
'然后在程序中调用GetSystemMetrics函数
Number& = GetSystemMetrics(SM_CMOUSEBUTTONS)
'返回值为系统支持的鼠标键数（返回0，则系统中没有安装鼠标:-) ）
'下面是GetSystemMetrics函数参数nIndex的定义:
SM_ARRANGE Flags specifying how the system arranged minimized windows. For more inFORMation about minimized windows, see the following Remarks section.
SM_CLEANBOOT 返回系统启动方式:
'0 正常启动
'1 安全模式启动
'2 网络安全模式启动
SM_CMOUSEBUTTONS '返回值为系统支持的鼠标键数，返回0，则系统中没有安装鼠标。
SM_CXBORDER
SM_CYBORDER '返回以相素值为单位的Windows窗口边框的宽度和高度，如果Windows的为3D形态，则等同于SM_CXEDGE参数
SM_CXCURSOR
SM_CYCURSOR '返回以相素值为单位的标准光标的宽度和高度
SM_CXDLGFRAME
SM_CYDLGFRAME '等同与SM_CXFIXEDFRAME And SM_CYFIXEDFRAME
SM_CXDOUBLECLK
SM_CYDOUBLECLK '以相素值为单位的双击有效的矩形区域
SM_CXEDGE , SM_CYEDGE '以相素值为单位的3D边框的宽度和高度
SM_CXFIXEDFRAME
SM_CYFIXEDFRAME '围绕具有标题但无法改变尺寸的窗口（通常是一些对话框）的边框的厚度
SM_CXFRAME , SM_CYFRAME '等同于SM_CXSIZEFRAME and SM_CYSIZEFRAME
SM_CXFULLSCREEN
SM_CYFULLSCREEN '全屏幕窗口的窗口区域的宽度和高度
SM_CXHSCROLL
SM_CYHSCROLL '水平滚动条的高度和水平滚动条上箭头的宽度
SM_CXHTHUMB '以相素为单位的水平滚动条上的滑动块宽度
SM_CXICON 'SM_CYICON 系统缺省的图标的高度和宽度（一般为32*32）
SM_CXICONSPACING
SM_CYICONSPACING '以大图标方式查看Item时图标之间的间距，这个距离总是大于等于SM_CXICON and SM_CYICON.
SM_CXMAXIMIZED
SM_CYMAXIMIZED '处于顶层的最大化窗口的缺省尺寸
SM_CXMAXTRACK
SM_CYMAXTRACK '具有可改变尺寸边框和标题栏的窗口的缺省最大尺寸，如果窗口大于这个尺寸，窗口是不可移动的。
SM_CXMENUCHECK
SM_CYMENUCHECK '以相素为单位计算的菜单选中标记位图的尺寸
SM_CXMENUSIZE
SM_CYMENUSIZE '以相素计算的菜单栏按钮的尺寸
SM_CXMIN , SM_CYMIN ' 窗口所能达到的最小尺寸
SM_CXMINIMIZED
SM_CYMINIMIZED ' 正常的最小化窗口的尺寸
SM_CXMINTRACK
SM_CYMINTRACK '最小跟踪距离，当使用者拖动窗口移动距离小于这个值，窗口不会移动。
SM_CXSCREEN
SM_CYSCREEN '以相素为单位计算的屏幕尺寸?
SM_CXSIZE 'SM_CYSIZE 以相素计算的标题栏按钮的尺寸
SM_CXSIZEFRAME
SM_CYSIZEFRAME '围绕可改变大小的窗口的边框的厚度
SM_CXSMICON
SM_CYSMICON '以相素计算的小图标的尺寸，小图标一般出现在窗口标题栏上。
M_CXVSCROLL
SM_CYVSCROLL '以相素计算的垂直滚动条的宽度和垂直滚动条上箭头的高度
SM_CYCAPTION '以相素计算的普通窗口标题的高度
SM_CYMENU '以相素计算的单个菜单条的高度
SM_CYSMCAPTION 以相素计算的窗口小标题栏的高度
SM_CYVTHUMB '以相素计算的垂直滚动条中滚动块的高度
SM_DBCSENABLED '如果为TRUE或不为0的值表明系统安装了双字节版本的USER.Exe, 为FALSE或0则不是?
SM_DEBUG '如果为TRUE或不为0的值表明系统安装了debug版本的USER.Exe, 为FALSE或0则不是?
SM_MENUDROPALIGNMENT '如果为TRUE或不为0的值下拉菜单是右对齐的否则是左对齐的?
SM_MOUSEPRESENT '如果为TRUE或不为0的值则安装了鼠标，否则没有安装。
SM_MOUSEWHEELPRESENT '如果为TRUE或不为0的值则安装了滚轮鼠标，否则没有安装。(Windows NT only)
SM_SWAPBUTTON '如果为TRUE或不为0的值则鼠标左右键交换，否则没有。
'------------------------------------------------------
'把 VB 标准的工具栏变成平面式
'平面式的工具栏好象显得很酷！但 VB5 只提供了普通的凸起的工具栏。你是否想把它变成平面的？这似乎很不容易。但事实并非如此，试试：
'BAS:
Public Const WM_USER = &H400
Public Const TB_SETSTYLE = WM_USER + 56
Public Const TB_GETSTYLE = WM_USER + 57
Public Const TBSTYLE_FLAT = &H800
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'SUB:
Private Sub MakeFlat()
Dim style As Long
Dim hToolbar As Long
Dim r As Long
hToolbar = FindWindowEx(Toolbar1.hwnd, 0&, "ToolbarWindow32", vbNullString)
style = SendMessageLong(hToolbar, TB_GETSTYLE, 0&, 0&)
If style And TBSTYLE_FLAT Then
style = style Xor TBSTYLE_FLAT
Else: style = style Or TBSTYLE_FLAT
End If
r = SendMessageLong(hToolbar, TB_SETSTYLE, 0, style)
Toolbar1.Refresh
End Sub
'注意：需要 4.70 或其以上版本的 comctl32.dll 支持。
'---------------------------------------------
'在 Caption 中显示 & 符号
' 大家知道，& 符号是 Windows 的快捷键表示符号，如果要在 Caption 中显示 & ，方法很简单，连续输入两个 & 符号即可。如在 Caption 中输入 Save && Exit，则显示 Save & Exit。
'---------------------------------------------
'让窗口一直在上面
'很多流行软件都有这样一个选项：Always on Top。它可以让窗口在最上面，别的窗口不能覆盖它。我们在VB 中，可以使用下面的方法来实现：
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_NOCOPYBITS = &H80
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
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 mbOnTop As Boolean
Private Property Let OnTop(Setting As Boolean)
If Setting Then
SetWindowPos hwnd, -1, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, -2, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
mbOnTop = Setting
End Property
Private Property Get OnTop() As Boolean
'Return the private variable set in Property Let
OnTop = mbOnTop
End Property
'调用 OnTop=True 即可让窗口 Always OnTop。
'------------------------------------------------
'播放资源文件文件中的声音
'VB 提供的方法使我们可以很容易地使用资源文件中的字符?图片等资源?
'我们可以用以下方法播放资源文件中的 wav 声音：
'首先，在你的资源文件的源文件 (RC) 文件加入下面一行：
'MySound WAVE c:\music\vanhalen.wav
'然后将其编译为 RES 文件。最后使用下面的声明及代码：
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwflags As Long) As Long
Private Const SND_ASYNC& = &H1
Private Const SND_NODEFAULT& = &H2
Private Const SND_RESOURCE& = &H40004
Dim hInst As Long
Dim sSoundName As String
Dim lFlags As Long
Dim lRet As Long
Private Sub Command1_Click()
hInst = App.hInstance
sSoundName = "MySound"
lFlags = SND_RESOURCE + SND_ASYNC + SND_NODEFAULT
lRet = PlaySound(sSoundName, hInst, lFlags)
End Sub
'-----------------------------------------------
'使用枚举变量
'VB5 引入枚举变量，使用它，我们可以显著地改变应用程序的易读性：
Public Enum TimeOfDay
Morning = 0
Afternoon = 1
Evening = 2
End Enum
Sub Main()
Dim RightNow As TimeOfDay
If Time >= #12:00:00 AM# And Time < #12:00:00 PM# Then
RightNow = Morning
ElseIf Time >= #12:00:00 PM# And Time < #6:00:00 PM# Then
RightNow = Afternoon
ElseIf Time >= #6:00:00 PM# Then
RightNow = Evening
End If
End Sub
'------------------------------------------------
'动态改变屏幕设置
'我们经常看到许多 Win95 的应用程序（尤其是游戏）在运行它的时候改变屏幕的设置，运行完后恢复，在 VB 中，我们可以用以下方法实现：
'- 定义
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 。
-----------------------------------------------
'移动没有标题栏的窗口
'我们一般是用鼠标按住窗口的标题栏，然后移动窗口，当窗口没有标题栏时，我们可以用下面的方法来移动窗口：
'在 BAS 文件中声明：
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
'然后，在 FORM_MouseDown 事件中：
Private Sub FORM_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub
'----------------------------------------------
'快速选择全部项目
'我们在使用 List 控件时，经常需要全部选择其中的项目，在项目较少时，我们可以逐项设置 Selected 来选择全部的项目，但当项目较多时，这样做就比较费时，其实，我们可以用 API 函数来简单实现此功能：
Dim nRet As Long
Dim bState As Boolean
bState = True
nRet = SendMessage(lstList.hwnd, LB_SETSEL, bState, -1)
'函数声明:
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Integer, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const WM_USER = &H400
Public Const LB_SETSEL = (WM_USER + 6)
'----------------------------------------------
'真正删除数据库的记录
' 大家知道，缺省情况下，VB 删除记录只是把记录作上个删除标志而已，并没有真正删除。要真正删除记录，你可以使用 VB 提供的以下方法：BeginTrans、CommitTrans、RollBack。其中，BeginTrans 方法开始记录数据库的变动，CommitTrans 方法确认数据库的变动，而RollBack方法则可以恢复被删除或修改的记录。它们可以嵌套使用。因此，要恢复被删除的记录，应该在使用 BeginTrans 方法之后及使用CommiTrans方法之前使用 RollBack 方法。
'----------------------------------------------
'捕捉 MoueExit 事件
'MouseDown、MouseUp、MouseMove。VB 似乎提供了很好的 Mouse 事件。但好象还缺少什么！对！还差 MouseExit（鼠标移出）事件。在 VB 中，我们要捕捉 MouseExit 事件，必须用 API 函数：
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
'然后，我们可以在控件（以 Picture1 为例）的 MouseMove 事件上加上以下代码：
Dim MouseExit As Boolean
MouseOver = (0 <= x) And (x <= Picture1.Width) And (0 <= y) And (y <= Picture1.Height)
If MouseExit Then
'........
SetCapture Picture1.hwnd
Else
'........
ReleaseCapture
End If
'--------------------------------------------------
'变量的地址VarPtr
'VB5 内置了一个 VarPtr 函数，可是此函数在 VB4 中没有提供。可是你知道吗？VB4 的运行库中已经包含了此函数。只是在用它之前，我们需要声明一下：
#If Win16 Then
Declare Function VarPtr Lib "VB40016.DLL" (variable As Any) As Long
#Else
Declare Function VarPtr Lib "VB40032.DLL" (variable As Any) As Long
#End If
'此函数在传递一个 Type 结构（如果此结构要求其一段是另一个变量或记录的地址）给一个外部的 API 程序时十分有用。
'-------------------------------------------------
'编译时不要自动使用 快速代码优化
' 如果你第一次使用 VB 的本地代码优化选项，你可能会立即尝试选择“优化代码选项”。可是，你知道吗？这样做并不一定保证使你的程序得到最佳性能。除非你拥有大量内存，不然程序的性能优化一般不会运行很快。因为这将导致程序装载速度缓慢，在内存不足的机器上特别明显，这样“优化代码选项”就可能让你的用户觉得好象比“优化大小选项”还慢。
'基于以上原因，你可以考虑用 P 代码编译你的程序，特别是大型的、UI 和数据库加强的程序。本地“优化代码选项”所获得的性能并不一定可以弥补程序增长大小后带来的问题。
'要决定你到底适合那种编译方式，请使用 VB 企业版上的 Application PerFORMance Explorer (APE) 。
'-----------------------------------------------
'避免装载多份应用程序
'你的程序可能只支持单一用户，那么怎么来避免多用户同时使用它吗？
'你可以利用 App 对象的 PrevInstance 属性来轻易达到你的目的。
'我们可以在程序打开时加入以下代码来验证:
If App.PrevInstance Then
MsgBox ("程序已经运行，不能再次装载。"), vbExclamation
Unload Me
End If
'------------------------------------------------
'启动时禁止装入 Add - Ins
'启动VB时，Add-Ins 将加载。如果Add-Ins中有错误的话，每次都可能产生错误。为了启动时禁止装入 Add-Ins，在启动VB前，编辑 Windows 目录中的 VBAddin.INI 文件。找到以下的语句：
AppWizard.Wizard = 1
'将 1 改为 0 。
'-------------------------------------------------
'快速查找属性
'在属性窗口中，在打入字符时，按住 Ctrl+Shift。属性窗口将自动翻滚到以该字符开头的地方。
'-------------------------------------------------
'在字符串中使用双引号
'使用 Chr$(34) 连接是个办法，用 "" 更简单。如： MyName = "我的名字是 ""Blackcat""。"
'-------------------------------------------------
'混合字符串的长度
'在中文环境下，每个字被当做两个 Byte ：
Len("汉1") = 2
LenB("汉1") = 4
'但在许多情况下，我们希望中文字长度为 2，英文字符为 1。可用以下的函数：
LenB(StrConv("汉1"), vbFORMUnicode))
'---------------------------------------------------
'取得应用所在的目录
'使用 App.Path 可以得到应用所在的目录。不过得注意，当在根目录下时，Path 的返回值最右字符为 “\” ，如“c:\”，而如果不在根目录，则最右字符非 “\”，如“c:\vb5”。所以在使用 Path 做连接时，应使用以下的代码：
Dim FileName As String
Dim fullpath As String
If Right(App.path, 1) = "\" Then
fullpath = App.path + FileName
Else
fullpath = App.path + "\" + FileName
End If
'或者:
pth$ = App.path & IIf(Len(App.path) > 3, "\", "")
'-----------------------------------------------------
'快速交换整数
'可用以下的代码快速交换两个整数 (Interger):
a = a Xor b
b = a Xor b
'-----------------------------------------------------
'使用 IIF 和 SWITCH 以精减代码
'在很多地方你都可以使用一个更紧凑的 IIf函数来代替 If...Else...Endif 的结构：
'例: 返回两个值中较大的一个maxvalue = IIf(First >= Second, First, Second)
'Switch 则是一个很少使用的函数，可是在很多方面它都提供比 If...ElesIf 结构更好的效率
'例：判断 "x" 是正、负还是 null　Print Switch(x<0,"负",x>0,"正", True, "Null")
'---------------------------------------------------
'取得 DOS 环境变量
'使用 Environ 函数：
Dim x As Integer
Dim Env As String
x = 1
Env = Environ(x)
Do Until Env = ""
Env = Environ(x)
Debug.Print Env
x = x + 1
Loop
'------------------------------------------------
修改屏幕保护的口令
声明:
Private Declare Function PwdChangePassword Lib "mpr" Alias "PwdChangePasswordA" (ByVal lpcRegkeyname As String, ByVal hwnd As Long, ByVal uiReserved1 As Long, ByVal uiReserved2 As Long) As Long
使用:
' 出现修改屏幕保护口令的窗口
Call PwdChangePassword("SCRSAVE", Me.hwnd, 0, 0)
'-------------------------------------------------
'使用 API 开始屏幕保护
声明:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_SYSCOMMAND = &H112&
Const SC_SCREENSAVE = &HF140&
代码:
Dim result As Long
result = SendMessage(FORM1.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
'-------------------------------------------------
取得和设置系统颜色
声明:
Public Const COLOR_SCROLLBAR = 0 '滚动条
Public Const COLOR_BACKGROUND = 1 '桌面背景
Public Const COLOR_ACTIVECAPTION = 2 '活动窗口标题
Public Const COLOR_INACTIVECAPTION = 3 '非活动窗口标题
Public Const COLOR_MENU = 4 '菜单
Public Const COLOR_WINDOW = 5 '窗口背景
Public Const COLOR_WINDOWFRAME = 6 '窗口框
Public Const COLOR_MENUTEXT = 7 '窗口文字
Public Const COLOR_WINDOWTEXT = 8 '3D 阴影 (Win95)
Public Const COLOR_CAPTIONTEXT = 9 '标题文字
Public Const COLOR_ACTIVEBORDER = 10 '活动窗口边框
Public Const COLOR_INACTIVEBORDER = 11 '非活动窗口边框
Public Const COLOR_APPWORKSPACE = 12 'MDI 窗口背景
Public Const COLOR_HIGHLIGHT = 13 '选择条背景
Public Const COLOR_HIGHLIGHTTEXT = 14 '选择条文字
Public Const COLOR_BTNFACE = 15 '按钮
Public Const COLOR_BTNSHADOW = 16 '3D 按钮阴影
Public Const COLOR_GRAYTEXT = 17 '灰度文字
Public Const COLOR_BTNTEXT = 18 '按钮文字
Public Const COLOR_INACTIVECAPTIONTEXT = 19 '非活动窗口文字
Public Const COLOR_BTNHIGHLIGHT = 20 '3D 选择按钮
Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorvalues As Long) As Long
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
'使用:
i = GetSysColors(COLOR_ACTIVECAPTION)
'i 是 RGB 值
i = SetSysColors(1, COLOR_ACTIVECAPTION, #ff0000)
'把标题设置为红色
'-------------------------------------------------
'改变墙纸
'声明:
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
'用法:
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, BMP名称, SPIF_UPDATEINIFILE)
'例子:
' 1. 把桌面图片设为 c:\windows\setup.bmp
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "c:\windows\setup.bmp", SPIF_UPDATEINIFILE)
' 2. 将桌面图片清除
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "", SPIF_UPDATEINIFILE)
'------------------------------------------------
'动态改变屏幕设置
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 。参见：X059 改变屏幕到16位彩色的演示
'--------------------------------------------------
桌面的大小
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const SPI_GETWORKAREA = 48
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Sub Command1_Click()
Dim lRet As Long
Dim apiRECT As RECT
lRet = SystemParametersInfo(SPI_GETWORKAREA, vbNull, apiRECT, 0)
If lRet Then
Print "Left: " & apiRECT.Left
Print "Top: " & apiRECT.Top
Print "Width: " & apiRECT.Right - apiRECT.Left
Print "Height: " & apiRECT.Bottom - apiRECT.Top
Else
Print "调用 SystemParametersInfo 失败"
End If
End Sub
其他方法:
Sub Command1_Click()
CR$ = Chr$(13) + Chr$(10)
TWidth% = Screen.Width \ Screen.TwipsPerPixelX
THeight% = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "屏幕大小为" + CR$ + CR$ + Str$(TWidth%) + " x" + Str$(THeight%), 64, "Info"
End Sub
'---------------------------------------------------
'禁止使用 Alt+F4 关闭窗口
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private Sub FORM_Load()
Dim hwndMenu As Long
Dim c As Long
hwndMenu = GetSystemMenu(Me.hwnd, 0)
c = GetMenuItemCount(hwndMenu)
DeleteMenu hwndMenu, c - 1, MF_BYPOSITION
c = GetMenuItemCount(hwndMenu)
DeleteMenu hwndMenu, c - 1, MF_BYPOSITION
End Sub
'------------------------------------------------------
'自动出现动画?进度和确认的文件操作
'使用以下的 API ，得到与资源管理器相同的感觉！
Private 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 String '只有在 FOF_SIMPLEPROGRESS 时用
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
'wFunc 常数
'FO_COPY 把 pFrom 文件拷贝到 pTo。
Const FO_COPY = &H2
'FO_DELETE 删除 pFrom 中的文件（pTo 忽略）
Const FO_DELETE = &H3
'FO_MOVE 把 pFrom 文件移动到 pTo。
Const FO_MOVE = &H1
'fFlag 常数
'FOF_ALLOWUNDO 允许 Undo。
Const FOF_ALLOWUNDO = &H40
'FOF_NOCONFIRMATION 不显示系统确认对话框。
Const FOF_NOCONFIRMATION = &H10
'FOF_NOCONFIRMMKDIR 不提示是否新建目录。
Const FOF_NOCONFIRMMKDIR = &H200
'FOF_SILENT 不显示进度对话框
Const FOF_SILENT = &H4
例子:
Dim SHFileOp As SHFILEOPSTRUCT
' 删除
SHFileOp.wFunc = FO_DELETE
SHFileOp.pFrom = "c:\config.old" + Chr(0)
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
Call SHFileOperation(SHFileOp)
' 删除多个文件
SHFileOp.wFunc = FO_DELETE
SHFileOp.pFrom = "c:\config.old" + Chr(0) + "c:\autoexec.old" + Chr(0)
SHFileOp.fFlags = FOF_ALLOWUNDO
Call SHFileOperation(SHFileOp)
' 拷贝
SHFileOp.wFunc = FO_COPY
SHFileOp.pFrom = "c:\t\*.*"
SHFileOp.pTo = "d:\t\*.*"
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR
Call SHFileOperation(SHFileOp)
' 移动
SHFileOp.wFunc = FO_MOVE
SHFileOp.pFrom = "c:\config.old" + Chr(0)
SHFileOp.pTo = "d:\t"
SHFileOp.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
'-----------------------------------------------------
快速建立目录
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
'函数:
'Call CreateNewDirectory("c:\test\directory\vb\tips\")
Public Sub CreateNewDirectory(NewDirectory As String)
Dim sDirTest As String
Dim SecAttrib As SECURITY_ATTRIBUTES
Dim bSuccess As Boolean
Dim sPath As String
Dim iCounter As Integer
Dim sTempDir As String
iFlag = 0
sPath = NewDirectory
If Right(sPath, Len(sPath)) <> "\" Then
sPath = sPath & "\"
End If
iCounter = 1
Do Until InStr(iCounter, sPath, "\") = 0
iCounter = InStr(iCounter, sPath, "\")
sTempDir = Left(sPath, iCounter)
sDirTest = Dir(sTempDir)
iCounter = iCounter + 1
'create directory
SecAttrib.lpSecurityDescriptor = &O0
SecAttrib.bInheritHandle = False
SecAttrib.nLength = Len(SecAttrib)
bSuccess = CreateDirectory(sTempDir, SecAttrib)
Loop
End Sub
'---------------------------------------------------
'开启文件属性窗口
'声明:
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long
'代码:
' 使用： ShowProps("c:\command.com",Me.hWnd)
Public Sub ShowProps(FileName As String, OwnerhWnd As Long)
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = FileName
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
r = ShellExecuteEX(SEI)
End Sub
'--------------------------------------------------
'使用 WIN95 的选择目录对话框
'声明:
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
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
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
'函数:
Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
BrowseForFolder = sPath
End Function
'------------------------------------------------
移动文件到回收站
声明:
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
代码:
Dim SHop As SHFILEOPSTRUCT
Dim strFile As String
With SHop
.wFunc = FO_DELETE
.pFrom = strFile + Chr(0)
.fFlags = FOF_ALLOWUNDO
End With
'--------------------------------------------------
'比较两个文件
Function CompFile(F1 As String, F2 As String) As Boolean
Dim issame As Boolean
Open F1 For Binary As #1
Open F2 For Binary As #2
issame = True
If LOF(1) <> LOF(2) Then
issame = False
Else
whole& = LOF(1) \ 10000 'number of whole 10,000 byte chunks
part& = LOF(1) Mod 10000 'remaining bytes at end of file
buffer1$ = String$(10000, 0)
buffer2$ = String$(10000, 0)
start& = 1
For x& = 1 To whole& 'this for-next loop will get 10,000
Get #1, start&, buffer1$ 'byte chunks at a time.
Get #2, start&, buffer2$
If buffer1$ <> buffer2$ Then
issame = False
Exit For
End If
start& = start& + 10000
Next
buffer1$ = String$(part&, 0)
buffer2$ = String$(part&, 0)
Get #1, start&, buffer1$ 'get the remaining bytes at the end
Get #2, start&, buffer2$ 'get the remaining bytes at the end
If buffer1$ <> buffer2$ Then
issame = False
End If
Close
CompFile = issame
End Function
'--------------------------------------------------
'取得临时文件名
'声明:
Public Const MAX_PATH = 260
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'代码:
Public Function GetTempFile() As String
Dim lngRet As Long
Dim strBuffer As String, strTempPath As String
'初始化 buffer
strBuffer = String$(MAX_PATH, 0)
'取得临时路径
lngRet = GetTempPath(Len(strBuffer), strBuffer)
'0 错误
If lngRet = 0 Then Exit Function
'去掉尾中的 null
strTempPath = Left$(strBuffer, lngRet)
'初始化 buffer
strBuffer = String$(MAX_PATH, 0)
'取得临时文件名
lngRet = GetTempFileName(strTempPath, "tmp", 0&, strBuffer)
If lngRet = 0 Then Exit Function
lngRet = InStr(1, strBuffer, Chr(0))
If lngRet > 0 Then
GetTempFile = Left$(strBuffer, lngRet - 1)
Else
GetTempFile = strBuffer
End If
End Function
'--------------------------------------------------
'确定是 WINDOWS 的可执行文件
'在文件的第 24 字节，如果为40h，就是 Windows 的可执行文件。
Function WinExe(ByVal Exe As String) As Integer
Dim fh As Integer
Dim T As String * 1
fh = FreeFile
Open Exe For Binary As #fh
Get fh, 25, T
Close #fh
WinExe = (Asc(T) = &H40&)
End Function
'---------------------------------------------------
'建立多级目录
Sub CreateLongDir(sDrive As String, sDir As String)
Dim sBuild As String
While InStr(2, sDir, "\") > 1
sBuild = sBuild & Left(sDir, InStr(2, sDir, "\") - 1)
sDir = Mid(sDir, InStr(2, sDir, "\"))
If Dir(sDrive & sBuild, 16) = "" Then
MkDir sDrive & sBuild
End If
Wend
End Sub
'----------------------------------------------------
'取得文件的扩展名
Function GetExtension(FileName As String)
Dim PthPos, ExtPos As Integer
For i = Len(FileName) To 1 Step -1 ' Go from the Length of the filename, to the first character by 1.
If Mid(FileName, i, 1) = "." Then ' If the current position is '.' then...
ExtPos = i ' ...Change the ExtPos to the number.
For j = Len(FileName) To 1 Step -1 ' Do the Same...
If Mid(FileName, j, 1) = "\" Then ' ...but for '\'.
PthPos = j ' Change the PthPos to the number.
Exit For ' Since we found it, don't search any more.
End If
Next j
Exit For ' Since we found it, don't search any more.
End If
Next i
If PthPos > ExtPos Then
Exit Function ' No extension.
Else
If ExtPos = 0 Then Exit Function ' If there is not extension, then exit sub.
GetExtension = Mid(FileName, ExtPos + 1, Len(FileName) - ExtPos) 'Messagebox the Extension
End If
End Function
'使用:
FileExt = GetExtension("c:\windows\vb\vb.exe")
'-----------------------------------------------------
'从全路径名中提取文件名
Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
例子:
File = StripPath("c:\windows\hello.txt")
'-------------------------------------------------------
把文件置入到Text或RichText中
Dim sFile As String
'Set sFile equal to your filename
Dim i As Long
i = FreeFile()
Open sFile For Input As #i
txtMain.Text = Input$(i, LOF(i))
Close #1
'-------------------------------------------------------
'目录所占的字节数
'该函数返回目录使用的字节数:
Function DirUsedBytes(ByVal dirName As String) As Long
Dim FileName As String
Dim FileSize As Currency
If Right$(dirName, 1) <> "\" Then
dirName = dirName & "\"
End If
FileSize = 0
FileName = Dir$(dirName & "*.*")
Do While FileName <> ""
FileSize = FileSize + _
FileLen(dirName & FileName)
FileName = Dir$
Loop
DirUsedBytes = FileSize
'使用:
'MsgBox DirUsedBytes("C:\Windows")
'------------------------------------------------------
'打开 Win95 的创建快捷方式窗口
'以下的代码演示了如何利用 Win95 的 Wizard 在指定的目录中建立快捷方式。
Dim x As Integer
x = Shell("C:\WINDOWS\rundll32.exe AppWiz.Cpl,NewLinkHere " & App.path & "\", 1)
'-------------------------------------------------------
显示盘中所有的目录
'以下的代码把盘中所有的目录都显示在DriveListBox和一个Listbox中。需要一个 如果DirListBox隐藏的话，处理可以快一些。
Dim iLevel As Integer, iMaxSize As Integer
Dim i As Integer, j As Integer
ReDim iDirCount(22) As Integer
'最大 22 级目录
ReDim sdirs(22, 1) As String
'drive1 是 DriveListBox 控件
'dir1 是 DirListBox 控件
iLevel = 1
iDirCount(iLevel) = 1
iMaxSize = 1
sdirs(iLevel, iDirCount(iLevel)) = Left$(drive1.Drive, 2) & "\"
Do
iLevel = iLevel + 1
iDirCount(iLevel) = 0
For j = 1 To iDirCount(iLevel - 1)
dir1.path = sdirs(iLevel - 1, j)
dir1.Refresh
If iMaxSize < (iDirCount(iLevel) + dir1.ListCount) Then
ReDim Preserve sdirs(22, iMaxSize + dir1.ListCount + 1) As String
iMaxSize = dir1.ListCount + iDirCount(iLevel) + 1
End If
For i = 0 To dir1.ListCount - 1
iDirCount(iLevel) = _
iDirCount(iLevel) + 1 '子目录记数
sdirs(iLevel, iDirCount(iLevel)) = dir1.List(i)
Next i
Next j
'所有名称放到 List1 中
list1.Clear
If iDirCount(iLevel) = 0 Then
'如果无自目录
For i = 1 To iLevel
For j = 1 To iDirCount(i)
list1.AddItem sdirs(i, j)
Next j
Next i
Exit Do
End If
Loop
'------------------------------------------------------
'取得长文件名
Public Function GetLongFilename(ByVal sShortName As String) As String
Dim sLongName As String
Dim sTemp As String
Dim iSlashPos As Integer
'Add \ to short name to prevent Instr from failing
sShortName = sShortName & "\"
'Start from 4 to ignore the "[Drive Letter]:\" characters
iSlashPos = InStr(4, sShortName, "\")
'Pull out each string between \ character for conversion
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
'Prefix with the drive letter
GetLongFilename = Left$(sShortName, 2) & sLongName
End Function
'-------------------------------------------------------
'记载Windows使用的时间
' 有时候你需要记下每次Windows开启和关闭的时间，下面这个小程序就可以完成这个功能，你可以把它放在Windows开始菜单的“启动”文件夹里面，这样当你进入Windows时，这个小程序就会自动启动（不可见），并在你指定的文件中写下当时的时间，在你推出Windows系统时，小程序会关闭并记下离开的时间，并关闭记录文件。
Private Sub FORM_Load()
Left = -10000
Top = -10000
Open "c:\apps\log.txt" For Append As #1
Print #1, "On: " & CStr(Now)
Close #1
End Sub
Private Sub FORM_Unload(Cancel As Integer)
Open "c:\apps\log.txt" For Append As #1
Print #1, "Off:" & CStr(Now)
Close #1
End
End Sub
----------------------------------------------
'怎样关闭一个正在运行的程序
'你可以使用API函数FindWindow和PostMessage去寻找指定的窗口，并关闭它。下面的例子教给你怎样找到并关掉一个Caption为“Caluclator”的程序。
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "Calculator")
Debug.Print winHwnd
If winHwnd <> 0 Then
RetVal = PostMessage(winHwnd, WM_CLOSE, 0&, 0&)
If RetVal = 0 Then
MsgBox "置入消息错误！"
End If
Else
MsgBox "Calculator没有打开！"
End If
'为了让以上的代码工作，你必须在模块文件中什么以下API函数：
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_CLOSE = &H10
'----------------------------------------------------
'我怎样确定我的程序是否在运行？
'把以下代码放在第一个窗体的FORM_Load事件中:
If App.PrevInstance = True Then
Call MsgBox("这个程序正在运行！", vbExclamation)
End
End If
'-----------------------------------------------------
'怎样延迟一个VB程序？
'延迟在VB中非常有意义！举个例子，有时你需要等待一个额外的过程完成，才能运行程序下面的代码。延迟使程序摆脱了CPU的运算速度对程序运行速度的影响，但是在VB中却没有延迟这个很多语言都有的现成函数，所以还要依靠API函数，请看以下的代码：
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'延迟1秒
Call Sleep(1000)
'--------------------------------------
'怎样改变双击鼠标的时间间隔？
'在较短时间里连续的点击两次鼠标就会造成鼠标双击事件。你可以调用API函数SetDoubleClickTime改变鼠标双击所需要的时间，它只有一个参数，并可精确到毫秒级。
Declare Function SetDoubleClickTime Lib "user32" (ByVal wCount As Long) As Long
'提示: 这种改变将影响到整个操作系统?
'-------------------------------------------------------
'怎样找到鼠标指针的XY坐标？
'在很多的作图软件中都有一个小的区域显示当前屏幕上的光标位置，这利用API函数非常容易做到，下面的例子将演示使用代码如何返回当前光标的XY的坐标值。
'在VB5中建立一个新项目文件，FORM1使用默认设置. 选择菜单的“Project/add Module”，建立一个新的模块文件“Moudule1”。
'输入以下代码声明API函数?
Option Explicit
Type POINTAPI ' Declare types
x As Long
y As Long
End Type
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long ' Declare API
'把焦点移到FORM1，添加两个标签对象（Label）和一个计时器对象（Timer1），把计时器的Interval属性设为1，然后双击FORM1的任何区域，在代码窗口中输入：
Option Explicit
Dim z As POINTAPI ' 声明变量
Private Sub Timer1_Timer()
GetCursorPos z ' 得到坐标
Label1 = "x: " & z.x ' 得到X坐标
Label2 = "y: " & z.y ' 得到Y坐标
End Sub
'按F5运行程序，移动鼠标注意观察两个标签对象的变化。
'------------------------------------------------------
'怎样捕捉窗体的鼠标？
'这个技巧将向您展示如何使用捕捉光标的API函数阻止鼠标指针移出窗体?
'注意！：如果窗体的BorderStyle属性被设为sizeable（2或5），则当你改变窗体的大小时鼠标就会“逃脱”程序的监控！因此你最好把BorderStyle设为0、1、3或4。
'把以下代码添加如模块:
Option Explicit
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Public Sub DisableTrap(CurFORM As Form)
Dim erg As Long
'声明过程变量
'设置新坐标
Dim NewRect As RECT
CurFORM.Caption = "释放鼠标"
With NewRect
.Left = 0&
.Top = 0&
.Right = Screen.Width / Screen.TwipsPerPixelX
.Bottom = Screen.Height / Screen.TwipsPerPixelY
End With
erg& = ClipCursor(NewRect)
End Sub
Public Sub EnableTrap(CurFORM As Form)
Dim x As Long, y As Long, erg As Long
'声明过程变量
'设置新坐标
Dim NewRect As RECT
'得到TwipsperPixel
'窗体的ScaleMode必须设为Twips！！！
x& = Screen.TwipsPerPixelX
y& = Screen.TwipsPerPixelY
CurFORM.Caption = "捕捉鼠标"
'设置光标的范围
With NewRect
.Left = CurFORM.Left / x&
.Top = CurFORM.Top / y&
.Right = .Left + CurFORM.Width / x&
.Bottom = .Top + CurFORM.Height / y&
End With
erg& = ClipCursor(NewRect)
End Sub
'2、在窗体上添加两个命令按钮（Command Button）。
'3 ?把以下代码添加如FORM1?
Private Sub Command1_Click()
EnableTrap FORM1
End Sub
Private Sub Command2_Click()
DisableTrap FORM1
End Sub
Private Sub FORM_Unload(Cancel As Integer)
'程序结束时释放鼠标。
DisableTrap FORM1
End Sub
'--------------------------------------------------------
'怎样得到文本框（TextBox）中的文本行数？
'计算文本框中输入文本的行数可以使用SendMessage函数返回，当一行文字发生环绕时，它将被当作新的一行，而被非简单的计算文本中的换行符个数。
'把以下API函数的声明添入模块文件的general declarations区域，如果您使用的是VB4-32或VB5，也可以把此声明添入FORM1的general declarations中，并把所有的“Public”更换为“Private”。
Option Explicit
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const EM_GETLINECOUNT = &HBA
Form Code
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
'注释：为了使本程序成功，请在设计阶段把文本框的Multiline属性设为True。
'----------------------------------------------------------
'怎样使程序的标题条闪烁？
'建立新的项目文件，添加模块文件，并填写如下代码：
Public Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
'在窗体中添加两个按钮和一个计时器，并用设置以下属性：
command1.Caption = "开始"
command2.Caption = "停止"
Timer1.INTERVAL = 500 '每0.5秒闪烁一次
Timer1.Enabled = False
Private Sub Timer1_Timer()
a& = FlashWindow(Me.hwnd, 1)
End Sub
Private Sub Command1_Click()
Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
Timer1.Enabled = False
End Sub
'--------------------------------------------------------------------------------
'怎样加速数据库的访问速度？
records.movelast
intRecCount = records.RecordCount
records.movefirst
For intCounter = 1 To intRecCount
combo1.AddItem records![Full Name]
records.movenext
Next intCounter
'------------------------------------------------
'怎么对付数据库中的空字符？
'缺省时的数据库字段为空字符（并不是指一个字符串值为“空格”，而是什么也没有），当你读取这些字段的时候把它们赋值给VB的String变量，你就会得到“变量类型不匹配”的错误。最好的解决方法应当是嵌入一串空格和字段连接起来，请看下面的代码：
Dim DB As Database
Dim RS As Recordset
Dim sYear As String
Set DB = OpenDatabase("Biblio.mdb")
Set RS = DB.OpenRecordset("Authors")
sYear = "" & RS![Year Born]
'------------------------------------------------
'怎样打开或关闭CD-ROM？
'如果你想通过VB打开或者关闭CD-ROM，你可以向Windows Multimedia DLL发出一条相关的命令请求，但是你必须先声明DLL：
在模块文件中加入以下代码:
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
以下是打开CD -ROM的过程代码:
retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
关闭CD -ROM用以下代码:
'retvalue = mcisendstring("set CDAudio door closed", _returnstring, 127, 0)
'------------------------------------------------
'怎样使用VB程序退出Windows？
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" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
退出Windows:
T& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
'------------------------------------------------
'怎样用VB断开与internet的连接？
'如果你想终止与internet的连接，可以使用断开连接的方法，首先你必须声明以下函数和变量：
Declarations
Public Const RAS_MAXENTRYNAME As Integer = 256Public Const RAS_MAXDEVICETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412Public 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
'--------------------------------------------------------
'怎样用VB得知系统当前是否处于internet链结状态？
'对于那些必须和internet链结才能工作的程序来说，知道当前计算机是否处于链结状态是非常有意义的。当Windows系统处于链结状态时，它会在注册表里改动一个键值，下面的例子告诉你如何读取这个键值，并得知系统是否与internet相连。
'声明以下函数变量常量:
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
'-------------------------------------------------------------
'放置“透明”的图片
'在 VB 中，如果你试着把一只有鸟的图片放到背景的一棵树上，你就会发现树会被鸟遮住一个矩形的区域（即鸟的图片矩形）。我们可以通过以下方法使图片上非鸟的其它部分变透明：
'我们可以利用一个 WinAPI 函数 BitBlt 对图形进行一系列的位操作来达到此目的。
'函数声明:
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
'参数解释:
'目标环境：hDestDC__目标设备环境；x__左上角；y__顶端；nWidth__宽；nHeight__高
'源环境：hSrcDC__源设备环境；xSrc__源左上角；ySrc__源顶端；
'dwRop__位处理操作，如 vbSrcAnd；vbSrcAnd；vbSrcCopy；vbSrcErase；vbSrcInvert 等
'（目标环境或源环境只能是 Picture, FORM 或 Printer 对象。各单位为象素。）
'进行处理之前，我们需要对鸟的图片进行处理：先复制一份相同的图形，将其应该透明之处（鸟的背景）设置为黑色（设此图为sPic），再将另一图做以下处理：要复制的地方（鸟）设置为黑色，其余地方设置（鸟的背景）为白色（设此图为Mask）。
'设树的图形为名dPic?
'最后，请加入以下代码：
r = BitBlt(dPic.hdc, 0, 0, sPic.Width, sPic.Height, Mask.hdc, 0, 0, vbScrCopy)
r = BitBlt(dPic.hdc, 0, 0, sPic.Width, sPic.Height, sPic.hdc, 0, 0, vbScrInvert)
'后记:
'1、VB 中的 PaintPicture 方法提供类似功能，但速度不及此方法；
'2、在此方法上稍微加入一些代码，就不难实现动画的显示。
'3、VB 例子中的 CallDlls 就使用此方法。
'-----------------------------------------------------------------
'设置打印页边距
'你可以使用打印机的Scale属性来设置打印页边距。下面的代码设置左边距为1/2英寸。右边距为3/4英寸。乘以1440是将英尺转换成twips。
Printer.ScaleLeft = -0.75 * 1440
Printer.ScaleTop = -0.5 * 1440
Printer.CurrentX = 0
Printer.CurrentY = 0 '本