Image: Visual Basic Version

'*****************************************************************************
'                                                                            *
'  Image.frm                                                                 *
'                                                                            *
'  This program demonstrates the Fastgraph for Windows image file display    *
'  and creation functions.                                                   *
'                                                                            *
'*****************************************************************************
Dim hPal As Long
Dim hVB As Long
Dim cxClient As Long, cyClient As Long
Dim cxBuffer As Long, cyBuffer As Long
Dim nColors As Long
Dim nFrames As Long
Dim Context(48) As Byte
Dim FileHeader(128) As Byte
Dim FileName As String
Dim mbString As String
Private Sub Form_Activate()
   Call fg_realize(hPal)
   Refresh
End Sub
Private Sub Form_Load()
   ScaleMode = 3
   Call fg_setdc(hDC)
   hPal = fg_defpal()
   Call fg_realize(hPal)
   Call fg_vbinit
   cxBuffer = 32
   cyBuffer = 32
   hVB = fg_vballoc(cxBuffer, cyBuffer)
   Call fg_vbopen(hVB)
   Call fg_vbcolors
   Call fg_setcolor(-1)
   Call fg_fillpage
End Sub
Private Sub Form_Paint()
   Call fg_vbscale(0, cxBuffer - 1, 0, cyBuffer - 1, 0, cxClient - 1, 0, cyClient - 1)
End Sub
Private Sub Form_Resize()
   cxClient = ScaleWidth
   cyClient = ScaleHeight
   Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
   Call CloseContext
   Call fg_vbclose
   Call fg_vbfree(hVB)
   Call fg_vbfin
End Sub
'*****************************************************************************
'                                                                            *
'  Event handlers for the items on the BMP menu.                             *
'                                                                            *
'*****************************************************************************
Private Sub mnuBMPItem_Click(Index As Integer)
   Dim ColorDepth As Long
   On Error GoTo ErrHandler
   Select Case Index
      Case 0   ' Open
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "bmp"
         CommonDialog1.FileName = ""
         CommonDialog1.Filter = "BMP files (*.bmp)|*.BMP"
         CommonDialog1.Flags = cdlOFNReadOnly
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowOpen
         FileName = CommonDialog1.FileName
         If fg_bmphead(FileName, FileHeader(0)) < 0 Then
            Call MsgBox(FileName + vbCr + " is not a BMP file.", vbCritical, "Error")
            Exit Sub
         End If
         Screen.MousePointer = 11
         nColors = fg_bmppal(FileName, ByVal 0)
         Call fg_bmpsize(FileHeader(0), cxBuffer, cyBuffer)
         Call SwitchBuffers
         Call fg_showbmp(FileName, 0)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
         Screen.MousePointer = 0
         mnuBMPItem(1).Enabled = True
         mnuBMPItem(2).Enabled = True
         mnuPCXItem(1).Enabled = True
         mnuPCXItem(2).Enabled = False
         mnuJPEGItem(1).Enabled = False
         mnuFlicItem(1).Enabled = False
         mnuFlicItem(2).Enabled = False
         mnuFlicItem(3).Enabled = False
         mnuFlicItem(4).Enabled = False
         mnuAVIItem(1).Enabled = False
         mnuAVIItem(2).Enabled = False
         mnuAVIItem(3).Enabled = False
         mnuAVIItem(4).Enabled = False
      Case 1   ' Make
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "bmp"
         CommonDialog1.FileName = Left(FileName, InStr(FileName, ".") - 1) + ".bmp"
         CommonDialog1.Filter = "BMP files (*.bmp)|*.BMP"
         CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt + _
                               cdlOFNPathMustExist
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowSave
         FileName = CommonDialog1.FileName
         If nColors = 0 Then
           ColorDepth = 24
         ElseIf nColors = 256 Then
           ColorDepth = 8
         ElseIf nColors = 16 Then
           ColorDepth = 4
         Else
           ColorDepth = 1
         End If
         Screen.MousePointer = 11
         Call fg_makebmp(0, cxBuffer - 1, 0, cyBuffer - 1, ColorDepth, FileName)
         Screen.MousePointer = 0
      Case 2   ' Details
         mbString = FileName + vbCr + _
                  Str(cxBuffer) + " x" + Str(cyBuffer) + " pixels" + vbCr
         If nColors > 0 Then
            mbString = mbString + Str(nColors) + " colors"
         Else
            mbString = mbString + "24-bit RGB"
         End If
         Call MsgBox(mbString, vbInformation, "Information")
   End Select
