2002-12-02 21:08

'use VarPtr to return string from mciSendString, modified by Guidance.
'                                     http://citymap.126.com    2002-12-2
'************************************************************************
'*                                                                      *
'*   RapidQ Windows AVI player by Peter Scheutz Ver 0.1 10 Okt. 1999    *
'*   Freeware - use and improve                                         *
'*   Use "as is" no warrenty                                            *
'*                                                                      *
'*   Includes reusable AviFile Object                                   *
'*   OBS: NO encapsulation - therefore use methods only as shown below  *
'*                                                                      *
'*   Expect errors - this program has not been tested too much.         *
'*                                                                      *
'*   The SetWindowPos is used as a workaround. RQ seems to quit the     *
'*   current SUB when a Form is programmaticly resised.                 *
'*   This limitation may be removed in your/future versions and         *
'*   you can then revert to native RQ methods.                          *
'*                                                                      *
'*   Have Fun                                                           *
'*                                                                      *
'************************************************************************

     $INCLUDE "RapidQ.inc"

     $APPTYPE GUI
     $TYPECHECK ON

     $RESOURCE PLAYBMP AS "PLAY.BMP"
     $RESOURCE STOPBMP AS "STOP.BMP"

     DECLARE FUNCTION mciSendString LIB "winmm.dll" ALIAS "mciSendStringA" (lpstrCommand AS STRING, lpstrReturnString AS LONG, uReturnLength AS LONG, hwndCallback AS LONG) AS LONG
     DECLARE FUNCTION mciGetErrorString LIB "winmm.dll" ALIAS "mciGetErrorStringA" (dwError AS LONG, lpstrBuffer AS LONG, uLength AS LONG) AS LONG
     DECLARE FUNCTION SetWindowPos LIB "user32" ALIAS "SetWindowPos" (hwnd AS LONG, hWndInsertAfter AS LONG,x AS LONG,y AS LONG,cx AS LONG,cy AS LONG,wFlags AS LONG) AS LONG

     CONST HWND_TOPMOST = -1
     CONST SWP_SHOWWINDOW = &H40


     TYPE AviFile EXTENDS QOBJECT
      mvarMediaOpen AS LONG
      CanvasHandle AS LONG
      currentFrame AS LONG
      mvarMediaName AS STRING
      MediaLenght AS LONG
      MediaWidth AS LONG
      MediaHeight AS LONG
      mvarLastError AS STRING


      SUB ParseMediaDimension(mediadim AS STRING)
        ' this sub parses string containing "Xpos Ypos Xlen Ylen" seperated with spaces
       DIM sPos AS LONG
       DIM ePos AS LONG
       DIM x AS LONG
       DIM y AS LONG
       DIM list AS QSTRINGLIST
       list.parse(mediadim," ")
       AviFile.MediaWidth=VAL(list.item(2))
       AviFile.MediaHeight=VAL(list.item(3))
'        ePos=INSTR(,mediadim," ")
'        x = Val(Mid$(mediadim, 1, ePos))

'        sPos = ePos + 1
'        ePos = InStr(sPos, mediadim, " ")
'        y = Val(Mid$(mediadim, sPos, ePos - sPos))

'        sPos = ePos + 1
'        ePos = InStr(sPos, mediadim, " ")
'        AviFile.MediaWidth = Val(Mid$(mediadim, sPos, ePos - sPos))

