发信人: msnet()
整理人: (1999-06-22 21:27:08), 站内信件
|
编者的话
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
大家好！
VB邮件在各位网友的热情支持与关心下正在茁壮成长，
为了使这一邮件列表办得更好，我们期侍各位热情投稿，
稿件可以涉及与VB、ASP有关的内容。
如果你有好的作品或你发现了好的作品，不要忘了让
大家共享。
版主 冯德平
[email protected]
=================================================
vb邮件（5.17）
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VB经验技巧（二）
怎样得到当前的屏幕分辨率？
如何改变屏幕的分辨率？
如何用VB抓图？
怎样得到磁盘空间未占用的字节数？
怎样得到Windows系统的目录？ 怎样得到磁盘序号？
怎样加速数据库的访问速度？
怎么对付数据库中的空字符？
怎样打开或关闭CD-ROM？
怎样确定系统是否安装了声卡？
怎样使用API播放MIDI音乐？
怎样播放AVI文件？
怎样用VB建立internet连接？
怎样用VB断开与internet的连接？ 怎样用VB得知系统当前是否处于internet链
结状态？
怎样使Ctrl-Alt-Delete和Ctrl-Esc无效？
怎样使用VB程序退出Windows？
怎样得到当前的屏幕分辨率？
在程序设计中我们经常要改变窗体的大小，而这也依赖于屏幕的分辨率，下面的
例子将演示如何得到当前屏幕的分辨率：
ResWidth = Screen.Width \ Screen.TwipsPerPixelX
ResHeight = Screen.Height \ Screen.TwipsPerPixelY
ScreenRes = ResWidth & "x" & ResHeight
ResWidth和ResHeight分别表示屏幕的宽和高，比如这样的结果：
800x600
----------------------------------------------------------------------
----------
如何改变屏幕的分辨率？
对于很多VB程序员来说怎样改变屏幕的分辨率一直是一个难题，而且在API-View
er里竟然没有EnumDisplaySettings和ChangeDisplaySettings！！遵从以下的步
骤，你就可以改变屏幕的分辨率。将以下代码加入模块文件：
Declare Function EnumDisplaySettings Lib "user32" _
Alias "EnumDisplaySettingsA" _
(ByVal lpszDeviceName As Long, _
ByVal iModeNum As Long, _
lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" _
Alias "ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
2、下面的例子将演示如何把屏幕分辨率更改为640x480（保持原来的颜色数）。
Dim DevM As DEVMODE
'DevM收集信息
erg& = EnumDisplaySettings(0&, 0&, DevM)
'不改变颜色数目是因为如果改变颜色数就要重新启动
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL
DevM.dmPelsWidth = 640 '屏幕宽度
DevM.dmPelsHeight = 480 '屏幕高度
'DevM.dmBitsPerPel = 32 (还可以为 8, 16, 32甚至4)
'改变显示模式并检查是否可能
erg& = ChangeDisplaySettings(DevM, CDS_TEST)'检查是否成功 Select Case
erg&
Case DISP_CHANGE_RESTART
an = MsgBox("你现在必须重新启动系统，执行吗？", vbYesNo + vbSystemModa
l, "消息")
If an = vbYes Then erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
MsgBox "一切正常！", vbOKOnly + vbSystemModal, "成功"
Case Else
MsgBox "显示模式不支持", vbOKOnly + vbSystemModal, "错误"End Select
End Sub
----------------------------------------------------------------------
----------
如何用VB抓图？
下面的例子将演示怎样把桌面图片用BitBlt函数复制到窗体中，你可以利用它制
作抓图程序，或是制作屏保程序。
把以下代码加入模块：
Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Integer, ByVal x As Integer, _
ByVal y As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Integer, ByVal _
hSrcDC As Integer, ByVal xSrc As Integer, _
ByVal ySrc As Integer, ByVal dwRop As _
Long) As Integer
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046
窗体代码：
设置窗体属性如下：
AutoRedraw True
BorderStyle 0 - None
WindowState 2 - Maximized
现在，把下面的代码加入到窗体中。
Private Sub Form_Load()
Dim DeskhWnd As Long, DeskDC As Long
'得到桌面的hWnd
DeskhWnd& = GetDesktopWindow()
DeskDC& = GetDC(DeskhWnd&)
BitBlt Form1.hDC, 0&, 0&, _Screen.Width, Screen.Height, DeskDC&, _
0&, 0&, SRCCOPY
End Sub
向窗体添加一个命令按钮，并加入以下代码：
Private Sub Command1_Click()
Unload Me
End
End Sub
----------------------------------------------------------------------
----------
怎样得到磁盘空间未占用的字节数？
要得到磁盘空间未占用的字节数可以使用GetDiskFreeSpace 函数：
Declare Function GetDiskFreeSpace Lib "kernel32" Alias _
"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters _
As Long) As Long
下面是找出磁盘所剩空间的例子：
Dim SectorsPerCluster&
Dim BytesPerSector&
Dim NumberOfFreeClusters&
Dim TotalNumberOfClusters&
Dim FreeBytes&
dummy& = GetDiskFreeSpace("c:\", SectorsPerCluster, _
BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOfFreeClusters * SectorsPerCluster * _
BytesPerSector
----------------------------------------------------------------------
----------
怎样得到Windows系统的目录？
如果你的程序用到ini文件，那么储存它们最好的地方就是Windows目录，下面的
例子向你展示如何得到Windows目录。
声明以下函数：
Public Const MAX_PATH = 260
Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal _
nSize As Long) As Long
代码如下：
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, _
Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
请看下面的例子如何使用函数：
Call MsgBox("The Windows directory is " & GetWinPath, _
vbInformation)
----------------------------------------------------------------------
----------
怎样得到磁盘序号？
当磁盘被格式化过之后，操作系统就会在它上面留下磁盘的序号。虽然这个序号
并不唯一，当对于一个32位的整数来说，很少有机会能看到两个相同的序号，你
相信吗？这个序号经常被用来作为拷贝保护的一部分，下面的例子会教给你如何
得到磁盘序号：
声明函数：
Private Declare Function GetVolumeInformation Lib _
"kernel32.dll" Alias "GetVolumeInformationA" (ByVal _
lpRootPathName As String, ByVal lpVolumeNameBuffer As _
String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength _
As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal _
nFileSystemNameSize As Long) As Long
代码如下：
Function GetSerialNumber(strDrive As String) As Long
Dim SerialNum As Long
Dim Res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
Res = GetVolumeInformation(strDrive, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
GetSerialNumber = SerialNum
End Function
使用该函数：
Call MsgBox GetSerialNumber("C:\")
它将告诉你C驱的磁盘序号。
----------------------------------------------------------------------
----------
怎样加速数据库的访问速度？
下面的窍门将教会你如何加速数据库的访问速度，当人们要读取一个数据库时往
往会这么做：
Do while not records.eof
combo1.additem records![Full Name]
records.movenext
loop
经常遇到的问题是每次数据库移动到下一条记录的时候，它必须检查是否到达文
件底部，这将使数据的访问速度大打折扣。当你需要在一个巨大的数据库中移动
或寻找时，最好是这样做：
records.movelast
intRecCount=records.RecordCount
records.movefirstfor intCounter=1 to intRecCount combo1.additem record
s![Full Name]
records.movenext
next intCounter
试试看，你将得到33%的速度提升！
----------------------------------------------------------------------
----------
怎么对付数据库中的空字符？
缺省时的数据库字段为空字符（并不是指一个字符串值为“空格”，而是什么也
没有），当你读取这些字段的时候把它们赋值给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, By
Val 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)
----------------------------------------------------------------------
----------
怎样确定系统是否安装了声卡？
现在很多程序都在特定的事件播放声音，但是如果系统没有安装声卡，那无意于
对牛弹琴，下面的例子将告诉你系统是否安装了声卡：
声明函数：
Declare Function waveOutGetNumDevs Lib "winmm.dll" _
Alias "waveOutGetNumDevs" () As Long
代码：
Dim i As Integeri = waveOutGetNumDevs()If i > 0 Then MsgBox "你的系统可
以播放声音。", _
vbInformation, "声卡检测"
Else
MsgBox "你的系统不能播放声音。", _
vbInformation, "声卡检测"
End If
----------------------------------------------------------------------
----------
怎样使用API播放MIDI音乐？
本例将演示如何使用mciSendString播放MIDI文件，如果你有专业版或企业版的V
B环境，可以直接使用MCI控件播放MIDI，而无需使用API。
请按照以下步骤进行：
首先建立一个新的项目文件，添加一个命令按钮，并向按钮添加以下代码：
Private Sub Command1_Click()
Dim ret As Integer
' 下面的代码将打开C:\WIN31\CANYON.MID的音序器
ret = mciSendString("open c:\windows\CANYON.MID _
type sequencer alias canyon", 0&, 0, 0)
'直到MCI命令返回到程序
ret = mciSendString("play canyon wait", 0&, 0, 0) ' 关闭Canyon
ret = mciSendString("close canyon", 0&, 0, 0)
End Sub
在Form1的general declarations中加入以下代码：
#If Win32 Then
Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
#ElseIf Win16 Then
Private Declare Function mciSendString Lib "mmsystem" (ByVal _
lpstrCommand As String, ByVal lpstrReturnStr As Any, ByVal _
wReturnLen As Integer, ByVal hCallBack As Integer) As Long
#End If
----------------------------------------------------------------------
----------
怎样播放AVI文件？
本例将演示如何不用MCI播放AVI文件：
添加一个新模块文件，加入以下代码：
Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength _As Long, ByVal hwndC
allback As Long) As Long
向Form1加入以下代码：
Private Sub Form_Activate()
Dim returnstring As String
FileName As String
returnstring = Space(127)
'要播放的AVI文件
FileName = "F:\Funstuff\Videos\Highperf\Welcome1.avi"
erg = mciSendString("open " & Chr$(34) & FileName & _
Chr$(34) & " type avivideo alias video", returnstring, _
127, 0)
erg = mciSendString("set video time format ms", _
returnstring, 127, 0)
erg = mciSendString("play video from 0", returnstring, _
127, 0)
End Sub
关闭AVI文件使用以下代码：
erg = mciSendString("close video", returnstring, 127, 0)
----------------------------------------------------------------------
----------
怎样用VB建立internet连接？
建立拨号上网的连接，可以使用以下代码：
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " _
& "connection_name", 1)
----------------------------------------------------------------------
----------
怎样用VB断开与internet的连接？
如果你想终止与internet的连接，可以使用断开连接的方法，首先你必须声明以
下函数和变量：
Declarations
Public Const RAS_MAXENTRYNAME As Integer = 256Public Const RAS_MAXDEVI
CETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412Public Const ERROR_SUCCES
S = 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 LongDeclare Function RegOpenKey Lib "advapi32.dll" Alias _"RegOpenK
eyA" (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
----------------------------------------------------------------------
----------
怎样使Ctrl-Alt-Delete和Ctrl-Esc无效？
在VB程序中经常要使Ctrl-Alt-Delete和Ctrl-Esc 无效：
声明以下函数：
Private 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
代码如下：
Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)End Sub 使Ctrl-Alt-
Delete ：
Call DisableCtrlAltDelete(True)
恢复Ctrl-Alt-Delete ：
Call DisableCtrlAltDelete(False)
----------------------------------------------------------------------
----------
怎样使用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" Alias _
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long
退出Windows：
t& = ExitWindowsEx(EWX_FORCE OR EWX_REBOOT, 0)
HandsomeMen 推荐
=============================================
欢迎投稿 [email protected]
主 页 goodvbhome.yeah.net
=============================================
订阅请到如下地址：
http://server.com/WebApps/mail-list-subscribe.cgi?id=16852
=============================================
----------------------------------------------------------------------
----------
如何改变屏幕的分辨率？
对于很多VB程序员来说怎样改变屏幕的分辨率一直是一个难题，而且在API-View
er里竟然没有EnumDisplaySettings和ChangeDisplaySettings！！遵从以下的步
骤，你就可以改变屏幕的分辨率。将以下代码加入模块文件：
Declare Function EnumDisplaySettings Lib "user32" _
Alias "EnumDisplaySettingsA" _
(ByVal lpszDeviceName As Long, _
ByVal iModeNum As Long, _
lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" _
Alias "ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
2、下面的例子将演示如何把屏幕分辨率更改为640x480（保持原来的颜色数）。
Dim DevM As DEVMODE
'DevM收集信息
erg& = EnumDisplaySettings(0&, 0&, DevM)
'不改变颜色数目是因为如果改变颜色数就要重新启动
DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'Or DM_BITSPERPEL
DevM.dmPelsWidth = 640 '屏幕宽度
DevM.dmPelsHeight = 480 '屏幕高度
'DevM.dmBitsPerPel = 32 (还可以为 8, 16, 32甚至4)
'改变显示模式并检查是否可能
erg& = ChangeDisplaySettings(DevM, CDS_TEST)'检查是否成功 Select Case
erg&
Case DISP_CHANGE_RESTART
an = MsgBox("你现在必须重新启动系统，执行吗？", vbYesNo + vbSystemModa
l, "消息")
If an = vbYes Then erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
MsgBox "一切正常！", vbOKOnly + vbSystemModal, "成功"
Case Else
MsgBox "显示模式不支持", vbOKOnly + vbSystemModal, "错误"End Select
End Sub
----------------------------------------------------------------------
----------
如何用VB抓图？
下面的例子将演示怎样把桌面图片用BitBlt函数复制到窗体中，你可以利用它制
作抓图程序，或是制作屏保程序。
把以下代码加入模块：
Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Integer, ByVal x As Integer, _
ByVal y As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Integer, ByVal _
hSrcDC As Integer, ByVal xSrc As Integer, _
ByVal ySrc As Integer, ByVal dwRop As _
Long) As Integer
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046
窗体代码：
设置窗体属性如下：
AutoRedraw True
BorderStyle 0 - None
WindowState 2 - Maximized
现在，把下面的代码加入到窗体中。
Private Sub Form_Load()
Dim DeskhWnd As Long, DeskDC As Long
'得到桌面的hWnd
DeskhWnd& = GetDesktopWindow()
DeskDC& = GetDC(DeskhWnd&)
BitBlt Form1.hDC, 0&, 0&, _Screen.Width, Screen.Height, DeskDC&, _
0&, 0&, SRCCOPY
End Sub
向窗体添加一个命令按钮，并加入以下代码：
Private Sub Command1_Click()
Unload Me
End
End Sub
----------------------------------------------------------------------
----------
怎样得到磁盘空间未占用的字节数？
要得到磁盘空间未占用的字节数可以使用GetDiskFreeSpace 函数：
Declare Function GetDiskFreeSpace Lib "kernel32" Alias _
"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _
lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters _
As Long) As Long
下面是找出磁盘所剩空间的例子：
Dim SectorsPerCluster&
Dim BytesPerSector&
Dim NumberOfFreeClusters&
Dim TotalNumberOfClusters&
Dim FreeBytes&
dummy& = GetDiskFreeSpace("c:\", SectorsPerCluster, _
BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = NumberOfFreeClusters * SectorsPerCluster * _
BytesPerSector
----------------------------------------------------------------------
----------
怎样得到Windows系统的目录？
如果你的程序用到ini文件，那么储存它们最好的地方就是Windows目录，下面的
例子向你展示如何得到Windows目录。
声明以下函数：
Public Const MAX_PATH = 260
Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal _
nSize As Long) As Long
代码如下：
Public Function GetWinPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetWindowsDirectory(strFolder, MAX_PATH)
If lngResult <> 0 Then
GetWinPath = Left(strFolder, InStr(strFolder, _
Chr(0)) - 1)
Else
GetWinPath = ""
End If
End Function
请看下面的例子如何使用函数：
Call MsgBox("The Windows directory is " & GetWinPath, _
vbInformation)
----------------------------------------------------------------------
----------
怎样得到磁盘序号？
当磁盘被格式化过之后，操作系统就会在它上面留下磁盘的序号。虽然这个序号
并不唯一，当对于一个32位的整数来说，很少有机会能看到两个相同的序号，你
相信吗？这个序号经常被用来作为拷贝保护的一部分，下面的例子会教给你如何
得到磁盘序号：
声明函数：
Private Declare Function GetVolumeInformation Lib _
"kernel32.dll" Alias "GetVolumeInformationA" (ByVal _
lpRootPathName As String, ByVal lpVolumeNameBuffer As _
String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength _
As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal _
nFileSystemNameSize As Long) As Long
代码如下：
Function GetSerialNumber(strDrive As String) As Long
Dim SerialNum As Long
Dim Res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
Res = GetVolumeInformation(strDrive, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
GetSerialNumber = SerialNum
End Function
使用该函数：
Call MsgBox GetSerialNumber("C:\")
它将告诉你C驱的磁盘序号。
----------------------------------------------------------------------
----------
怎样加速数据库的访问速度？
下面的窍门将教会你如何加速数据库的访问速度，当人们要读取一个数据库时往
往会这么做：
Do while not records.eof
combo1.additem records![Full Name]
records.movenext
loop
经常遇到的问题是每次数据库移动到下一条记录的时候，它必须检查是否到达文
件底部，这将使数据的访问速度大打折扣。当你需要在一个巨大的数据库中移动
或寻找时，最好是这样做：
records.movelast
intRecCount=records.RecordCount
records.movefirstfor intCounter=1 to intRecCount combo1.additem record
s![Full Name]
records.movenext
next intCounter
试试看，你将得到33%的速度提升！
----------------------------------------------------------------------
----------
怎么对付数据库中的空字符？
缺省时的数据库字段为空字符（并不是指一个字符串值为“空格”，而是什么也
没有），当你读取这些字段的时候把它们赋值给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, By
Val 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)
----------------------------------------------------------------------
----------
怎样确定系统是否安装了声卡？
现在很多程序都在特定的事件播放声音，但是如果系统没有安装声卡，那无意于
对牛弹琴，下面的例子将告诉你系统是否安装了声卡：
声明函数：
Declare Function waveOutGetNumDevs Lib "winmm.dll" _
Alias "waveOutGetNumDevs" () As Long
代码：
Dim i As Integeri = waveOutGetNumDevs()If i > 0 Then MsgBox "你的系统可
以播放声音。", _
vbInformation, "声卡检测"
Else
MsgBox "你的系统不能播放声音。", _
vbInformation, "声卡检测"
End If
----------------------------------------------------------------------
----------
怎样使用API播放MIDI音乐？
本例将演示如何使用mciSendString播放MIDI文件，如果你有专业版或企业版的V
B环境，可以直接使用MCI控件播放MIDI，而无需使用API。
请按照以下步骤进行：
首先建立一个新的项目文件，添加一个命令按钮，并向按钮添加以下代码：
Private Sub Command1_Click()
Dim ret As Integer
' 下面的代码将打开C:\WIN31\CANYON.MID的音序器
ret = mciSendString("open c:\windows\CANYON.MID _
type sequencer alias canyon", 0&, 0, 0)
'直到MCI命令返回到程序
ret = mciSendString("play canyon wait", 0&, 0, 0) ' 关闭Canyon
ret = mciSendString("close canyon", 0&, 0, 0)
End Sub
在Form1的general declarations中加入以下代码：
#If Win32 Then
Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
#ElseIf Win16 Then
Private Declare Function mciSendString Lib "mmsystem" (ByVal _
lpstrCommand As String, ByVal lpstrReturnStr As Any, ByVal _
wReturnLen As Integer, ByVal hCallBack As Integer) As Long
#End If
----------------------------------------------------------------------
----------
怎样播放AVI文件？
本例将演示如何不用MCI播放AVI文件：
添加一个新模块文件，加入以下代码：
Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength _As Long, ByVal hwndC
allback As Long) As Long
向Form1加入以下代码：
Private Sub Form_Activate()
Dim returnstring As String
FileName As String
returnstring = Space(127)
'要播放的AVI文件
FileName = "F:\Funstuff\Videos\Highperf\Welcome1.avi"
erg = mciSendString("open " & Chr$(34) & FileName & _
Chr$(34) & " type avivideo alias video", returnstring, _
127, 0)
erg = mciSendString("set video time format ms", _
returnstring, 127, 0)
erg = mciSendString("play video from 0", returnstring, _
127, 0)
End Sub
关闭AVI文件使用以下代码：
erg = mciSendString("close video", returnstring, 127, 0)
----------------------------------------------------------------------
----------
怎样用VB建立internet连接？
建立拨号上网的连接，可以使用以下代码：
Dim res
res = Shell("rundll32.exe rnaui.dll,RnaDial " _
& "connection_name", 1)
----------------------------------------------------------------------
----------
怎样用VB断开与internet的连接？
如果你想终止与internet的连接，可以使用断开连接的方法，首先你必须声明以
下函数和变量：
Declarations
Public Const RAS_MAXENTRYNAME As Integer = 256Public Const RAS_MAXDEVI
CETYPE As Integer = 16
Public Const RAS_MAXDEVICENAME As Integer = 128
Public Const RAS_RASCONNSIZE As Integer = 412Public Const ERROR_SUCCES
S = 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 LongDeclare Function RegOpenKey Lib "advapi32.dll" Alias _"RegOpenK
eyA" (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
----------------------------------------------------------------------
----------
怎样使Ctrl-Alt-Delete和Ctrl-Esc无效？
在VB程序中经常要使Ctrl-Alt-Delete和Ctrl-Esc 无效：
声明以下函数：
Private 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
代码如下：
Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)End Sub 使Ctrl-Alt-
Delete ：
Call DisableCtrlAltDelete(True)
恢复Ctrl-Alt-Delete ：
Call DisableCtrlAltDelete(False)
----------------------------------------------------------------------
----------
怎样使用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" Alias _
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long
退出Windows：
t& = ExitWindowsEx(EWX_FORCE OR EWX_REBOOT, 0)
HandsomeMen 推荐
=============================================
欢迎投稿 [email protected]
主 页 goodvbhome.yeah.net
=============================================
订阅请到如下地址：
http://server.com/WebApps/mail-list-subscribe.cgi?id=16852
=============================================
--
网站主页地址：http://home.hn.cninfo.net/home/msnet
网易上的主页地址：http://www4.netease.com/~aaaaaaaaa
本网站主页镜像地址：http://goodvbhome.yeah.net
※ 修改:．msnet 于 May 17 23:29:14 修改本文．[FROM: 202.103.47.117]
※ 来源:．月光软件站 http://www.moon-soft.com．[FROM: 202.103.47.117]
|
|