home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch9 / Fade.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-05-31  |  6.1 KB  |  191 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  3. Begin VB.Form frmFade 
  4.    Caption         =   "Fade"
  5.    ClientHeight    =   3885
  6.    ClientLeft      =   165
  7.    ClientTop       =   735
  8.    ClientWidth     =   5835
  9.    LinkTopic       =   "Form2"
  10.    ScaleHeight     =   3885
  11.    ScaleWidth      =   5835
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin VB.TextBox txtNumFrames 
  14.       Height          =   285
  15.       Left            =   1080
  16.       TabIndex        =   5
  17.       Text            =   "10"
  18.       Top             =   360
  19.       Width           =   495
  20.    End
  21.    Begin VB.CommandButton cmdFade 
  22.       Caption         =   "Fade"
  23.       Height          =   375
  24.       Left            =   5040
  25.       TabIndex        =   3
  26.       Top             =   0
  27.       Width           =   735
  28.    End
  29.    Begin VB.TextBox txtBaseName 
  30.       Height          =   285
  31.       Left            =   1080
  32.       TabIndex        =   2
  33.       Top             =   0
  34.       Width           =   3855
  35.    End
  36.    Begin MSComDlg.CommonDialog dlgOpenFile 
  37.       Left            =   0
  38.       Top             =   720
  39.       _ExtentX        =   847
  40.       _ExtentY        =   847
  41.       _Version        =   393216
  42.    End
  43.    Begin VB.PictureBox picCanvas 
  44.       AutoSize        =   -1  'True
  45.       Height          =   2295
  46.       Left            =   120
  47.       ScaleHeight     =   149
  48.       ScaleMode       =   3  'Pixel
  49.       ScaleWidth      =   157
  50.       TabIndex        =   0
  51.       Top             =   720
  52.       Width           =   2415
  53.    End
  54.    Begin VB.Label lblFrameNumber 
  55.       Height          =   255
  56.       Left            =   1680
  57.       TabIndex        =   6
  58.       Top             =   360
  59.       Width           =   495
  60.    End
  61.    Begin VB.Label Label1 
  62.       Caption         =   "Num Frames"
  63.       Height          =   255
  64.       Index           =   1
  65.       Left            =   120
  66.       TabIndex        =   4
  67.       Top             =   360
  68.       Width           =   975
  69.    End
  70.    Begin VB.Label Label1 
  71.       Caption         =   "Base Name"
  72.       Height          =   255
  73.       Index           =   0
  74.       Left            =   120
  75.       TabIndex        =   1
  76.       Top             =   0
  77.       Width           =   855
  78.    End
  79.    Begin VB.Menu mnuFile 
  80.       Caption         =   "&File"
  81.       Begin VB.Menu mnuFileOpen 
  82.          Caption         =   "&Open..."
  83.          Shortcut        =   ^O
  84.       End
  85.    End
  86. Attribute VB_Name = "frmFade"
  87. Attribute VB_GlobalNameSpace = False
  88. Attribute VB_Creatable = False
  89. Attribute VB_PredeclaredId = True
  90. Attribute VB_Exposed = False
  91. Option Explicit
  92. ' Make the fade frames.
  93. Private Sub cmdFade_Click()
  94. Dim num_frames As Integer
  95. Dim base_name As String
  96. Dim old_pixels() As RGBTriplet
  97. Dim new_pixels() As RGBTriplet
  98. Dim bits_per_pixel As Integer
  99. Dim X As Integer
  100. Dim Y As Integer
  101. Dim i As Integer
  102. Dim fraction As Single
  103.     If Not IsNumeric(txtNumFrames.Text) Then txtNumFrames.Text = "10"
  104.     num_frames = CInt(txtNumFrames.Text)
  105.     base_name = txtBaseName.Text
  106.     ' Get the input pixels.
  107.     GetBitmapPixels picCanvas, old_pixels, bits_per_pixel
  108.     ' Make room for the output pixels.
  109.     ReDim new_pixels(0 To UBound(old_pixels, 1), 0 To UBound(old_pixels, 2))
  110.     ' Build the frames.
  111.     For i = 1 To num_frames
  112.         lblFrameNumber.Caption = Format$(i)
  113.         DoEvents
  114.         fraction = (num_frames - i) / num_frames
  115.         For X = 0 To picCanvas.ScaleWidth - 1
  116.             For Y = 0 To picCanvas.ScaleHeight - 1
  117.                 With new_pixels(X, Y)
  118.                     .rgbRed = fraction * old_pixels(X, Y).rgbRed
  119.                     .rgbGreen = fraction * old_pixels(X, Y).rgbGreen
  120.                     .rgbBlue = fraction * old_pixels(X, Y).rgbBlue
  121.                 End With
  122.             Next Y
  123.         Next X
  124.         ' Update the image.
  125.         SetBitmapPixels picCanvas, bits_per_pixel, new_pixels
  126.         picCanvas.Picture = picCanvas.Image
  127.         ' Save the results.
  128.         SavePicture picCanvas.Picture, base_name & Format$(i) & ".bmp"
  129.     Next i
  130.     ' Restore the original image.
  131.     SetBitmapPixels picCanvas, bits_per_pixel, old_pixels
  132.     picCanvas.Picture = picCanvas.Image
  133.     lblFrameNumber.Caption = ""
  134. End Sub
  135. ' Start in the current directory.
  136. Private Sub Form_Load()
  137. Dim base_name As String
  138.     base_name = App.Path
  139.     If Right$(base_name, 1) <> "\" Then base_name = base_name & "\"
  140.     txtBaseName = base_name & "Fade_"
  141.     picCanvas.AutoSize = True
  142.     picCanvas.ScaleMode = vbPixels
  143.     picCanvas.AutoRedraw = True
  144.     dlgOpenFile.CancelError = True
  145.     dlgOpenFile.InitDir = App.Path
  146.     dlgOpenFile.Filter = _
  147.         "Bitmaps (*.bmp)|*.bmp|" & _
  148.         "GIFs (*.gif)|*.gif|" & _
  149.         "JPEGs (*.jpg)|*.jpg;*.jpeg|" & _
  150.         "Icons (*.ico)|*.ico|" & _
  151.         "Cursors (*.cur)|*.cur|" & _
  152.         "Run-Length Encoded (*.rle)|*.rle|" & _
  153.         "Metafiles (*.wmf)|*.wmf|" & _
  154.         "Enhanced Metafiles (*.emf)|*.emf|" & _
  155.         "Graphic Files|*.bmp;*.gif;*.jpg;*.jpeg;*.ico;*.cur;*.rle;*.wmf;*.emf|" & _
  156.         "All Files (*.*)|*.*"
  157. End Sub
  158. ' Load the indicated file.
  159. Private Sub mnuFileOpen_Click()
  160. Dim file_name As String
  161.     ' Let the user select a file.
  162.     On Error Resume Next
  163.     dlgOpenFile.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  164.     dlgOpenFile.ShowOpen
  165.     If Err.Number = cdlCancel Then
  166.         Exit Sub
  167.     ElseIf Err.Number <> 0 Then
  168.         Beep
  169.         MsgBox "Error selecting file.", , vbExclamation
  170.         Exit Sub
  171.     End If
  172.     On Error GoTo 0
  173.     Screen.MousePointer = vbHourglass
  174.     DoEvents
  175.     file_name = Trim$(dlgOpenFile.FileName)
  176.     dlgOpenFile.InitDir = Left$(file_name, Len(file_name) _
  177.         - Len(dlgOpenFile.FileTitle) - 1)
  178.     ' Open the file.
  179.     On Error GoTo LoadError
  180.     picCanvas.Picture = LoadPicture(file_name)
  181.     On Error GoTo 0
  182.     picCanvas.Picture = picCanvas.Image
  183.     Screen.MousePointer = vbDefault
  184.     Exit Sub
  185. LoadError:
  186.     Screen.MousePointer = vbDefault
  187.     MsgBox "Error " & Format$(Err.Number) & _
  188.         " opening file '" & file_name & "'" & vbCrLf & _
  189.         Err.Description
  190. End Sub
  191.