vb 高手搜集-常见问题总结(1)

　　使用：
Dim Flag As Boolean
Flag = Fun_FloppyDrive("A:")
If Flag = False Then MsgBox "A:驱没有准备好，请将磁盘插入驱动器！", vbCritical

''-------------------------------
''函数:检查软驱中是否有盘的存在
''-------------------------------
Private Function Fun_FloppyDrive(sDrive As String) As Boolean
On Error Resume Next
Fun_FloppyDrive = Dir(sDrive) <> ""
End Function

　　如何弹出和关闭光驱托盘

Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub Command1_Click()
mciExecute "set cdaudio door open" ''弹出光驱
Label2.Caption = "弹 出"
End Sub

Private Sub Command2_Click()
Label2.Caption = "关 闭"
mciExecute "set cdaudio door closed" ''合上光驱
Unload Me
End
End Sub

　　如何让你的程序在任务列表隐藏

Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

''请你试试 Ctrl+Alt+Del 是不是你的程序隐藏了
Private Sub Command1_Click()
i = RegisterServiceProcess(GetCurrentProcessId, 1)
End Sub

　　如何用程序控制滑鼠游标 (Mouse Cursor) 到指定位置

　　以下这个例子，当 User 在 Text1 中按下 ''Enter'' 键后，滑鼠游标会自动移到 Command2 按钮上方

　　请在声明区中加入以下声明：

　　16 位版本： ( Sub 无传回值 )
Declare Sub SetCursorPos Lib "User" (ByVal X As Integer, ByVal Y As Integer)

　　32 位版本： ( Function 有传回值，Integer 改成 Long )
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long

