mmc.frm

来自「VB6程序设计参考手册 -独立源码 VB6程序设计参考手册 -独立源码」· FRM 代码 · 共 167 行

VERSION 5.00
Object = "{C1A8AF28-1257-101B-8FB0-0020AF039CA3}#1.1#0"; "MCI32.OCX"
Begin VB.Form Form1 
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "CDPlayer"
   ClientHeight    =   1830
   ClientLeft      =   150
   ClientTop       =   435
   ClientWidth     =   4665
   Icon            =   "MMC.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1830
   ScaleWidth      =   4665
   StartUpPosition =   3  '窗口缺省
   Begin VB.CheckBox Check1 
      Caption         =   "试听"
      Height          =   255
      Left            =   3120
      TabIndex        =   4
      Top             =   1560
      Width           =   735
   End
   Begin VB.DriveListBox Drive1 
      Height          =   300
      Left            =   360
      TabIndex        =   3
      Top             =   1440
      Visible         =   0   'False
      Width           =   735
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   10000
      Left            =   240
      Top             =   120
   End
   Begin MCI.MMControl MMControl1 
      Height          =   495
      Left            =   720
      TabIndex        =   0
      Top             =   960
      Width           =   3540
      _ExtentX        =   6244
      _ExtentY        =   873
      _Version        =   393216
      DeviceType      =   ""
      FileName        =   ""
   End
   Begin VB.Label Label2 
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00800000&
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   600
      Width           =   4455
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      BackColor       =   &H00C0C0C0&
      Caption         =   "CD Player"
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   24
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00800000&
      Height          =   615
      Left            =   240
      TabIndex        =   1
      Top             =   120
      Width           =   4215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'  初始化，检查是否有光盘驱动器和CD光盘
Private Sub Form_Load()
    MMControl1.AutoEnable = True
    MMControl1.Notify = False
    MMControl1.Wait = True
    MMControl1.Shareable = False
    MMControl1.DeviceType = "cdaudio"
    MMControl1.RecordVisible = False
    Call cdscan
End Sub

'   检查是否有光盘驱动器和CD光盘
Private Sub cdscan()
    Dim n As Integer
    Dim fs, drv
    Set fs = CreateObject("Scripting.FileSystemObject")
    For n = 0 To Drive1.ListCount - 2
        Set drv = fs.GetDrive(Left(Drive1.List(n), 2)) '获取驱动器类型
        If drv.drivetype = 4 Then ' 驱动器是光盘驱动器的话
        cdname = Drive1.List(n)
        On Error GoTo Errhandle
        '检测光驱里是否有光盘
        sr = Dir(cdname & "\Track01.cda", vbReadOnly) '检查是否有CD音轨
            If sr <> "" Then
            audiopath = cdname & "\" & sr
            Exit For
            End If
        End If
    Next

    If audiopath <> "" Then  '找到音轨则播放
        Call cdplay(audiopath)
    ElseIf cdname <> "" Then '在光盘上找不到CD音轨
        feedback = MsgBox("请确认放入的是CD光盘", vbAbortRetryIgnore)
        Select Case feedback
            Case vbAbort
                End
            Case vbRetry
                Call cdscan
            Case vbIgnore
            '   什么也不做
        End Select
    Else  '该计算机没有光驱
        MsgBox "该计算机没有光驱，即将退出。"
        End
    End If
    Exit Sub
    
Errhandle:
    MsgBox "请放入光盘"
End Sub

'   打开设备
Private Sub cdplay(ByVal audiopath As String)
    MMControl1.FileName = audiopath
    MMControl1.Command = "Open"
End Sub

'  更新状态
Private Sub MMControl1_StatusUpdate()
    Label2.Caption = MMControl1.Track & " of " & MMControl1.Tracks & " Tracks"
    If Check1.Value Then
        Timer1.Enabled = True
    Else
        Timer1.Enabled = False
    End If
End Sub

'   试听，每曲播放10秒
Private Sub Timer1_Timer()
    MMControl1.Command = "Next"
End Sub

'  卸载窗体时，停止播放并关闭设备
Private Sub Form_Unload(Cancel As Integer)
    MMControl1.Command = "Stop"
    MMControl1.Command = "Close"
End Sub