ErrHandler:  ' user pressed Cancel button
End Sub
'*****************************************************************************
'                                                                            *
'  Event handlers for the items on the PCX menu.                             *
'                                                                            *
'*****************************************************************************
Private Sub mnuPCXItem_Click(Index As Integer)
   On Error GoTo ErrHandler
   Select Case Index
      Case 0   ' Open
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "pcx"
         CommonDialog1.FileName = ""
         CommonDialog1.Filter = "PCX files (*.pcx)|*.PCX"
         CommonDialog1.Flags = cdlOFNReadOnly
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowOpen
         FileName = CommonDialog1.FileName
         If fg_pcxhead(FileName, FileHeader(0)) < 0 Then
            Call MsgBox(FileName + vbCr + " is not a PCX file.", vbCritical, "Error")
            Exit Sub
         End If
         Screen.MousePointer = 11
         nColors = fg_pcxpal(FileName, ByVal 0)
         Call fg_pcxsize(FileHeader(0), cxBuffer, cyBuffer)
         Call SwitchBuffers
         Call fg_move(0, 0)
         Call fg_showpcx(FileName, FG_AT_XY)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
         Screen.MousePointer = 0
         mnuBMPItem(1).Enabled = True
         mnuBMPItem(2).Enabled = False
         mnuPCXItem(1).Enabled = True
         mnuPCXItem(2).Enabled = True
         mnuJPEGItem(1).Enabled = False
         mnuFlicItem(1).Enabled = False
         mnuFlicItem(2).Enabled = False
         mnuFlicItem(3).Enabled = False
         mnuFlicItem(4).Enabled = False
         mnuAVIItem(1).Enabled = False
         mnuAVIItem(2).Enabled = False
         mnuAVIItem(3).Enabled = False
         mnuAVIItem(4).Enabled = False
      Case 1   ' Make
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "pcx"
         CommonDialog1.FileName = Left(FileName, InStr(FileName, ".") - 1) + ".pcx"
         CommonDialog1.Filter = "PCX files (*.pcx)|*.PCX"
         CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt + _
                               cdlOFNPathMustExist
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowSave
         FileName = CommonDialog1.FileName
         Screen.MousePointer = 11
         Call fg_makepcx(0, cxBuffer - 1, 0, cyBuffer - 1, FileName)
         Screen.MousePointer = 0
      Case 2   ' Details
         mbString = FileName + vbCr + _
                  Str(cxBuffer) + " x" + Str(cyBuffer) + " pixels" + vbCr
         If nColors > 0 Then
            mbString = mbString + Str(nColors) + " colors"
         Else
            mbString = mbString + "24-bit RGB"
         End If
         Call MsgBox(mbString, vbInformation, "Information")
   End Select
ErrHandler:  ' user pressed Cancel button
End Sub
'*****************************************************************************
'                                                                            *
'  Event handlers for the items on the JPEG menu.                            *
'                                                                            *
'*****************************************************************************
Private Sub mnuJPEGItem_Click(Index As Integer)
   On Error GoTo ErrHandler
   Select Case Index
      Case 0   ' Open
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "jpg"
         CommonDialog1.FileName = ""
         CommonDialog1.Filter = "JPEG files (*.jpg)|*.JPG"
         CommonDialog1.Flags = cdlOFNReadOnly
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowOpen
         FileName = CommonDialog1.FileName
         If fg_jpeghead(FileName, FileHeader(0)) < 0 Then
            Call MsgBox(FileName + vbCr + " is not a baseline JPEG file.", vbCritical,
                        "Error")
            Exit Sub
         End If
         Screen.MousePointer = 11
         nColors = 0
         Call fg_jpegsize(FileHeader(0), cxBuffer, cyBuffer)
         Call SwitchBuffers
         Call fg_showjpeg(FileName, 0)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
         Screen.MousePointer = 0
         mnuBMPItem(1).Enabled = True
         mnuBMPItem(2).Enabled = False
         mnuPCXItem(1).Enabled = True
         mnuPCXItem(2).Enabled = False
         mnuJPEGItem(1).Enabled = True
         mnuFlicItem(1).Enabled = False
         mnuFlicItem(2).Enabled = False
         mnuFlicItem(3).Enabled = False
         mnuFlicItem(4).Enabled = False
         mnuAVIItem(1).Enabled = False
         mnuAVIItem(2).Enabled = False
         mnuAVIItem(3).Enabled = False
         mnuAVIItem(4).Enabled = False
      Case 1   ' Details
         mbString = FileName + vbCr + _
                  Str(cxBuffer) + " x" + Str(cyBuffer) + " pixels" + vbCr + _
                  "24-bit RGB"
         Call MsgBox(mbString, vbInformation, "Information")
   End Select