　　在 Form1 中加入以下程序码：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
x% = (Form1.Left + Command2.Left + Command2.Width / 2 + 60) / Screen.TwipsPerPixelX
y% = (Form1.Top + Command2.Top + Command2.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos x%, y%
End If
End Sub

　　如何让用户自行输入方程式，并计算其结果

　　假设我们要让使用者在“方程式”栏位中自由输入方程式，然后利用方程式进行计算，则引用ScriptControl控件可以很方便地做到。

　　( ScriptControl 控件附属于VB 6.0，如果安装后没有看到此一控件，可在光盘的 \Common\Tools\VB\Script 目录底下找此一控件， 其.文件名为Msscript.ocx。) 假设放在窗体上的ScriptControl控件名称为ScriptControl1，则在“计算”按钮的Click事件中编写如下代码：

Dim Statement As String Statement = "X=" + Text1.Text + vbCrLf + _ "Y=" + Text2.Text + vbCrLf + _ "MsgBox ""计算结果="" & Y " ScriptControl1.ExecuteStatement( Statement

　　如何让一个 App 永远保持在最上层 ( Always on Top )

　　请在声明区中加入以下声明

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 SWP_NOMOVE = &H2 ''不更动目前视窗位置
Const SWP_NOSIZE = &H1 ''不更动目前视窗大小
Const HWND_TOPMOST = -1 ''设定为最上层
Const HWND_NOTOPMOST = -2 ''取消最上层设定
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE

''将 APP 视窗设定成永远保持在最上层
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS

''取消最上层设定
SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS

　　我要如何在程序中开启网页

　　在声明区中声明如下 (在 .bas 档中用 Public, 在 Form 中用 Private)

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

　　在程序中

Intranet：
ShellExecute Me.hWnd, "open", "http://Intranet主机/目录", "", "", 5
Internet：
ShellExecute Me.hWnd, "open", "http://www.ruentex.com.tw", "", "", 5

　　VB可以产生四角形以外其他形状的 Form 吗

　　这个问题，您一定无法想像有多容易，您可以产生任何形状的 Form，但必须借助 CreateEllipticRgn 及 SetWindowRgn 二个 API ，例如：

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Sub Form_Load()
Dim lReturn As Long
Me.Show
lReturn = SetWindowRgn(hWnd, CreateEllipticRgn(10, 10, 340, 150), True)
End Sub

　　CreateEllipticRgn 之四个参数说明如下：
　　X1：椭圆中心点之X轴位置，但以 Form 的实№边界为限。
　　Y1：椭圆中心点之Y轴位置，但以 Form 的实№边界为限。
　　X2：椭圆长边的长度
　　Y2：椭圆短边的长度的

如何移除 Form 右上方之『X』按钮

　　其实 Form 右上方之三个按钮分别对应到 Form 左上方控制盒 (ControlBox) 中的几个选项 (缩到最小 / 放到最大 / 关闭)，而其中的最大化 (MaxButton) 及最小化 (Minbutton) 都可以直接在 Form 的属性中设定，但是 VB 并没有提供设定『X』按钮的功能！要达到这个功能，必须借助 API：

　　由于『X』按钮对应到 ControlBox 的关闭选项，所以我们只要移除系统 Menu (就是ControlBox) 的关闭选项即可！您自己可以先看看您现在使用的 Browser 左上方的系统 Menu，【关闭】选项是在第几个，不是第 6 个！是第 7 个，分隔线也算一个！分隔线才是第 6 个！

　　当我们移除了关闭选项之後，会留下一条很奇怪的分隔线，所以最好连分隔线也一并移除。而 Menu 的 Index 是从 0 开始，分隔线是第 6 个，所以 Index = 5。

　　修正：为了让程序码在 Windows NT 也能运作正常，将各 Integer 型态改成 Long。 89.05.04

　　抓取系统 Menu 的 hwnd
Private Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

　　移除系统 Menu 的 API
Private Declare Function RemoveMenu Lib "user32" Alias "RemoveMenu" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

　　第一个参数是系统 Menu 的 hwnd
　　第二个参数是要移除选项的 Index

　　如何用鼠标移动没有标题的 Form，或移动 Form 中的控制项

　　在声明区中放入以下声明：

　　16 位版本： ( Sub 无返回值 )
Private Declare Sub ReleaseCapture Lib "User" ()
Private Declare Sub SendMessage Lib "User" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Long)

　　32 位版本： ( Function 有返回值，Integer 改成 Long )
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

　　共用常数：
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012

　　若要移动 Form，程序码如下：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Form1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub

　　以上功能也适用于用鼠标在 Form 中移动控制项，程序码如下：
Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
i = ReleaseCapture
i = SendMessage(Command1.hwnd, WM_SYSCOMMAND, SC_MOVE, 0)
End Sub

　　检查文件是否存在

Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then FileExists = False Else FileExists = True
End Function

　　如何设置对VB数据库连接的动态路径

　　我个人因为经常作一些数据库方面的程序，对于程序间如何与数据库进行接口的问题之烦是深有体会，因为VB在数据库链接的时候，一般是静态，即数据库存放的路径是固定的，如用VB的DATA，adodc,DataEnvironment 等到作数据库链接时，如果存放数据库的路径被改变的话，就会找不到路经，真是一个特别烦的事。
　　
　　笔者的解决方法是利用app.path 来解决这个问题。

　　一、用data控件进行数据库链接，可以这样：
　　在form_load()过程中放入：
private form_load()
Dim str As String ''定义
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
data1.databasename=str & "\数据库名"
data1.recordsource="数据表名"
data1.refresh
sub end

　　这几句话的意为，打开当前程序运行的目录下的数据库。
　　
　　你只要保证你的数据库在你程序所在的目录之下就行了。

　　二、利用adodc（ADO Data Control)进行数据库链接：
private form_load ()
Dim str As String ''定义
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "\tsl.mdb"
Adodc1.ConnectionString = str
Adodc1.CommandType = adCmdText
Adodc1.RecordSource = "select * from table3"
Adodc1.Refresh
end sub

　　三、利用DataEnvironment进行数据库链接
　　
　　可在过程中放入：
On Error Resume Next
If DataEnvironment1.rsCommand1.State <> adStateClosed Then
DataEnvironment1.rsCommand1.Close ''如果打开，则关闭
End If
''i = InputBox("请输入友人编号:", "输入")
''If i = "" Then Exit Sub
DataEnvironment1.Connection1.Open App.Path & "\userdatabase\tsl.mdb"
DataEnvironment1.rsCommand1.Open "select * from table3 where 编号=''" & i & "''"
''Set DataReport2.DataSource = DataEnvironment1
''DataReport2.DataMember = "command1"
''DataReport2.show
end sub

　　四、利用ADO(ActiveX Data Objects)进行编程：

　　建立连接：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim str
str = App.Path
If Right(str, 1) <> "\" Then
str = str + "\"
End If
str = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & str & "\tsl.mdb"
conn.open str
rs.cursorlocation=aduseclient
rs.open "数据表名",conn,adopenkeyset.adlockpessimistic

　　用完之后关闭数据库：
conn.close
set conn=nothing