'        sPos = ePos + 1
'        AviFile.MediaHeight = Val(Mid$(mediadim, sPos, Len(mediadim) - sPos))

      END SUB

      FUNCTION GetMciDescription(McierrNr AS LONG) AS STRING
        ' this function gets a txt description from a MCI error nr.
       DIM Retval AS LONG
       DIM RetString AS STRING  'we don't use this - it ends up on the stack instead
       RetString = SPACE$(128)
       Retval = mciGetErrorString(McierrNr, VARPTR(RetString), 128)
       RetString = LEFT$(retstring,128)'STACK.Str(1)
       IF Retval = True THEN
        AviFile.mvarLastError = RetString
       ELSE
        RetString = ""
       END IF
       AviFile.GetMciDescription = RetString
      END FUNCTION


      SUB MakeMediaClose
        ' stops and closes loaded file - ignores errors call to make sure "MEDIA" alias is closed
       DIM Retval AS INTEGER
       DIM RetString AS STRING
       RetString = SPACE$(128)
       Retval = mciSendString("stop MEDIA", VARPTR(RetString), 128, 0)
       RetString = SPACE$(128)
       Retval = mciSendString("close MEDIA", VARPTR(RetString), 128, 0)
       AviFile.mvarMediaOpen = False
        'showmessage (str$(RetVal))
      END SUB
      SUB MakeMediaOpen
        ' opens file if not already open and toggle the MediaOpen flag
       IF AviFile.mvarMediaOpen = False THEN
        DIM Retval AS INTEGER
        DIM RetString AS STRING
        RetString = SPACE$(128)
        Retval = mciSendString("open " + AviFile.mvarMediaName + " alias MEDIA parent " _
         + STR$(AviFile.CanvasHandle) + " style child", VARPTR(RetString), 128, 0)
        IF Retval = 0 THEN
         AviFile.mvarMediaOpen = True
        ELSE
                'showmessage(AviFile.GetMciDescription(retVal))
        END IF

       END IF

      END SUB
      FUNCTION GetPos AS LONG
        ' gets the current frame position of MEDIA (avi file)
       IF AviFile.mvarMediaOpen = True THEN
        DIM Retval AS INTEGER
        DIM RetString AS STRING
        DIM nowPos AS STRING
        RetString = SPACE$(128)
        Retval = mciSendString("status MEDIA position", VARPTR(RetString), 128, 0)
        nowPos = LEFT$(retstring,128)'STACK.Str(1)
        IF Retval = 0 THEN
         AviFile.currentFrame = VAL(nowPos)
        END IF
       END IF
       AviFile.GetPos = AviFile.currentFrame
      END FUNCTION
      FUNCTION PlayMedia AS LONG
        ' plays video from current frame
       AviFile.MakeMediaOpen
       DIM Retval AS INTEGER
       DIM RetString AS STRING
       RetString = SPACE$(128)
       Retval = mciSendString("play MEDIA from " + STR$(AviFile.currentFrame) _
        , VARPTR(RetString) , 128, 0)

       IF Retval = 0 THEN
        AviFile.PlayMedia = True
       ELSE
            'showmessage(AviFile.GetMciDescription(retVal))
        AviFile.PlayMedia = False
       END IF

      END FUNCTION
      SUB StopMedia
        ' stops (pauses) video
       IF AviFile.mvarMediaOpen = True THEN
        AviFile.GetPos
        DIM Retval AS INTEGER
        DIM RetString AS STRING
        RetString = SPACE$(128)
        Retval = mciSendString("stop MEDIA", VARPTR(RetString), 128, 0)
       END IF
      END SUB
      SUB SetMediaName(mName AS STRING)
        ' use this to set the name of the video file, then call init
       AviFile.mvarMediaName = mName
       AviFile.currentFrame = 0
      END SUB

      SUB ShowStill
        ' show a certan frame number of the file - dont call this call "Setstill" instead
       AviFile.MakeMediaOpen
       DIM Retval AS INTEGER
       DIM RetString AS STRING
       RetString = SPACE$(128)
       Retval = mciSendString("play MEDIA from " + STR$(AviFile.currentFrame) + " to " _
        + STR$(AviFile.currentFrame), VARPTR(RetString), 128, 0)

       IF Retval <> 0 THEN
            'showmessage(AviFile.GetMciDescription(retVal))
       END IF
      END SUB
      SUB Setstill(frame AS LONG)
        ' call this to show a certain frame
       IF AviFile.mvarMediaOpen = True THEN
        IF frame < 0 THEN
         frame = 0
        END IF
        IF frame > AviFile.MediaLenght THEN
         frame = AviFile.MediaLenght
        END IF
        AviFile.currentFrame = frame
        AviFile.ShowStill
       END IF
      END SUB
      FUNCTION Init AS LONG
        ' gets the size and number of frames of the avi file - returns False if error
       IF AviFile.mvarMediaName = "" THEN
        AviFile.Init = False
        EXIT FUNCTION
       END IF
       AviFile.Init = True
       AviFile.MakeMediaClose
       DIM Retval AS INTEGER
       DIM RetString AS STRING
       DIM errDescript AS STRING
       RetString = SPACE$(128)
       Retval = mciSendString("open " + AviFile.mvarMediaName + " alias MEDIA" _
        , VARPTR(RetString), 128, 0)
       IF Retval <> 0 THEN
        AviFile.Init = False
        EXIT FUNCTION
            'showmessage (AviFile.GetMciDescription(retval))
       END IF
       RetString = SPACE$(128)
       Retval = mciSendString("status MEDIA length", VARPTR(RetString), 128, 0)
       RetString = LEFT$(retstring,128)'STACK.Str$(1)
       IF Retval = 0 THEN

        AviFile.MediaLenght = VAL(RetString)
       ELSE
        AviFile.MediaLenght = -1 'invalid
        AviFile.Init = False
       END IF

       RetString = SPACE$(128)
       Retval = mciSendString("where MEDIA source", VARPTR(RetString), 128, 0)