ErrHandler:  ' user pressed Cancel button
End Sub
'*****************************************************************************
'                                                                            *
'  Event handlers for the items on the FLI/FLC menu.                         *
'                                                                            *
'*****************************************************************************
Private Sub mnuFlicItem_Click(Index As Integer)
   On Error GoTo ErrHandler
   Select Case Index
      Case 0   ' Open
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "fli"
         CommonDialog1.FileName = ""
         CommonDialog1.Filter = "flic files (*.fli,*.flc)|*.FLI;*.FLC"
         CommonDialog1.Flags = cdlOFNReadOnly
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowOpen
         FileName = CommonDialog1.FileName
         If fg_flichead(FileName, FileHeader(0)) < 0 Then
            Call MsgBox(FileName + vbCr + " is not an FLI or FLC file.", vbCritical,
                        "Error")
            Exit Sub
         End If
         nColors = 256
         Call fg_flicsize(FileHeader(0), cxBuffer, cyBuffer)
         Call SwitchBuffers
         Call fg_flicopen(FileName, Context(0))
         Call fg_flicplay(Context(0), 1, FG_NODELAY)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
         nFrames = FileHeader(7) * 256 + FileHeader(6)
         mnuBMPItem(1).Enabled = True
         mnuBMPItem(2).Enabled = False
         mnuPCXItem(1).Enabled = True
         mnuPCXItem(2).Enabled = False
         mnuJPEGItem(1).Enabled = False
         mnuFlicItem(1).Enabled = True
         mnuFlicItem(2).Enabled = True
         mnuFlicItem(3).Enabled = True
         mnuFlicItem(4).Enabled = True
         mnuAVIItem(1).Enabled = False
         mnuAVIItem(2).Enabled = False
         mnuAVIItem(3).Enabled = False
         mnuAVIItem(4).Enabled = False
      Case 1   ' Play
         Screen.MousePointer = 11
         Call fg_showflic(FileName, 0, FG_NODELAY)
         Screen.MousePointer = 0
         Call fg_flicskip(Context(0), -1)
      Case 2   ' Frame
         If fg_flicplay(Context(0), 1, FG_NODELAY) = 0 Then
            Call fg_flicskip(Context(0), -1)
            Call fg_flicplay(Context(0), 1, FG_NODELAY)
         End If
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
      Case 3   ' Reset
         Call fg_flicskip(Context(0), -1)
         Call fg_flicplay(Context(0), 1, FG_NODELAY)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
      Case 4   ' Details
         mbString = FileName + vbCr + _
                  Str(cxBuffer) + " x" + Str(cyBuffer) + " pixels" + vbCr + _
                  Str(nFrames) + " frames"
         Call MsgBox(mbString, vbInformation, "Information")
   End Select
