2013-08-20 12:34

'=======================================================
' Type Objet
' Classe QCdaudio
'=======================================================
     $IFNDEF TRUE
      $DEFINE True 1
     $ENDIF

     $IFNDEF FALSE
      $DEFINE False 0
     $ENDIF

     $IFNDEF boolean
      $DEFINE boolean INTEGER
     $ENDIF

     CONST CD_CLOSE=0
     CONST CD_PLAY=1
     CONST CD_PAUSE=2
     CONST CD_STOP=3
     $IFNDEF __WIN32API				   'windows 32 definitions
      DECLARE FUNCTION mciSendCdaudio LIB "winmm.dll" ALIAS "mciSendStringA" (lpstrCommand AS STRING, lpstrReturnString AS LONG, uReturnLength AS LONG, hwndCallback AS LONG) AS LONG
      DECLARE FUNCTION mciGetErrorCdaudio LIB "winmm.dll" ALIAS "mciGetErrorStringA" (dwError AS LONG,Byref lpstrBuffer AS STRING,uLength AS LONG) AS LONG
      DECLARE SUB event_change(track AS INTEGER,time AS STRING)
     $ENDIF

     TYPE Qcdaudio EXTENDS QOBJECT
  '================================
  ' champs et proprietés
  '================================
      TIMER AS QTIMER
      Time AS STRING
      TrackTime AS STRING
      TrackNumber AS INTEGER
      TimePosition AS STRING
      Position AS LONG
      State AS INTEGER
      AudioOpen AS boolean
      Present AS boolean
      ERROR AS STRING
      CurrentTrack AS INTEGER PROPERTY SET SetCurrentTrack
      OnChange AS EVENT(event_change)


  '====================================
  ' proprieté position track
  '====================================
      PROPERTY SET SetCurrentTrack(track AS INTEGER)
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        IF track<1 THEN
         Qcdaudio.CurrentTrack=1
        ELSE
         IF track>Qcdaudio.TrackNumber THEN
          Qcdaudio.CurrentTrack=Qcdaudio.TrackNumber
         ELSE
          Qcdaudio.CurrentTrack=track
         END IF
        END IF
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("seek cdaudio to "+STR$(Qcdaudio.CurrentTrack),VARPTR(RetString),128,0)
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("set cdaudio time format tmsf",VARPTR(RetString),128,0)
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("status cdaudio length track "+STR$(Qcdaudio.CurrentTrack),VARPTR(RetString),128,0)
        IF Retval=False THEN Qcdaudio.TrackTime=RTRIM$(RetString)
       END IF
      END PROPERTY

PRIVATE:

  '========================================
  ' Méthode retourne le texte de l'erreur
  '========================================
      FUNCTION GetMciDescription(McierrNr AS LONG) AS STRING
       DIM Retval AS LONG
       DIM RetString AS STRING

       RetString=SPACE$(200)
       Retval=mciGetErrorCdaudio(McierrNr,RetString,200)
       IF Retval THEN
        Qcdaudio.GetMciDescription=RTRIM$(RetString)
       ELSE
        Qcdaudio.GetMciDescription=""
       END IF
      END FUNCTION

  '====================================
  ' méthode lecture position track
  '====================================
      FUNCTION GetTrack AS INTEGER
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("status cdaudio current track"+,VARPTR(RetString),128,0)
        IF Retval=False THEN Qcdaudio.GetTrack=VAL(RetString)
       END IF
      END FUNCTION

  '====================================
  ' méthode lecture position temps cd
  '====================================
      FUNCTION GetTimePosition AS STRING
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("status cdaudio position"+,VARPTR(RetString),128,0)
        IF Retval=False THEN Qcdaudio.GetTimePosition=RTRIM$(RetString)
       END IF
      END FUNCTION

  '====================================
  ' méthode lecture position ms cd
  '====================================
      FUNCTION GetPosition AS LONG
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("set cdaudio time format ms",VARPTR(RetString),128,0)
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("status cdaudio position"+,VARPTR(RetString),128,0)
        IF Retval=False THEN Qcdaudio.GetPosition=VAL(RetString)
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("set cdaudio time format tmsf",VARPTR(RetString),128,0)
       END IF
      END FUNCTION

  '====================================
  ' méthode lecture mode cd
  '====================================
      FUNCTION GetMode AS INTEGER
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("status cdaudio mode",VARPTR(RetString),128,0)
        IF INSTR(RetString,"stopped")>0 THEN Qcdaudio.GetMode=CD_STOP
        IF INSTR(RetString,"playing")>0 THEN Qcdaudio.GetMode=CD_PLAY
        IF INSTR(RetString,"paused")>0 THEN Qcdaudio.GetMode=CD_PAUSE
       END IF
      END FUNCTION

