home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH5 / SRC / BMPPLAY2.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-08  |  13.1 KB  |  422 lines

  1. VERSION 4.00
  2. Begin VB.Form PlayerForm 
  3.    Caption         =   "Bitmap Player"
  4.    ClientHeight    =   3825
  5.    ClientLeft      =   1710
  6.    ClientTop       =   1380
  7.    ClientWidth     =   5850
  8.    Height          =   4515
  9.    Left            =   1650
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   255
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   390
  14.    Top             =   750
  15.    Width           =   5970
  16.    Begin VB.TextBox NumFramesText 
  17.       Height          =   285
  18.       Left            =   1560
  19.       TabIndex        =   11
  20.       Text            =   "100"
  21.       Top             =   120
  22.       Width           =   375
  23.    End
  24.    Begin VB.OptionButton RunType 
  25.       Caption         =   "Looping"
  26.       Height          =   255
  27.       Index           =   2
  28.       Left            =   360
  29.       TabIndex        =   9
  30.       Top             =   2400
  31.       Width           =   1095
  32.    End
  33.    Begin VB.OptionButton RunType 
  34.       Caption         =   "Reversing"
  35.       Height          =   255
  36.       Index           =   1
  37.       Left            =   360
  38.       TabIndex        =   8
  39.       Top             =   2040
  40.       Width           =   1095
  41.    End
  42.    Begin VB.OptionButton RunType 
  43.       Caption         =   "One time"
  44.       Height          =   255
  45.       Index           =   0
  46.       Left            =   360
  47.       TabIndex        =   7
  48.       Top             =   1680
  49.       Value           =   -1  'True
  50.       Width           =   1095
  51.    End
  52.    Begin VB.TextBox FPSText 
  53.       Height          =   285
  54.       Left            =   1560
  55.       TabIndex        =   6
  56.       Text            =   "20"
  57.       Top             =   1080
  58.       Width           =   375
  59.    End
  60.    Begin VB.PictureBox MovieImage 
  61.       AutoRedraw      =   -1  'True
  62.       AutoSize        =   -1  'True
  63.       Height          =   375
  64.       Left            =   600
  65.       ScaleHeight     =   21
  66.       ScaleMode       =   3  'Pixel
  67.       ScaleWidth      =   21
  68.       TabIndex        =   2
  69.       Top             =   3480
  70.       Visible         =   0   'False
  71.       Width           =   375
  72.    End
  73.    Begin VB.CommandButton CmdStart 
  74.       Caption         =   "Start"
  75.       Default         =   -1  'True
  76.       Enabled         =   0   'False
  77.       Height          =   375
  78.       Left            =   600
  79.       TabIndex        =   1
  80.       Top             =   3000
  81.       Width           =   855
  82.    End
  83.    Begin VB.PictureBox Canvas 
  84.       Height          =   3810
  85.       Left            =   2040
  86.       Picture         =   "BMPPLAY2.frx":0000
  87.       ScaleHeight     =   250
  88.       ScaleMode       =   3  'Pixel
  89.       ScaleWidth      =   250
  90.       TabIndex        =   0
  91.       Top             =   0
  92.       Width           =   3810
  93.    End
  94.    Begin VB.Label Label2 
  95.       Caption         =   "Frames to load:"
  96.       Height          =   255
  97.       Left            =   120
  98.       TabIndex        =   10
  99.       Top             =   120
  100.       Width           =   1455
  101.    End
  102.    Begin VB.Label Label1 
  103.       Caption         =   "Frames per second:"
  104.       Height          =   255
  105.       Index           =   1
  106.       Left            =   120
  107.       TabIndex        =   5
  108.       Top             =   1080
  109.       Width           =   1455
  110.    End
  111.    Begin VB.Label NumLabel 
  112.       BorderStyle     =   1  'Fixed Single
  113.       Caption         =   "0"
  114.       Height          =   255
  115.       Left            =   1560
  116.       TabIndex        =   4
  117.       Top             =   480
  118.       Width           =   375
  119.    End
  120.    Begin VB.Label Label1 
  121.       Caption         =   "Frame:"
  122.       Height          =   255
  123.       Index           =   0
  124.       Left            =   120
  125.       TabIndex        =   3
  126.       Top             =   480
  127.       Width           =   615
  128.    End
  129.    Begin MSComDlg.CommonDialog FileDialog 
  130.       Left            =   0
  131.       Top             =   3360
  132.       _Version        =   65536
  133.       _ExtentX        =   847
  134.       _ExtentY        =   847
  135.       _StockProps     =   0
  136.       CancelError     =   -1  'True
  137.    End
  138.    Begin VB.Menu mnuFile 
  139.       Caption         =   "&File"
  140.       Begin VB.Menu mnuFileLoad 
  141.          Caption         =   "&Load..."
  142.          Shortcut        =   ^L
  143.       End
  144.       Begin VB.Menu mnuFileSaveAs 
  145.          Caption         =   "&Save As..."
  146.          Enabled         =   0   'False
  147.          Shortcut        =   ^A
  148.       End
  149.       Begin VB.Menu mnuFileSep 
  150.          Caption         =   "-"
  151.       End
  152.       Begin VB.Menu mnuFileExit 
  153.          Caption         =   "E&xit"
  154.       End
  155.    End
  156. Attribute VB_Name = "PlayerForm"
  157. Attribute VB_Creatable = False
  158. Attribute VB_Exposed = False
  159. Option Explicit
  160. Dim NumImages As Integer
  161. Dim MaxImage As Integer
  162. Dim Playing As Boolean
  163. Dim bytes() As Byte
  164. Dim hgt As Long
  165. Dim wid As Long
  166. ' ************************************************
  167. ' Load a sequence of images.
  168. ' ************************************************
  169. Sub LoadSequence(fname As String)
  170. Dim status As Long
  171. Dim fnum As Integer
  172. Dim num_pal As Integer
  173. Dim pal(0 To 255) As PALETTEENTRY
  174.     ' Open the file.
  175.     fnum = FreeFile
  176.     Open fname For Binary Access Read As #fnum
  177.     ' Get the image's palette size and palette.
  178.     Get #fnum, , num_pal
  179.     Get #fnum, , pal
  180.     status = ResizePalette(Canvas.Picture.hPal, num_pal)
  181.     status = SetPaletteEntries(Canvas.Picture.hPal, 0, num_pal, pal(0))
  182.     status = RealizePalette(Canvas.hdc)
  183.     ' Get the number of frames, wid, and hgt.
  184.     Get #fnum, , NumImages
  185.     Get #fnum, , wid
  186.     Get #fnum, , hgt
  187.     ' Get the frames' bytes.
  188.     ReDim bytes(1 To wid, 1 To hgt, 1 To NumImages)
  189.     Get #fnum, , bytes
  190.     ' Close the file.
  191.     Close #fnum
  192.     status = SetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
  193.     Canvas.Refresh
  194.     NumLabel.Caption = "0"
  195.     NumFramesText.Text = Format$(NumImages)
  196. End Sub
  197. ' ************************************************
  198. ' Save the images.
  199. ' ************************************************
  200. Sub SaveSequence(fname As String)
  201. Dim status As Long
  202. Dim fnum As Integer
  203. Dim num_pal As Integer
  204. Dim pal(0 To 255) As PALETTEENTRY
  205.     ' Open the file.
  206.     fnum = FreeFile
  207.     Open fname For Binary Access Write As #fnum
  208.     ' Save the images' palette size and palette.
  209.     num_pal = GetPaletteEntries(Canvas.Picture.hPal, 0, 256, pal(0))
  210.     Put #fnum, , num_pal
  211.     Put #fnum, , pal
  212.     ' Save the number of frames, wid, and hgt.
  213.     Put #fnum, , NumImages
  214.     Put #fnum, , wid
  215.     Put #fnum, , hgt
  216.     ' Save the frames' bytes.
  217.     Put #fnum, , bytes
  218.     ' Close the file.
  219.     Close #fnum
  220. End Sub
  221. ' ************************************************
  222. ' Load the images.
  223. ' ************************************************
  224. Sub LoadImages(fname As String)
  225. Dim base As String
  226. Dim i As Integer
  227. Dim bm As BITMAP
  228. Dim status As Long
  229.     ' Get the base file name.
  230.     base = Left$(fname, Len(fname) - 5)
  231.     ' See how many frames the user wants to load.
  232.     If Not IsNumeric(NumFramesText.Text) Then _
  233.         NumFramesText.Text = Format$(10)
  234.     NumImages = CInt(NumFramesText.Text)
  235.     ' Get the first image.
  236.     Canvas.Picture = LoadPicture(base & "0.bmp")
  237.     ' See how big it is.
  238.     status = GetObject(Canvas.Image, BITMAP_SIZE, bm)
  239.     wid = bm.bmWidthBytes
  240.     hgt = bm.bmHeight
  241.     ' Make room for the bitmap bits.
  242.     ReDim bytes(1 To wid, 1 To hgt, 1 To NumImages)
  243.     ' Get the first image's bytes.
  244.     status = GetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
  245.     ' Load the other images.
  246.     On Error GoTo LoadPictureError
  247.     For i = 2 To NumImages
  248.         NumLabel.Caption = Format$(i - 1)
  249.         NumLabel.Refresh
  250.         Canvas.Picture = LoadPicture(base & Format$(i - 1) & ".bmp")
  251.         If i > NumImages Then Exit For
  252.         status = GetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, i))
  253.     Next i
  254.     status = SetBitmapBits(Canvas.Image, wid * hgt, bytes(1, 1, 1))
  255.     Canvas.Refresh
  256.     NumLabel.Caption = "0"
  257.     NumFramesText.Text = Format$(NumImages)
  258.     Exit Sub
  259. LoadPictureError:
  260.     ' We ran out of images early.
  261.     NumImages = i - 1
  262.     NumFramesText.Text = Format$(NumImages)
  263.     ReDim Preserve bytes(1 To wid, 1 To hgt, 1 To NumImages)
  264.     Resume Next
  265. End Sub
  266. ' ***********************************************
  267. ' Run the animation until Playing is false.
  268. ' ***********************************************
  269. Sub PlayImages()
  270. Const RUN_TYPE_ONE_TIME = 0
  271. Const RUN_TYPE_BACK_AND_FORTH = 1
  272. Const RUN_TYPE_LOOPING = 2
  273. Dim i As Integer
  274. Dim ms_per_frame As Integer
  275. Dim next_time As Long
  276. Dim run_type As Integer
  277. Dim hbm As Integer
  278. Dim status As Long
  279.     ' See long it should be between frames.
  280.     If Not IsNumeric(FPSText.Text) Then _
  281.         FPSText.Text = "20"
  282.     ms_per_frame = 1000 / CInt(FPSText.Text)
  283.                 
  284.     ' See what kind of run it is (looping, etc.).
  285.     For i = 0 To 2
  286.         If RunType(i).Value Then Exit For
  287.     Next i
  288.     run_type = i
  289.     ' Start the animation.
  290.     hbm = Canvas.Image
  291.     next_time = GetTickCount
  292.     Do While Playing
  293.         For i = 1 To NumImages
  294.             status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1, i))
  295.             Canvas.Refresh
  296.             NumLabel.Caption = Format$(i)
  297.             next_time = next_time + ms_per_frame
  298.             WaitTill next_time
  299.             
  300.             If Not Playing Then Exit Sub
  301.         Next i
  302.             
  303.         ' If this is a one time run, stop.
  304.         If run_type = RUN_TYPE_ONE_TIME Then Exit Do
  305.         
  306.         ' If this is a back and forth run, go back.
  307.         If run_type = RUN_TYPE_BACK_AND_FORTH Then
  308.             For i = NumImages - 2 To 1 Step -1
  309.                 status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1, i))
  310.                 Canvas.Refresh
  311.                 NumLabel.Caption = Format$(i)
  312.                 next_time = next_time + ms_per_frame
  313.                 WaitTill next_time
  314.                 
  315.                 If Not Playing Then Exit Sub
  316.             Next i
  317.         End If
  318.     Loop
  319. End Sub
  320. ' ************************************************
  321. ' Start or stop playing.
  322. ' ************************************************
  323. Private Sub CmdStart_Click()
  324.     If Playing Then
  325.         Playing = False
  326.         CmdStart.Caption = "Stopped"
  327.         CmdStart.Enabled = False
  328.     Else
  329.         CmdStart.Caption = "Stop"
  330.         Playing = True
  331.         PlayImages
  332.         Playing = False
  333.         CmdStart.Caption = "Start"
  334.         CmdStart.Enabled = True
  335.     End If
  336. End Sub
  337. Private Sub Form_Unload(Cancel As Integer)
  338.     End
  339. End Sub
  340. Private Sub mnuFileExit_Click()
  341.     Unload Me
  342. End Sub
  343. ' ***********************************************
  344. ' Load new image files.
  345. ' ***********************************************
  346. Private Sub mnuFileLoad_Click()
  347. Dim fname As String
  348.     ' Allow the user to pick a file.
  349.     On Error Resume Next
  350.     FileDialog.Filter = "Bitmap files (*_0.BMP)|*_0.BMP|Bitmap sequences (*.SEQ)|*.SEQ"
  351.     FileDialog.FilterIndex = 1
  352.     FileDialog.filename = ""
  353.     FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  354.     FileDialog.ShowOpen
  355.     If Err.Number = cdlCancel Then
  356.         Exit Sub
  357.     ElseIf Err.Number <> 0 Then
  358.         Beep
  359.         MsgBox "Error selecting file.", , vbExclamation
  360.         Exit Sub
  361.     End If
  362.     On Error GoTo 0
  363.     fname = Trim$(FileDialog.filename)
  364.     FileDialog.InitDir = Left$(fname, Len(fname) _
  365.         - Len(FileDialog.FileTitle) - 1)
  366.     ' Load the pictures.
  367.     WaitStart
  368.     If UCase(Right$(Trim$(fname), 3)) = "BMP" Then
  369.         LoadImages fname
  370.     Else
  371.         LoadSequence fname
  372.     End If
  373.     WaitEnd
  374.     CmdStart.Enabled = True
  375.     mnuFileSaveAs.Enabled = True
  376. End Sub
  377. ' ***********************************************
  378. ' Restore the mouse pointers for the form and all
  379. ' the picture boxes.
  380. ' ***********************************************
  381. Sub WaitEnd()
  382.     MousePointer = vbDefault
  383.     Canvas.MousePointer = vbDefault
  384. End Sub
  385. ' ***********************************************
  386. ' Give the form and all the picture boxes an
  387. ' hourglass cursor.
  388. ' ***********************************************
  389. Sub WaitStart()
  390.     MousePointer = vbHourglass
  391.     Canvas.MousePointer = vbHourglass
  392.     DoEvents
  393. End Sub
  394. ' ************************************************
  395. ' Allow the user to save the sequence.
  396. ' ************************************************
  397. Private Sub mnuFileSaveAs_Click()
  398. Dim fname As String
  399.     ' Allow the user to pick a file.
  400.     On Error Resume Next
  401.     FileDialog.Filter = "Bitmap sequences (*.SEQ)|*.SEQ"
  402.     FileDialog.FilterIndex = 1
  403.     FileDialog.filename = ""
  404.     FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  405.     FileDialog.ShowSave
  406.     If Err.Number = cdlCancel Then
  407.         Exit Sub
  408.     ElseIf Err.Number <> 0 Then
  409.         Beep
  410.         MsgBox "Error selecting file.", , vbExclamation
  411.         Exit Sub
  412.     End If
  413.     On Error GoTo 0
  414.     fname = Trim$(FileDialog.filename)
  415.     FileDialog.InitDir = Left$(fname, Len(fname) _
  416.         - Len(FileDialog.FileTitle) - 1)
  417.     ' Save the pictures.
  418.     WaitStart
  419.     SaveSequence fname
  420.     WaitEnd
  421. End Sub
  422.