Mastering Visual Basic 5/MasteringVisualBasic5.iso/olympus/ik32_15t/vb4.shr/GetPtln.frm

Visual Basic Form | 1996-08-07 | 9.7 KB | 340 lines

VERSION 4.00
Begin VB.Form Form1
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Get/Put Line"
   ClientHeight    =   2805
   ClientLeft      =   2115
   ClientTop       =   1965
   ClientWidth     =   4785
   Height          =   3585
   Left            =   2055
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   187
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   319
   Top             =   1245
   Width           =   4905
   Begin VB.CommandButton cmdTransfer
      Caption         =   "&Transfer"
      Height          =   375
      Left            =   90
      TabIndex        =   0
      Top             =   2340
      Width           =   1485
   End
   Begin ik32Lib.Picbuf PicbufDest
      Height          =   2265
      Left            =   2430
      TabIndex        =   2
      Top             =   0
      Width           =   2265
      _Version        =   65536
      _ExtentX        =   3995
      _ExtentY        =   3995
      _StockProps     =   253
   End
   Begin ik32Lib.Picbuf PicbufSrc
      Height          =   2265
      Left            =   90
      TabIndex        =   1
      Top             =   0
      Width           =   2265
      _Version        =   65536
      _ExtentX        =   3995
      _ExtentY        =   3995
      _StockProps     =   253
      FileName        =   "D:\MAI\IMAGES\Boat.bmp"
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuLoad1Bit
         Caption         =   "Load &1 Bit"
      End
      Begin VB.Menu mnuLoad4Bit
         Caption         =   "Load &4 Bit"
      End
      Begin VB.Menu mnuLoad8Bit
         Caption         =   "Load &8 Bit"
      End
      Begin VB.Menu mnuLoad24Bit
         Caption         =   "Load &24 Bit"
      End
      Begin VB.Menu mnuSpacer
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit
         Caption         =   "E&xit"
         Shortcut        =   ^X
      End
   End
   Begin VB.Menu mnuOptions
      Caption         =   "&Options"
      Begin VB.Menu mnuShowProgress
         Caption         =   "&Show Progress"
         Checked         =   -1  'True
      End
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim Root As String
'Description: This code creates 1-bit, opposite
'images in the two picbufs.
Sub Build1Bit()
    ' setup the source
    ReDim nLine(0 To picbufsrc.Width - 1) As Long
    Dim i, j As Integer
    ' setup the source
    picbufsrc.Init 1, picbufsrc.Width, picbufsrc.Height, RGB(255, 255, 255)
    For i = 0 To picbufsrc.Width - 1
        nLine(i) = 0
    Next i
    For j = 0 To picbufsrc.Width - 1
        picbufsrc.PutScanLine j, nLine(0)
    Next j
    ' setup the destination
    PicbufDest.Init 1, PicbufDest.Width, PicbufDest.Height, RGB(255, 255, 255)
    For i = 0 To PicbufDest.Width - 1
        nLine(i) = 255
    Next i
    For j = 0 To PicbufDest.Width - 1
        PicbufDest.PutScanLine j, nLine(0)
    Next j
End Sub
'Description: This code creates 24-bit, opposite
'images in the two picbufs.
Sub Build24Bit()
    ' setup the source
    picbufsrc.Init 24, picbufsrc.Width, picbufsrc.Height, RGB(255, 255, 255)
    ReDim nLine(0 To picbufsrc.Width - 1) As Long
    Dim i, j, k As Integer
    Dim inc As Integer
    inc = 255 / picbufsrc.Height
    k = 0
    For j = 0 To picbufsrc.Height - 1
        For i = 0 To picbufsrc.Width - 1
            nLine(i) = RGB(k, k, k)
        Next

        picbufsrc.PutScanLine j, nLine(0)

        k = k + inc
        If k > 255 Then
            k = 255
        End If
    Next j
    ' setup the destination
    PicbufDest.Init 24, PicbufDest.Width, PicbufDest.Height, RGB(255, 255, 255)
    k = 255
    For j = 0 To PicbufDest.Height - 1
        For i = 0 To PicbufDest.Width - 1
            nLine(i) = RGB(k, k, k)
        Next i

        PicbufDest.PutScanLine j, nLine(0)

        k = k - inc
        If k < 0 Then
            k = 0
        End If
    Next j
