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
|