PUBLIC:

  '=================================
  ' méthode fermeture media cd
  '=================================
      SUB CLOSE
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       Qcdaudio.TIMER.enabled=False
       RetString=SPACE$(128)
       Retval=mciSendCdaudio("stop cdaudio",VARPTR(RetString),128,0)
       RetString=SPACE$(128)
       Retval=mciSendCdaudio("close cdaudio",VARPTR(RetString),128,0)
       Qcdaudio.AudioOpen=False
       Qcdaudio.Time=""
       Qcdaudio.TrackTime=""
       Qcdaudio.TimePosition=""
       Qcdaudio.Position=0
       Qcdaudio.TrackNumber=0
       Qcdaudio.CurrentTrack=0
       Qcdaudio.State=CD_CLOSE
      END SUB

  '====================================
  ' méthode ouverture cd
  '====================================
      FUNCTION OPEN AS boolean
       DIM Retval AS INTEGER
       DIM RetString AS STRING
       DIM FlagOpen AS boolean

       Qcdaudio.CLOSE
       RetString=SPACE$(128)
       Retval=mciSendCdaudio("open cdaudio",VARPTR(RetString),128,0)
       IF Retval=False THEN
        RetString=SPACE$(19)
        Retval=mciSendCdaudio("status cdaudio media present",VARPTR(RetString),19,0)
        IF INSTR(RetString,"true")>0 THEN
         Qcdaudio.Present=True
         RetString=SPACE$(128)
         Retval=mciSendCdaudio("status cdaudio number of tracks",VARPTR(RetString),128,0)
         IF Retval=False THEN
          Qcdaudio.TrackNumber=VAL(RetString)
          RetString=SPACE$(128)
          Retval=mciSendCdaudio("set cdaudio time format tmsf",VARPTR(RetString),128,0)
          RetString=SPACE$(128)
          Retval=mciSendCdaudio("status cdaudio length",VARPTR(RetString),128,0)
          IF Retval=False THEN
           Qcdaudio.Time=RTRIM$(RetString)
           Qcdaudio.State=CD_STOP
           Qcdaudio.CurrentTrack=1
           Qcdaudio.AudioOpen=True
           Qcdaudio.OPEN=True
           FlagOpen=True
          END IF
         END IF
        END IF
       ELSE
        Qcdaudio.ERROR=Qcdaudio.GetMciDescription(Retval)
       END IF
       IF FlagOpen=False THEN Qcdaudio.CLOSE
      END FUNCTION

  '==================================
  ' méthode lecture cdaudio
  '==================================
      SUB Play
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        Qcdaudio.TIMER.enabled=True
        RetString = SPACE$(128)
        IF Qcdaudio.State=CD_PAUSE THEN
         Retval=mciSendCdaudio("play cdaudio from "+Qcdaudio.TimePosition,VARPTR(RetString),128,0)
        ELSE
         Retval=mciSendCdaudio("play cdaudio from "+STR$(Qcdaudio.CurrentTrack),VARPTR(RetString),128,0)
        END IF
        IF Retval=False THEN Qcdaudio.State=CD_PLAY
       END IF
      END SUB

  '==================================
  ' méthode arret lecture cd
  '==================================
      SUB Stop
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("stop cdaudio",VARPTR(RetString),128,0)
        IF Retval=False THEN
         Qcdaudio.TIMER.enabled=False
         Qcdaudio.State=CD_STOP
         Qcdaudio.CurrentTrack=1
         RetString=SPACE$(128)
         Retval=mciSendCdaudio("seek cdaudio to start",VARPTR(RetString),128,0)
        END IF
       END IF
      END SUB

  '==================================
  ' méthode pause lecture cd
  '==================================
      SUB Pause
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       IF Qcdaudio.AudioOpen=true AND Qcdaudio.State=CD_PLAY THEN
        RetString=SPACE$(128)
        Retval=mciSendCdaudio("pause cdaudio",VARPTR(RetString),128,0)
        IF Retval=False THEN
         Qcdaudio.State=CD_PAUSE
         Qcdaudio.TIMER.enabled=False
         Qcdaudio.CurrentTrack=Qcdaudio.GetTrack
         Qcdaudio.TimePosition=Qcdaudio.GetTimePosition
        END IF
       END IF
      END SUB

  '====================================
  ' méthode ejection cd
  '====================================
      SUB Eject
       DIM Retval AS INTEGER
       DIM RetString AS STRING

       Qcdaudio.stop
       Qcdaudio.CLOSE
       RetString=SPACE$(128)
       Retval=mciSendCdaudio("set cdaudio door open"+,VARPTR(RetString),128,0)
       Qcdaudio.Present=False
      END SUB

  '===============================================
  ' évenement changementposition du cd
  '===============================================
      EVENT TIMER.OnTimer
       Qcdaudio.currentTrack=Qcdaudio.GetTrack
       Qcdaudio.TimePosition=Qcdaudio.GetTimePosition
       Qcdaudio.State=Qcdaudio.GetMode
       IF Qcdaudio.State=CD_STOP THEN Qcdaudio.Stop
       CALLFUNC(Qcdaudio.OnChange,Qcdaudio.currentTrack,Qcdaudio.TimePosition)
      END EVENT

      CONSTRUCTOR
       State=CD_CLOSE
       TIMER.interval=1000
       TIMER.enabled=False
      END CONSTRUCTOR
     END TYPE

2013-08-20 12:34