form1.frm

VB源码,是初学者的福因.让你很快掌握VB编程

'
rc = mixerOpen(hmixer, 0, 0, 0, 0)
If MMSYSERR_NOERROR <> rc Then
    MsgBox "Could not open the mixer.", vbCritical, "Volume Control"
    Exit Sub
End If
'
' Get the waveout volume control.
'
OK = fGetVolumeControl(hmixer, _
        MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, _
        MIXERCONTROL_CONTROLTYPE_VOLUME, volCtrl)
'
' If the function successfully gets the volume control,
' the maximum and minimum values are specified by
' lMaximum and lMinimum. Use them to set the scrollbar.
'
If OK Then
    With Volume
        .Max = volCtrl.lMinimum
        .Min = volCtrl.lMaximum \ 2
        .SmallChange = 1000
        .LargeChange = 1000
    End With
End If
    Left = (Screen.Width - Width) \ 2       'will center form
    Top = (Screen.Height - Height) \ 2      'will center form

Timer1.Interval = 500 'Change value depending On the speed of flahing.

If (App.PrevInstance = True) Then
    End
End If


Timer1.Enabled = False
FastForwardSpeed = 10
CDLoad = False


If (SendMCIString("open cdaudio alias cd wait shareable", True) = False) Then
    End
End If

SendMCIString "set cd time format tmsf wait", True
Timer1.Enabled = True
MsgBox ("Open CD rom Drive.")
SendMCIString "set cd door open", True  'sets cd door open
MsgBox ("Put your compact disk in the CD Rom drive and click Close.")

End Sub

Private Sub Form_Unload(Cancel As Integer)
'Close all MCI devices opened by this program
SendMCIString "close all", False
End Sub

' Play the CD
Private Sub Play_Click()
SendMCIString "play cd", True
Playing = True
End Sub

' Pause the CD
Private Sub Pause_Click()
SendMCIString "pause cd", True
Playing = False
Update
End Sub
' Eject the CD
Private Sub Eject_Click()
SendMCIString "set cd door open", True
Update
End Sub
' Fast forward
Private Sub FastForward_Click()
Dim e As String * 40

SendMCIString "set cd time format milliseconds", True
mciSendString "status cd position wait", e, Len(e), 0
If (Playing) Then
    Command = "play cd from " & CStr(CLng(e) + FastForwardSpeed * 1000)
Else
    Command = "seek cd to " & CStr(CLng(e) + FastForwardSpeed * 1000)
End If
mciSendString Command, 0, 0, 0
SendMCIString "set cd time format tmsf", True
Update
End Sub
' Rewind the CD
Private Sub Rewind_Click()
Dim e As String * 40

SendMCIString "set cd time format milliseconds", True
mciSendString "status cd position wait", e, Len(e), 0
If (Playing) Then
    Command = "play cd from " & CStr(CLng(e) - FastForwardSpeed * 1000)
Else
    Command = "seek cd to " & CStr(CLng(e) - FastForwardSpeed * 1000)
End If
mciSendString Command, 0, 0, 0
SendMCIString "set cd time format tmsf", True
Update
End Sub
' Forward track
Private Sub NextTrack_Click()
If (Track < TotalTracks) Then
    If (Playing) Then
        Command = "play cd from " & Track + 1
        SendMCIString Command, True
    Else
        Command = "seek cd to " & Track + 1
        SendMCIString Command, True
    End If
Else
    SendMCIString "seek cd to 1", True
End If
Update
End Sub
' Go to previous track
Private Sub PreviousTrack_Click()
Dim from As String
If (Minute = 0 And Second = 0) Then
    If (Track > 1) Then
        from = CStr(Track - 1)
    Else
        from = CStr(TotalTracks)
    End If
Else
    from = CStr(Track)
End If
If (Playing) Then
    Command = "play cd from " & from
    SendMCIString Command, True
Else
    Command = "seek cd to " & from
    SendMCIString Command, True
End If
Update
End Sub

' Update the display and state variables
Private Sub Update()
Static e As String * 30