'        RetString = STACK.Str(1)
'        showmessage(RetString)
       AviFile.ParseMediaDimension (RetString)

       RetString = SPACE$(128)
       Retval = mciSendString("close MEDIA", VARPTR(RetString), 128, 0)
       IF Retval <> 0 THEN
        AviFile.Init = False
            'showmessage (str$(RetVal)+"M " +AviFile.GetMciDescription(retval))
       END IF

      END FUNCTION

      CONSTRUCTOR
       mvarMediaName = ""
       MediaLenght = -1
       mvarMediaOpen = False
      END CONSTRUCTOR

     END TYPE

'*******************Test AviFile component*******************



     DIM Video AS AviFile
     DIM font AS QFONT
     font.Name = "Arial"
     font.Size = 12
     font.AddStyles (fsBold)

     DECLARE SUB PlayClick
     DECLARE SUB StopClick
     DECLARE SUB FormReSize
     DECLARE SUB TrackBarChange
     DECLARE SUB FormClose (Action AS INTEGER)
     DECLARE SUB FormOnKeyDown (Key AS WORD, Shift AS INTEGER)

     CREATE Form AS QFORM
      CAPTION = "Rapid Q Avi player"
      BorderStyle = bsToolWindow
      OnKeyDown = FormOnKeyDown
      OnResize = FormReSize
      OnClose = FormClose

      CREATE NavPanel AS QPANEL
       Height = 32
       BevelOuter = bvNone

       CREATE TrackBar AS QTRACKBAR
        Left = 70
        Height = 18
        Top = 8
        TickStyle = tsNone
        TickMarks = tmBoth
        LineSize = 0
        OnChange = TrackBarChange
       END CREATE

       CREATE PlayBtn AS QCOOLBTN
        BMPHandle = PLAYBMP
        Flat = True
        Left = 8: Top = 4: Height = 26: Width = 26
        CAPTION = ""
        OnClick = PlayClick
        font = font
        GroupIndex = 2
       END CREATE

       CREATE StopBtn AS QCOOLBTN
        BMPHandle = STOPBMP
        Flat = True
        Left = 8 + 26: Top = 4: Height = 26: Width = 26
        CAPTION = ""
        OnClick = StopClick
        font = font
        GroupIndex = 2
       END CREATE
      END CREATE
     END CREATE


