home *** CD-ROM | disk | FTP | other *** search
- VERSION 4.00
- Begin VB.Form PlayerForm
- Caption = "Bitmap Player"
- ClientHeight = 3825
- ClientLeft = 1710
- ClientTop = 1380
- ClientWidth = 5850
- Height = 4515
- Left = 1650
- LinkTopic = "Form1"
- ScaleHeight = 255
- ScaleMode = 3 'Pixel
- ScaleWidth = 390
- Top = 750
- Width = 5970
- Begin VB.TextBox NumFramesText
- Height = 285
- Left = 1560
- TabIndex = 11
- Text = "100"
- Top = 120
- Width = 375
- End
- Begin VB.OptionButton RunType
- Caption = "Looping"
- Height = 255
- Index = 2
- Left = 360
- TabIndex = 9
- Top = 2400
- Width = 1095
- End
- Begin VB.OptionButton RunType
- Caption = "Reversing"
- Height = 255
- Index = 1
- Left = 360
- TabIndex = 8
- Top = 2040
- Width = 1095
- End
- Begin VB.OptionButton RunType
- Caption = "One time"
- Height = 255
- Index = 0
- Left = 360
- TabIndex = 7
- Top = 1680
- Value = -1 'True
- Width = 1095
- End
- Begin VB.TextBox FPSText
- Height = 285
- Left = 1560
- TabIndex = 6
- Text = "20"
- Top = 1080
- Width = 375
- End
- Begin VB.PictureBox MovieImage
- AutoRedraw = -1 'True
- AutoSize = -1 'True
- Height = 375
- Left = 600
- ScaleHeight = 21
- ScaleMode = 3 'Pixel
- ScaleWidth = 21
- TabIndex = 2
- Top = 3480
- Visible = 0 'False
- Width = 375
- End
- Begin VB.CommandButton CmdStart
- Caption = "Start"
- Default = -1 'True
- Enabled = 0 'False
- Height = 375
- Left = 600
- TabIndex = 1
- Top = 3000
- Width = 855
- End
- Begin VB.PictureBox Canvas
- Height = 3810
- Left = 2040
- Picture = "BMPPLAY2.frx":0000
- ScaleHeight = 250
- ScaleMode = 3 'Pixel
- ScaleWidth = 250
- TabIndex = 0
- Top = 0
- Width = 3810
- End
- Begin VB.Label Label2
- Caption = "Frames to load:"
- Height = 255
- Left = 120
- TabIndex = 10
- Top = 120
- Width = 1455
- End
- Begin VB.Label Label1
- Caption = "Frames per second:"
- Height = 255
- Index = 1
- Left = 120
- TabIndex = 5
- Top = 1080
- Width = 1455
- End
- Begin VB.Label NumLabel
- BorderStyle = 1 'Fixed Single
- Caption = "0"
- Height = 255
- Left = 1560
- TabIndex = 4
- Top = 480
- Width = 375
- End
- Begin VB.Label Label1
- Caption = "Frame:"
- Height = 255
- Index = 0
- Left = 120
- TabIndex = 3
- Top = 480
- Width = 615
- End
- Begin MSComDlg.CommonDialog FileDialog
- Left = 0
- Top = 3360
- _Version = 65536
- _ExtentX = 847
- _ExtentY = 847
- _StockProps = 0
- CancelError = -1 'True
- End
- Begin VB.Menu mnuFile
- Caption = "&File"
- Begin VB.Menu mnuFileLoad
- Caption = "&Load..."
- Shortcut = ^L
- End
- Begin VB.Menu mnuFileSaveAs
- Caption = "&Save As..."
- Enabled = 0 'False
- Shortcut = ^A
- End
- Begin VB.Menu mnuFileSep
- Caption = "-"
- End
- Begin VB.Menu mnuFileExit
- Caption = "E&xit"
- End
- End
- Attribute VB_Name = "PlayerForm"
- Attribute VB_Creatable = False
- Attribute VB_Exposed = False
- Option Explicit
- Dim NumImages As Integer
- Dim MaxImage As Integer
- Dim Playing As Boolean
- Dim bytes() As Byte
- Dim hgt As Long
- Dim wid As Long
- ' ************************************************
- ' Load a sequence of images.
- ' ************************************************
- Sub LoadSequence(fname As String)
- Dim status As Long
- Dim fnum As Integer
- Dim num_pal As Integer
- Dim pal(0 To 255) As PALETTEENTRY
- ' Open the file.
- fnum = FreeFile
- Open fname For Binary Access Read As #fnum
- ' Get the image's palette size and palette.
- Get #fnum, , num_pal
- Get #fnum, , pal
- status = ResizePalette(Canvas.Picture.hPal, num_pal)
- status = SetPaletteEntries(Canvas.Picture.hPal, 0, num_pal, pal(0))
- status = RealizePalette(Canvas.hdc)
- ' Get the number of frames, wid, and hgt.
- Get #fnum, , NumImages
- Get #fnum, , wid
- Get #fnum, , hgt
- ' Get the frames' bytes.
- ReDim bytes(1 To wid, 1 To hgt, 1 To NumImages)
- Get #fnum, , bytes
- ' Close the file.
- Close #fnum
- status = SetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
- Canvas.Refresh
- NumLabel.Caption = "0"
- NumFramesText.Text = Format$(NumImages)
- End Sub
- ' ************************************************
- ' Save the images.
- ' ************************************************
- Sub SaveSequence(fname As String)
- Dim status As Long
- Dim fnum As Integer
- Dim num_pal As Integer
- Dim pal(0 To 255) As PALETTEENTRY
- ' Open the file.
- fnum = FreeFile
- Open fname For Binary Access Write As #fnum
- ' Save the images' palette size and palette.
- num_pal = GetPaletteEntries(Canvas.Picture.hPal, 0, 256, pal(0))
- Put #fnum, , num_pal
- Put #fnum, , pal
- ' Save the number of frames, wid, and hgt.
- Put #fnum, , NumImages
- Put #fnum, , wid
- Put #fnum, , hgt
- ' Save the frames' bytes.
- Put #fnum, , bytes
- ' Close the file.
- Close #fnum
- End Sub
- ' ************************************************
- ' Load the images.
- ' ************************************************
- Sub LoadImages(fname As String)
- Dim base As String
- Dim i As Integer
- Dim bm As BITMAP
- Dim status As Long
- ' Get the base file name.
- base = Left$(fname, Len(fname) - 5)
- ' See how many frames the user wants to load.
- If Not IsNumeric(NumFramesText.Text) Then _
- NumFramesText.Text = Format$(10)
- NumImages = CInt(NumFramesText.Text)
- ' Get the first image.
- Canvas.Picture = LoadPicture(base & "0.bmp")
- ' See how big it is.
- status = GetObject(Canvas.Image, BITMAP_SIZE, bm)
- wid = bm.bmWidthBytes
- hgt = bm.bmHeight
- ' Make room for the bitmap bits.
- ReDim bytes(1 To wid, 1 To hgt, 1 To NumImages)
- ' Get the first image's bytes.
- status = GetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
- ' Load the other images.
- On Error GoTo LoadPictureError
- For i = 2 To NumImages
- NumLabel.Caption = Format$(i - 1)
- NumLabel.Refresh
- Canvas.Picture = LoadPicture(base & Format$(i - 1) & ".bmp")
- If i > NumImages Then Exit For
- status = GetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, i))
- Next i
- status = SetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
- Canvas.Refresh
- NumLabel.Caption = "0"
- NumFramesText.Text = Format$(NumImages)
- Exit Sub
- LoadPictureError:
- ' We ran out of images early.
- NumImages = i - 1
- NumFramesText.Text = Format$(NumImages)
- ReDim Preserve bytes(1 To wid, 1 To hgt, 1 To NumImages)
- Resume Next
- End Sub
- ' ***********************************************
- ' Run the animation until Playing is false.
- ' ***********************************************
- Sub PlayImages()
- Const RUN_TYPE_ONE_TIME = 0
- Const RUN_TYPE_BACK_AND_FORTH = 1
- Const RUN_TYPE_LOOPING = 2
- Dim i As Integer
- Dim ms_per_frame As Integer
- Dim next_time As Long
- Dim run_type As Integer
- Dim hbm As Integer
- Dim status As Long
- ' See long it should be between frames.
- If Not IsNumeric(FPSText.Text) Then _
- FPSText.Text = "20"
- ms_per_frame = 1000 / CInt(FPSText.Text)
-
- ' See what kind of run it is (looping, etc.).
- For i = 0 To 2
- If RunType(i).Value Then Exit For
- Next i
- run_type = i
- ' Start the animation.
- hbm = Canvas.Image
- next_time = GetTickCount
- Do While Playing
- For i = 1 To NumImages
- status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1, i))
- Canvas.Refresh
- NumLabel.Caption = Format$(i)
- next_time = next_time + ms_per_frame
- WaitTill next_time
-
- If Not Playing Then Exit Sub
- Next i
-
- ' If this is a one time run, stop.
- If run_type = RUN_TYPE_ONE_TIME Then Exit Do
-
- ' If this is a back and forth run, go back.
- If run_type = RUN_TYPE_BACK_AND_FORTH Then
- For i = NumImages - 2 To 1 Step -1
- status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1, i))
- Canvas.Refresh
- NumLabel.Caption = Format$(i)
- next_time = next_time + ms_per_frame
- WaitTill next_time
-
- If Not Playing Then Exit Sub
- Next i
- End If
- Loop
- End Sub
- ' ************************************************
- ' Start or stop playing.
- ' ************************************************
- Private Sub CmdStart_Click()
- If Playing Then
- Playing = False
- CmdStart.Caption = "Stopped"
- CmdStart.Enabled = False
- Else
- CmdStart.Caption = "Stop"
- Playing = True
- PlayImages
- Playing = False
- CmdStart.Caption = "Start"
- CmdStart.Enabled = True
- End If
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- End
- End Sub
- Private Sub mnuFileExit_Click()
- Unload Me
- End Sub
- ' ***********************************************
- ' Load new image files.
- ' ***********************************************
- Private Sub mnuFileLoad_Click()
- Dim fname As String
- ' Allow the user to pick a file.
- On Error Resume Next
- FileDialog.Filter = "Bitmap files (*_0.BMP)|*_0.BMP|Bitmap sequences (*.SEQ)|*.SEQ"
- FileDialog.FilterIndex = 1
- FileDialog.filename = ""
- FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
- FileDialog.ShowOpen
- If Err.Number = cdlCancel Then
- Exit Sub
- ElseIf Err.Number <> 0 Then
- Beep
- MsgBox "Error selecting file.", , vbExclamation
- Exit Sub
- End If
- On Error GoTo 0
- fname = Trim$(FileDialog.filename)
- FileDialog.InitDir = Left$(fname, Len(fname) _
- - Len(FileDialog.FileTitle) - 1)
- ' Load the pictures.
- WaitStart
- If UCase(Right$(Trim$(fname), 3)) = "BMP" Then
- LoadImages fname
- Else
- LoadSequence fname
- End If
- WaitEnd
- CmdStart.Enabled = True
- mnuFileSaveAs.Enabled = True
- End Sub
- ' ***********************************************
- ' Restore the mouse pointers for the form and all
- ' the picture boxes.
- ' ***********************************************
- Sub WaitEnd()
- MousePointer = vbDefault
- Canvas.MousePointer = vbDefault
- End Sub
- ' ***********************************************
- ' Give the form and all the picture boxes an
- ' hourglass cursor.
- ' ***********************************************
- Sub WaitStart()
- MousePointer = vbHourglass
- Canvas.MousePointer = vbHourglass
- DoEvents
- End Sub
- ' ************************************************
- ' Allow the user to save the sequence.
- ' ************************************************
- Private Sub mnuFileSaveAs_Click()
- Dim fname As String
- ' Allow the user to pick a file.
- On Error Resume Next
- FileDialog.Filter = "Bitmap sequences (*.SEQ)|*.SEQ"
- FileDialog.FilterIndex = 1
- FileDialog.filename = ""
- FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
- FileDialog.ShowSave
- If Err.Number = cdlCancel Then
- Exit Sub
- ElseIf Err.Number <> 0 Then
- Beep
- MsgBox "Error selecting file.", , vbExclamation
- Exit Sub
- End If
- On Error GoTo 0
- fname = Trim$(FileDialog.filename)
- FileDialog.InitDir = Left$(fname, Len(fname) _
- - Len(FileDialog.FileTitle) - 1)
- ' Save the pictures.
- WaitStart
- SaveSequence fname
- WaitEnd
- End Sub
-