' Check if CD is in the player
mciSendString "status cd media present", e, Len(e), 0
If (CBool(e)) Then
    ' Enable all the controls, get CD information
    If (CDLoad = False) Then
        mciSendString "status cd number of tracks wait", e, Len(e), 0
        TotalTracks = CInt(Mid$(e, 1, 2))
        Eject.Enabled = True
        
        ' If CD only has 1 track, then it's probably a data CD
        If (TotalTracks = 1) Then
            Exit Sub
        End If
        
        mciSendString "status cd length wait", e, Len(e), 0
        TotalTrack.Caption = "Tracks: " & TotalTracks & "  Total time: " & e
        ReDim TrackLength(1 To TotalTracks)
        Dim i As Integer
        For i = 1 To TotalTracks
            Command = "status cd length track " & i
            mciSendString Command, e, Len(e), 0
            TrackLength(i) = e
        Next
        Dim ts As Integer
        TrackSelection.Clear
        For ts = 1 To TotalTracks
        TrackSelection.AddItem ts
        Next ts
        TrackSelection.Text = TrackSelection.List(0)
        
        Play.Enabled = True
        Pause.Enabled = True
        FastForward.Enabled = True
        Rewind.Enabled = True
        NextTrack.Enabled = True
        PreviousTrack.Enabled = True
        stpButton.Enabled = True
        CDLoad = True
        SendMCIString "seek cd to 1", True
    End If

    ' Update the track time display
    mciSendString "status cd position", e, Len(e), 0
    Track = CInt(Mid$(e, 1, 2))
    Minute = CInt(Mid$(e, 4, 2))
    Second = CInt(Mid$(e, 7, 2))
    TimeWindow.Text = "[" & Format(Track, "00") & "] " & Format(Minute, "00") _
            & ":" & Format(Second, "00")
    TrackTime.Caption = "Track time: " & TrackLength(Track)
    TrackSelection.Text = TrackSelection.List(Track - 1)
    ' Check if CD is playing
    mciSendString "status cd mode", e, Len(e), 0
    Playing = (Mid$(e, 1, 7) = "playing")
Else
    Eject.Enabled = False
    ' Disable all the controls, clear the display
    If (CDLoad = True) Then
        Play.Enabled = False
        Pause.Enabled = False
        FastForward.Enabled = False
        Rewind.Enabled = False
        NextTrack.Enabled = False
        PreviousTrack.Enabled = False
        stpButton.Enabled = False
        CDLoad = False
        Playing = False
        TrackTime.Caption = ""
        TrackTime.Caption = ""
        TimeWindow.Text = ""
    End If
End If
End Sub
' Stop the CD
Private Sub stpButton_Click()
SendMCIString "stop cd wait", True
Command = "seek cd to " & Track
SendMCIString Command, True
Playing = False
Update
End Sub

Private Sub Timer1_Timer()
 FlashWindow hwnd, 1
Update

End Sub

Private Function fSetVolumeControl(ByVal hmixer As Long, _
    mxc As MIXERCONTROL, ByVal Volume As Long) As Boolean
'
' This function sets the value for a volume control.
'
Dim rc   As Long
Dim mxcd As MIXERCONTROLDETAILS
Dim vol  As MIXERCONTROLDETAILS_UNSIGNED

With mxcd
    .item = 0
    .dwControlID = mxc.dwControlID
    .cbStruct = Len(mxcd)
    .cbDetails = Len(vol)
End With
'
' Allocate a buffer for the control value buffer.
'
hmem = GlobalAlloc(&H40, Len(vol))
mxcd.paDetails = GlobalLock(hmem)
mxcd.cChannels = 1
vol.dwValue = Volume
'
' Copy the data into the control value buffer.
'
Call CopyPtrFromStruct(mxcd.paDetails, vol, Len(vol))
'
' Set the control value.
'
rc = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE)
Call GlobalFree(hmem)

If MMSYSERR_NOERROR = rc Then
    fSetVolumeControl = True
Else
    fSetVolumeControl = False
End If
End Function

Private Sub TrackSelection_Click()
lblTrackSelection.Visible = True
If (CDLoad) Then
        'Set TrackSelection value first
       
        If (Track <= TotalTracks) Then
            If (Playing) Then
                Command = "play cd from " & Val(TrackSelection.Text)
                SendMCIString Command, True
             Else
                Command = "seek cd to " & Val(TrackSelection.Text)
                SendMCIString Command, True
                SendMCIString "play cd", True
                Playing = True
            End If
        End If
        Else
        SendMCIString "seek cd to 1", True
    End If
    Update
End Sub

Private Sub Volume_Change()
lblVolume.Visible = True
Dim lVol As Long
lVol = CLng(Volume.Value) * 2
Call fSetVolumeControl(hmixer, volCtrl, lVol)
End Sub

Private Sub Volume_Scroll()
Dim lVol As Long

lVol = CLng(Volume.Value) * 2
Call fSetVolumeControl(hmixer, volCtrl, lVol)
End Sub