ErrHandler:  ' user pressed Cancel button
End Sub
'*****************************************************************************
'                                                                            *
'  Event handlers for the items on the AVI menu.                             *
'                                                                            *
'*****************************************************************************
Private Sub mnuAVIItem_Click(Index As Integer)
   On Error GoTo ErrHandler
   Select Case Index
      Case 0   ' Open
         CommonDialog1.CancelError = True
         CommonDialog1.DefaultExt = "avi"
         CommonDialog1.FileName = ""
         CommonDialog1.Filter = "AVI files (*.avi)|*.AVI"
         CommonDialog1.Flags = cdlOFNReadOnly
         CommonDialog1.InitDir = App.Path
         CommonDialog1.ShowOpen
         FileName = CommonDialog1.FileName
         If fg_avihead(FileName, FileHeader(0)) < 0 Then
            Call MsgBox(FileName + vbCr + " is not an AVI file.", vbCritical, "Error")
            Exit Sub
         End If
         nColors = fg_avipal(FileName, ByVal 0)
         Call fg_avisize(FileHeader(0), cxBuffer, cyBuffer)
         Call SwitchBuffers
         If fg_aviopen(FileName, Context(0)) < 0 Then
            Call MsgBox("Cannot play AVI file" + vbCr + FileName + ".", vbCritical,
                        "Error")
            mnuAVIItem(1).Enabled = False
            mnuAVIItem(2).Enabled = False
            mnuAVIItem(3).Enabled = False
            mnuAVIItem(4).Enabled = False
            Exit Sub
         End If
         Call fg_aviplay(Context(0), 1, FG_NODELAY)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
         mnuBMPItem(1).Enabled = True
         mnuBMPItem(2).Enabled = False
         mnuPCXItem(1).Enabled = True
         mnuPCXItem(2).Enabled = False
         mnuJPEGItem(1).Enabled = False
         mnuFlicItem(1).Enabled = False
         mnuFlicItem(2).Enabled = False
         mnuFlicItem(3).Enabled = False
         mnuFlicItem(4).Enabled = False
         mnuAVIItem(1).Enabled = True
         mnuAVIItem(2).Enabled = True
         mnuAVIItem(3).Enabled = True
         mnuAVIItem(4).Enabled = True
      Case 1   ' Play
         Screen.MousePointer = 11
         Call fg_showavi(FileName, 0, FG_NODELAY)
         Screen.MousePointer = 0
         Call fg_aviskip(Context(0), -1)
      Case 2   ' Frame
         If fg_aviplay(Context(0), 1, FG_NODELAY) = 0 Then
            Call fg_aviskip(Context(0), -1)
            Call fg_aviplay(Context(0), 1, FG_NODELAY)
         End If
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
      Case 3   ' Reset
         Call fg_aviskip(Context(0), -1)
         Call fg_aviplay(Context(0), 1, FG_NODELAY)
         Call fg_vbscale(0, cxBuffer-1, 0, cyBuffer-1, 0, cxClient-1, 0, cyClient-1)
      Case 4   ' Details
         mbString = FileName + vbCr + _
                  Str(cxBuffer) + " x" + Str(cyBuffer) + " pixels" + vbCr
         If nColors > 0 Then
            mbString = mbString + Str(nColors) + " colors"
         Else
            mbString = mbString + "24-bit RGB"
         End If
         Call MsgBox(mbString, vbInformation, "Information")
   End Select
ErrHandler:  ' user pressed Cancel button
End Sub
Private Sub mnuExit_Click()
   Unload Me
End Sub
'*****************************************************************************
'                                                                            *
'  CloseContext()                                                            *
'                                                                            *
'  Closes the active flic or AVI context. This function is called from       *
'  SwitchBuffers() and also from the Form_Unload handler.                    *
'                                                                            *
'*****************************************************************************
Private Sub CloseContext()
   If mnuFlicItem(4).Enabled Then
     Call fg_flicdone(Context(0))
   ElseIf mnuAVIItem(4).Enabled Then
     Call fg_avidone(Context(0))
   End If
End Sub
'*****************************************************************************
'                                                                            *
'  SwitchBuffers()                                                           *
'                                                                            *
'  Close the and release the active virtual buffer, then create and open a   *
'  new virtual buffer to hold the new image file.                            *
'                                                                            *
'*****************************************************************************
Private Sub SwitchBuffers()
   Call CloseContext
   Call fg_vbclose
   Call fg_vbfree(hVB)
   If nColors = 0 Then
      Call fg_vbdepth(24)
   Else
      Call fg_vbdepth(8)
   End If
   hVB = fg_vballoc(cxBuffer, cyBuffer)
   Call fg_vbopen(hVB)
   Call fg_vbcolors
End Sub

<< Prev

Next >>

Contents
Fastgraph Home Page

 

copyright 2001 Ted Gruber Software, Inc.