用VB編寫一個光驅保鏢

作者：土人
編程思路：當光驅里有光盤，立即檢測此光盤是否已經注冊，如不是，則彈出光驅，從而達到保護光驅的作用。

實現方法：
一.注冊光盤
利用INI配置文件記錄光盤的卷標號和序列號，比如一張卷標號為Sys、序列號為38972126的光盤，可在INI文件中在[CDRom]下按如下格式記錄：ys=38972126。
二.檢測光盤是否已經注冊
用一個Timer控件監視光驅里是否有光盤，若有，則激活另一個Timer控件，由它來檢測光驅里的光盤是否已經注冊，然后進行相關操作。
三.獲取光盤卷標和序列號
用GetDriveType判斷光驅盤符、用GetVolumeInformation讀取光盤的卷標和序列號。
四.彈出光驅
用mciSendString可對光驅的開、關進行操作，格式如下：
Call mciSendString("set CDAudio door open", returnstring, 127, 0)

具體步驟：
一.新建標準EXE工程，給窗體繪制如下控件：

控件 Name Caption
Timer tmrCheck
Timer tmrCd
命令按鈕 cmdAdd 注冊光盤
命令按鈕 cmdUnlock 解除保護

二、缺省添加一個標準模塊

三、編寫代碼如下——

'******* 模塊代碼：******

Option Explicit

'獲取磁盤類型的API
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
'獲取磁盤信息的API
Public 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

'用于操作光驅的API
Public 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

'讀寫INI的API
Public Declare Function WritePrivateProfileString Lib _
"kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, ByVal lpKeyName _
As Any, ByVal lpString As Any, ByVal lpFileName As _
String) As Long
Public Declare Function GetPrivateProfileString Lib _
"kernel32" Alias "GetPrivateProfileStringA" (ByVal _
lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As _
String, ByVal nSize As Long, ByVal lpFileName As String) _
As Long

Public Const DRIVE_CDROM = 5 '磁盤類型常量--光驅為5

'寫INI函數
Public Function WriteIni(ByVal section As String, ByVal key As String, _
ByVal value As String) As Boolean
Dim x As Long, Buff As String * 128, I As Integer
Buff = value + Chr(0)
x = WritePrivateProfileString(section, key, Buff, App.Path + "\cd.ini")
WriteIni = x
End Function

'讀INI函數
Public Function ReadIni(ByVal section As String, ByVal key As String) As String
Dim x As Long, Buff As String * 128, I As Integer
x = GetPrivateProfileString(section, key, "", Buff, 128, App.Path + "\cd.ini")
I = InStr(Buff, Chr(0))
ReadIni = Trim(Left(Buff, I - 1))
End Function

'****** 窗體代碼：******

Option Explicit

Dim cdName As String '光驅盤符
Dim volName As String '光盤卷標
Dim Serial As String '光盤序列號

Private Sub cmdAdd_Click()

'添加光盤
Dim sR As String

On Error GoTo ErrHandle
sR = Dir(cdName & "*.*")
Readcd '讀取光盤信息
Call WriteIni("CDRom", volName, Serial)
Exit Sub
ErrHandle:
Exit Sub

End Sub

Private Sub cmdUnlock_Click()

'保護/解除保護
Select Case cmdUnlock.Caption
Case "解除保護"
tmrCheck.Enabled = False
cmdUnlock.Caption = "保護模式"
Case "保護模式"
tmrCheck.Enabled = True
cmdUnlock.Caption = "解除保護"
End Select

End Sub

Private Sub Form_Load()

Dim DrvN As Integer '驅動器的ASCII碼
Dim DrvType As Integer '驅動器的類別
Dim n As Integer

tmrCheck.Enabled = True
tmrCheck.Interval = 1000
tmrCd.Enabled = False
tmrCd.Interval = 1

'獲取光驅盤符
DrvN = Asc("c")
For n = 0 To 10
DrvN = DrvN + 1
DrvType = GetDriveType(Chr(DrvN) & ":\")
If DrvType = 5 Then
cdName = Chr(DrvN) & ":\"
End If
Next

If cdName = "" Then '無光驅則退出
MsgBox "該計算機沒有光驅，即將退出。"
End
End If

End Sub

Private Sub Readcd() '讀取cd信息

Dim Vol As String * 256 '卷標
Dim FatType As String * 256 'fat格式
Dim GetVal As Long '序列號
Dim TempLon1 As Long
Dim TempLon2 As Long
Call GetVolumeInformation(cdName, Vol, 256, _
GetVal, TempLon1, TempLon2, FatType, 256)

volName = Vol: Serial = GetVal '給卷標、序列號賦值

End Sub

Private Sub tmrCheck_Timer()

Dim sR As String

On Error GoTo ErrHandle
'用Dir函數檢測光驅里是否有光盤
sR = Dir(cdName & "*.*") '若有光盤
tmrCd.Enabled = True '則tmrCd有效
Exit Sub
ErrHandle: '若無則tmrCd無效
tmrCd.Enabled = False

End Sub

Private Sub tmrCd_Timer()

Dim MyStr As String, ReStr As Long

Readcd
MyStr = ReadIni("CDRom", volName)
If Serial <> MyStr Then Call mciSendString("set CDAudio door open", ReStr, 127, 0)
Me.Caption = ReStr
tmrCd.Enabled = False

End Sub

四、運行程序
將工程保存在指定目錄，即可運行程序。

以上代碼在PWin98、VB6.0中文企業版環境下運行通過。當然，為使程序的可操作性更強，還有許多工作要做；如果您使用以上代碼編制了一個完美的光驅保鏢，請發給土人一個免費的拷貝，謝謝！

原文轉自：http://www.anti-gravitydesign.com