End Sub
'Description: This code creates 4-bit, opposite
'images in the two picbufs.
Sub Build4Bit()
    ' setup the source
    picbufsrc.Init 4, picbufsrc.Width, PicbufDest.Width, RGB(255, 255, 255)
    ReDim nLine(0 To picbufsrc.Width - 1) As Long
    Dim LoopIndex, i, j, k As Integer
    Dim inc As Integer
    Dim palette(16) As Long
    inc = 256 / 16
    j = 0
    For i = 1 To 16
        palette(i) = RGB(j, j, j)
        If j < 255 Then
            j = j + inc
        ElseIf j > 255 Then
            j = 255
        End If
    Next i
    picbufsrc.CreatePalette 16, palette(0), 0
    inc = picbufsrc.Height / 16
    For j = 0 To picbufsrc.Width - 1
        Select Case j
            Case Is < inc
                k = 0
            Case Is < inc * 2
                k = 1
            Case Is < inc * 3
                k = 2
            Case Is < inc * 4
                k = 3
            Case Is < inc * 5
                k = 4
            Case Is < inc * 6
                k = 5
            Case Is < inc * 7
                k = 6
            Case Is < inc * 8
                k = 7
            Case Is < inc * 9
                k = 8
            Case Is < inc * 10
                k = 9
            Case Is < inc * 11
                k = 10
            Case Is < inc * 12
                k = 11
            Case Is < inc * 13
                k = 12
            Case Is < inc * 14
                k = 13
            Case Is < inc * 15
                k = 14
            Case Else
                k = 15
        End Select
        For i = 0 To picbufsrc.Width - 1
            nLine(i) = k
        Next i
        picbufsrc.PutScanLine j, nLine(0)
    Next j
    ' setup the destination
    PicbufDest.Init 4, PicbufDest.Width, PicbufDest.Height, RGB(255, 255, 255)
    PicbufDest.CreatePalette 16, palette(1), 0
    inc = PicbufDest.Height / 16
    For j = 0 To PicbufDest.Width - 1
        Select Case j
            Case Is < inc
                k = 15
            Case Is < inc * 2
                k = 14
            Case Is < inc * 3
                k = 13
            Case Is < inc * 4
                k = 12
            Case Is < inc * 5
                k = 11
            Case Is < inc * 6
                k = 10
            Case Is < inc * 7
                k = 9
            Case Is < inc * 8
                k = 8
            Case Is < inc * 9
                k = 7
            Case Is < inc * 10
                k = 6
            Case Is < inc * 11
                k = 5
            Case Is < inc * 12
                k = 4
            Case Is < inc * 13
                k = 3
            Case Is < inc * 14
                k = 2
            Case Is < inc * 15
                k = 1
            Case Else
                k = 0
        End Select
        For i = 0 To PicbufDest.Width - 1
            nLine(i) = k
        Next i

        PicbufDest.PutScanLine j, nLine(0)
    Next j
End Sub
'Description: This code creates 8-bit, opposite
'images in the two picbufs.
Sub Build8Bit()
    ' setup the source
    picbufsrc.Init 8, picbufsrc.Width, picbufsrc.Height, RGB(255, 255, 255)
    ReDim nLine(0 To picbufsrc.Width - 1) As Long
    Dim i, j, k As Integer
    Dim inc As Integer
    Dim palette(256) As Long
    inc = 256 / picbufsrc.Height
    j = 0
    For i = 0 To 255
        palette(i) = RGB(j, j, j)
        If j < 255 Then
            j = j + inc
        ElseIf j > 255 Then
            j = 255
        End If
    Next i
    picbufsrc.CreatePalette 255, palette(1), 0
    For j = 0 To picbufsrc.Height - 1
        For i = 0 To picbufsrc.Width - 1
            nLine(i) = j
        Next i

        picbufsrc.PutScanLine j, nLine(0)
    Next j
    ' setup the destination
    PicbufDest.Init 8, PicbufDest.Width, PicbufDest.Height, RGB(255, 255, 255)
    PicbufDest.CreatePalette 255, palette(1), 0
    k = PicbufDest.Height
    For j = 0 To PicbufDest.Width - 1
        For i = 0 To PicbufDest.Width - 1
            nLine(i) = k
        Next i

        PicbufDest.PutScanLine j, nLine(0)

        k = k - 1
    Next j
End Sub
'Description: This code transfers the image from
'one picbuf to another.
Private Sub cmdTransfer_Click()
    Dim i As Integer
    ReDim Line(picbufsrc.Width) As Long
    For i = 0 To picbufsrc.Height - 1
        picbufsrc.GetScanLine i, Line(1)
        PicbufDest.PutScanLine i, Line(1)
        If mnuShowProgress.Checked Then
            DoEvents
        End If
    Next
End Sub
'Description: This code sets picbuf properties,
'and sets up 24 bit images in the two picbufs.
Private Sub Form_Load()
    InitPicbuf picbufsrc, False
    InitPicbuf PicbufDest, False
    Build24Bit
End Sub
'Description: This sub ends the program
Private Sub mnuExit_Click()
    ExitProgram
End Sub
'Description: This code calls a sub to create two
'1-bit images
Private Sub mnuLoad1Bit_Click()
    Build1Bit
End Sub
'Description: This code calls a sub to create two
'24-bit images
Private Sub mnuLoad24Bit_Click()
    Build24Bit
End Sub
'Description: This code calls a sub to create two
'4-bit images
Private Sub mnuLoad4Bit_Click()
    Build4Bit
End Sub
'Description: This code calls a sub to create two
'8-bit images
Private Sub mnuLoad8Bit_Click()
    Build8Bit
End Sub
Private Sub mnuShowProgress_Click()
  mnuShowProgress.Checked = Not mnuShowProgress.Checked
End Sub