' this timer is called when the avi is playing to show frame progress with trackbar
     DIM PosTimer AS QTIMER

     SUB PostimerOnTimer
      DIM Retval AS SHORT
      Retval = Video.GetPos
      TrackBar.Position = Retval
      DOEVENTS
      IF Retval = Video.MediaLenght THEN
       StopClick
       StopBtn.Down = True
        'PosTimer.Enabled=False
      END IF
     END SUB

     PosTimer.Enabled = False
     PosTimer.Interval = 1000
     PosTimer.OnTimer = PostimerOnTimer



     DIM MainMenu AS QMAINMENU
     DIM File AS QMENUITEM
     DIM Edit AS QMENUITEM
     DIM Search AS QMENUITEM
     DIM OPEN AS QMENUITEM
     DIM Break1 AS QMENUITEM
     DIM ExitItem AS QMENUITEM

     DIM OpenDialog AS QOPENDIALOG
     OpenDialog.Filter = "Video for Windows|*.AVI|"
     OpenDialog.CAPTION= "Choose Avi file to open"

     SUB FormClose(Action AS INTEGER)
    'IF MessageDlg("Really close this form?", mtWarning, mbYes OR mbNo, 0) = mrNo THEN
    '  Action = caNone
    'else
' close video befor exiting
      Video.MakeMediaClose
    'END IF
     END SUB

     SUB ExitClick
      Form.CLOSE
     END SUB
     SUB FileClick
    ' stop video if playing, befor opening open dialog
      StopClick
      StopBtn.Down = True
     END SUB
     SUB OpenClick

      IF OpenDialog.EXECUTE THEN
       Form.Cursor = crHourGlass
       Video.MakeMediaClose
       Video.SetMediaName OpenDialog.FileName
       Form.CAPTION = OpenDialog.FileName

        ' init AviFile object
       IF Video.Init = False THEN
        Video.SetMediaName ""
        Form.CAPTION = "Can't load: " + Form.CAPTION
        Form.Cursor = crDefault
        EXIT SUB
       END IF

       TrackBar.Max = Video.MediaLenght
       TrackBar.Position = 0

        ' I'd like to have all this stuff in a sub, but strange things happen
        ' It sizes the form to the size of the video
        ' and shows the first frame
       DIM BorderWidth AS LONG
       DIM BorderHeight AS LONG
       DIM NavHeight AS LONG
       DIM FormCenterX AS LONG
       DIM FormCenterY AS LONG
       DIM NewX AS LONG
       DIM NewY AS LONG
       FormCenterX = Form.Left + Form.Width / 2
       FormCenterY = Form.Top + Form.Height / 2

       NavHeight = NavPanel.Height
       BorderWidth = Form.Width - Form.ClientWidth
       BorderHeight = Form.Height - Form.ClientHeight
       NewX = FormCenterX - (Video.MediaWidth + BorderWidth) / 2
       NewY = FormCenterY - (Video.MediaHeight + NavHeight + BorderHeight) / 2
       IF NewX < 0 THEN
        NewX = 0
       END IF
       IF NewY < 0 THEN
        NewY = 0
       END IF
       Video.CanvasHandle = Form.Handle
       Video.ShowStill
       SetWindowPos Form.Handle, 0, NewX, NewY, Video.MediaWidth + BorderWidth, Video.MediaHeight + NavHeight + BorderHeight, SWP_SHOWWINDOW
'        form.clientwidth=Video.MediaWidth + BorderWidth
'        form.clientheight=Video.MediaHeight + NavHeight + BorderHeight
      END IF
     END SUB

     OPEN.CAPTION = "&Open"
     OPEN.OnClick = OpenClick

     Break1.CAPTION = "-"
     ExitItem.CAPTION = "E&xit"
     ExitItem.OnClick = ExitClick
     File.CAPTION = "&File"
     File.OnClick = FileClick


     File.AddItems OPEN,Break1,ExitItem

     MainMenu.PARENT = Form
     MainMenu.AddItems File


     SUB PlayClick
      IF Video.PlayMedia = True THEN
       PosTimer.Enabled = True
      ELSE
       StopBtn.Down = True
      END IF
     END SUB

     SUB StopClick
      PosTimer.Enabled = False
      Video.StopMedia
     END SUB

     SUB TrackBarChange
      Video.Setstill TrackBar.Position
     END SUB

     SUB FormReSize
      NavPanel.Top = Form.ClientHeight - NavPanel.Height
      NavPanel.Width = Form.ClientWidth
      TrackBar.Width = NavPanel.Width - TrackBar.Left - 10
     END SUB

     Form.center
     Form.SHOWMODAL

2002-12-02 21:08