ActiveX Programming Unleashed CD/AXU.iso/componen/vsocx/demo/vsawk.frm

Visual Basic Form | 1994-04-04 | 17.7 KB | 528 lines

VERSION 2.00
Begin Form frmVSAwk
   BackColor       =   &H00C0C0C0&
   Caption         =   "VSAwk Demo"
   ClientHeight    =   5325
   ClientLeft      =   975
   ClientTop       =   1560
   ClientWidth     =   8220
   Height          =   6015
   Icon            =   VSAWK.FRX:0000
   Left            =   915
   LinkTopic       =   "Form1"
   ScaleHeight     =   5325
   ScaleWidth      =   8220
   Top             =   930
   Width           =   8340
   Begin ListBox lstFonts
      Height          =   1590
      Left            =   4980
      Sorted          =   -1  'True
      TabIndex        =   3
      Top             =   720
      Width           =   3075
   End
   Begin VideoSoftAwk VSAwk2
      FS              =   " ,    "
      Left            =   7260
      Top             =   480
   End
   Begin CommandButton btnPrint
      Caption         =   "&Print"
      Height          =   375
      Left            =   4140
      TabIndex        =   2
      Top             =   1920
      Width           =   735
   End
   Begin CommandButton btnView
      Caption         =   "&View"
      Height          =   375
      Left            =   3360
      TabIndex        =   1
      Top             =   1920
      Width           =   735
   End
   Begin VideoSoftAwk VSAwk1
      FS              =   " ,    "
      Left            =   7080
      Top             =   480
   End
   Begin TextBox txtCode
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "Fixedsys"
      FontSize        =   9
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   2715
      Left            =   180
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Top             =   2460
      Width           =   7815
   End
   Begin ListBox lstFileParts
      Height          =   1590
      Left            =   180
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   720
      Width           =   3075
   End
   Begin CommonDialog CMDialog1
      Left            =   7500
      Top             =   420
   End
   Begin Label lblInfo
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Open a .FRM or .BAS file, then select subroutines to view or print."
      Height          =   1035
      Left            =   3360
      TabIndex        =   9
      Top             =   720
      Width           =   1515
   End
   Begin Label lblFonts
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Printer Fonts"
      ForeColor       =   &H00000000&
      Height          =   195
      Left            =   4980
      TabIndex        =   8
      Top             =   480
      Width           =   3075
   End
   Begin Label lblContents
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      Caption         =   "Contents"
      ForeColor       =   &H00000000&
      Height          =   195
      Left            =   180
      TabIndex        =   7
      Top             =   480
      Width           =   3075
   End
   Begin Label lblFileName
      BackColor       =   &H00C0C0C0&
      Caption         =   "[none]"
      ForeColor       =   &H00000080&
      Height          =   225
      Left            =   720
      TabIndex        =   6
      Top             =   120
      Width           =   7275
   End
   Begin Label Label1
      Alignment       =   1  'Right Justify
      BackColor       =   &H00C0C0C0&
      Caption         =   "File:"
      ForeColor       =   &H00000000&
      Height          =   195
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   495
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuFileOpen
         Caption         =   "&Open"
      End
      Begin Menu mnuFileSep1
         Caption         =   "-"
      End
      Begin Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuEdit
      Caption         =   "&Edit"
      Begin Menu mnuCopy
         Caption         =   "&Copy"
      End
      Begin Menu mnuCopyAll
         Caption         =   "Copy &All"
      End
   End
   Begin Menu mnuHelp
      Caption         =   "&Help"
      Begin Menu mnuHelpAbout
         Caption         =   "&About"
      End
   End
Option Explicit
'--------------------------------------------------
' Constants and Variables used in VSAwk demo.
'--------------------------------------------------
' Color Constants
Const DARK_GRAY = &H808080
Const WHITE = &HFFFFFF
Const BLACK = &H0
' Awk Action constants
Const AWK_SCANFILE = 0
Const AWK_NEXTLINE = 1
Const AWK_CLOSEFILE = 2
' Holds the section of basic code
Dim CodeString As String
' Boolean used while looking for [declarations] section
Dim FoundDecl As Integer
' Are we printing or just viewing?
Dim ActionType As Integer
' Used to indicate declarations section of code.
Const DECLARE_STRING = "(declarations)"
' WindowState constant
Const MINIMIZED = 1
' Cursor shape constants
Const CSR_NORMAL = 0
Const CSR_HOURGLASS = 11
' ActionType constants
Const GO_VIEW = 0
Const GO_PRINT = 1
' Default margin constants
Const LR_MARGIN = 5
Const TOP_MARGIN = 3
Const MB_OK = 0                 ' OK button only
Const MB_ICONEXCLAMATION = 48   ' Warning message
Sub btnPrint_Click ()
'--------------------------------------------------
' Print the routine selected in the list box.
'--------------------------------------------------
    If lstFileParts.ListIndex < 0 Then Exit Sub
    Screen.MousePointer = CSR_HOURGLASS
    VSAwk2.FileName = CMDialog1.Filename
    ActionType = GO_PRINT
    VSAwk2.Action = AWK_SCANFILE
    Screen.MousePointer = CSR_NORMAL
End Sub
Sub btnView_Click ()
'--------------------------------------------------
' View the routine selected in the list box.
'--------------------------------------------------
    If lstFileParts.ListIndex < 0 Then Exit Sub
    Screen.MousePointer = CSR_HOURGLASS
    VSAwk2.FileName = CMDialog1.Filename
    ActionType = GO_VIEW
    VSAwk2.Action = AWK_SCANFILE
    Screen.MousePointer = CSR_NORMAL
End Sub
Sub ClearForm ()
'--------------------------------------------------
' Get rid of any old data in the controls.
'--------------------------------------------------
     lstFileParts.Clear
     TxtCode.Text = ""
End Sub
Sub Form_Load ()
'--------------------------------------------------
' Position the form and load Printer Font list box.
'--------------------------------------------------
Dim i As Integer
    mnuHelp.Caption = Chr$(8) & mnuHelp.Caption & "  "
    For i = 0 To Printer.FontCount - 1
        lstFonts.AddItem Printer.Fonts(i)
    Next
    For i = 0 To lstFonts.ListCount - 1
        If i = 0 Then lstFonts.ListIndex = i
        If lstFonts.List(i) = "Courier New" Then lstFonts.ListIndex = i
    Next
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
End Sub
Sub Form_Paint ()
'--------------------------------------------------
' Repaint 3D effect where necessary.
'--------------------------------------------------
    Set3DControls
End Sub
Sub Form_Resize ()
'--------------------------------------------------
' Adjust the size of the text control and the
' File Name label when window size changes.
'--------------------------------------------------
Dim NewWidth As Integer, NewHeight As Integer
Dim Margin As Integer
    On Error Resume Next
    If WindowState = MINIMIZED Then Exit Sub
    Me.Cls
    Margin = lstFileParts.Left
    NewWidth = (Me.ScaleWidth - TxtCode.Left - Margin)
    NewHeight = (Me.ScaleHeight - TxtCode.Top - Margin)
    TxtCode.Move TxtCode.Left, TxtCode.Top, NewWidth, NewHeight
    lblFilename.Width = Me.ScaleWidth - lblFilename.Left - Margin
    ' Draw 3D effect around selected controls
    Set3DControls
End Sub
Function IsTextFile (ByVal AFileName As String) As Integer
'--------------------------------------------------
' A quick little check to see if this is a text
' file or not.  Not 100% accurate, but better
' than nothing.
'--------------------------------------------------
Dim fnum As Integer
Dim i As Integer
Dim ch As String
    On Error GoTo IsTextFile_Error
    IsTextFile = True
    fnum = FreeFile
    Open AFileName For Input As fnum
    For i = 1 To 25
        ch = Input$(1, fnum)
        ' if it's not lower ASCII then its probably
        ' not a text file.
        If Asc(ch) > 127 Then
            IsTextFile = False
            Exit For
        End If
        If EOF(fnum) Then Exit For
    Next
Exit Function
IsTextFile_Error:
    IsTextFile = False
    Exit Function
End Function
Sub lstFileParts_DblClick ()
'--------------------------------------------------
' Double-clicking on list box is the same as
' pressing the View button.
'--------------------------------------------------
    btnView.Value = 1
End Sub
Sub Make3D (pic As Form, ctl As Control)
'--------------------------------------------------
' Wrap a 3D effect around a control on a form.
'--------------------------------------------------
Dim AdjustX As Integer, AdjustY As Integer
Dim RightSide As Single
    AdjustX = Screen.TwipsPerPixelX
    AdjustY = Screen.TwipsPerPixelY
    ' Set the top shading line.
    pic.Line (ctl.Left - AdjustX, ctl.Top - AdjustY)-(ctl.Left + ctl.Width, ctl.Top - AdjustY), DARK_GRAY
    pic.Line -(ctl.Left + ctl.Width, ctl.Top + ctl.Height), WHITE
    pic.Line -(ctl.Left - AdjustX, ctl.Top + ctl.Height), WHITE
    pic.Line -(ctl.Left - AdjustX, ctl.Top - AdjustY), DARK_GRAY
End Sub
Sub mnuCopy_Click ()
    If TxtCode.SelText <> "" Then
        ClipBoard.SetText TxtCode.SelText
        TxtCode.SetFocus
    End If
End Sub
Sub mnuCopyAll_Click ()
Dim SavePos As Integer
    SavePos = TxtCode.SelStart
    TxtCode.SelStart = 0
    TxtCode.SelLength = Len(TxtCode.Text)
    If TxtCode.SelText <> "" Then
        ClipBoard.SetText TxtCode.SelText
    End If
    TxtCode.SelStart = SavePos
    TxtCode.SelLength = 0
    TxtCode.SetFocus
End Sub
Sub mnuFileExit_Click ()
'--------------------------------------------------
' End the program.
'--------------------------------------------------
    Unload Me
End Sub
Sub mnuFileOpen_Click ()
'--------------------------------------------------
' Open a Visual Basic source code file.
'--------------------------------------------------
    CMDialog1.DialogTitle = "Open a Visual Basic Source File"
    CMDialog1.Filter = "VB Source Code (.FRM,.BAS)|*.frm;*.bas"
    CMDialog1.Action = 1
    If CMDialog1.Filename = "" Then Exit Sub
    If Not IsTextFile(CMDialog1.Filename) Then
        MsgBox "Source files must be saved as text.", MB_OK Or MB_ICONEXCLAMATION
        Exit Sub
    End If
    ClearForm
    lblFilename = CMDialog1.Filename
    VSAwk1.FileName = CMDialog1.Filename
    Screen.MousePointer = CSR_HOURGLASS
    VSAwk1.Action = AWK_SCANFILE
    Screen.MousePointer = CSR_NORMAL
End Sub
Sub mnuHelpAbout_Click ()
    frmAbout.Show 1
End Sub
Sub PrintHeading ()
'--------------------------------------------------
' Print heading at top of a printer page.
'--------------------------------------------------
Dim i As Integer
    On Error Resume Next
    Printer.CurrentY = 0
    Printer.CurrentX = 0
    For i = 1 To TOP_MARGIN
        Printer.Print
    Next
    Printer.FontBold = True
    Printer.Print Space$(LR_MARGIN) & "File:    "; CMDialog1.Filename;
    PrintRightAlign "Page " & Format$(Printer.Page)
    Printer.Print
    Printer.Print Space$(LR_MARGIN) & "Printed: " & Format$(Now, "MM/DD/YYYY")
    Printer.CurrentX = Printer.TextWidth(Space$(LR_MARGIN))
    Printer.CurrentY = Printer.CurrentY + (Printer.TextHeight("W") \ 2)
    Printer.DrawWidth = 3
    Printer.Line -(Printer.ScaleWidth - Printer.TextWidth(Space$(LR_MARGIN)), Printer.CurrentY), RGB(0, 0, 0)
    Printer.CurrentY = Printer.CurrentY + (Printer.TextHeight("W") \ 2)
    Printer.CurrentX = 0
    Printer.FontBold = False
End Sub
Sub PrintLine (ByVal ALine As String)
'--------------------------------------------------
' Print a single line to the printer.  Break up
' long lines and pass them to PrintLine recursively.
'--------------------------------------------------
Dim indent As Integer
Dim i As Integer, j As Integer
Dim LeftMargin As String
Dim ATab As String
    On Error Resume Next
    ATab = Chr$(9)
    ALine = RTrim$(ALine)
    indent = 0
    For i = 1 To Len(ALine)
        If Mid$(ALine, i, 1) = " " Then
            indent = indent + 1
        ' This converts tabs to spaces
        ElseIf Mid$(ALine, i, 1) = ATab Then
            indent = indent + 8
        Else
            Exit For
        End If
    Next
    ALine = Space$(indent) & Mid$(ALine, i)
    LeftMargin = Space$(LR_MARGIN)
    ' Check if we're at the end of the page.
    If (Printer.CurrentY + Printer.TextHeight(ALine)) >= Printer.ScaleHeight Then
        Printer.NewPage
        PrintHeading
    End If
    ' Check if we can fit Aline on a single line.
    If Printer.TextWidth(LeftMargin & ALine & LeftMargin) <= Printer.ScaleWidth Then
        If Left$(Trim$(ALine), 1) = "'" Then Printer.FontItalic = True
        Printer.Print LeftMargin & ALine
        Printer.FontItalic = False
    Else
        For i = 1 To Len(ALine)
            If Printer.TextWidth(LeftMargin & Left$(ALine, i) & LeftMargin) > Printer.ScaleWidth Then
                Exit For
            End If
        Next
        ' Try to adjust for a word break nearby.
        For j = i To (j - 12) Step -1
            If InStr(" :()", Mid$(ALine, j, 1)) > 0 Then
                i = j + 1
                Exit For
            End If
        Next
        Printer.Print LeftMargin & Left$(ALine, i - 1)
        PrintLine Space$(indent) & ">> " & Mid$(ALine, i)
    End If
End Sub
Sub PrintRightAlign (ByVal Astr As String)
'--------------------------------------------------
' Print a string a the far right of the page.
'--------------------------------------------------
    On Error Resume Next
    Printer.CurrentX = Printer.ScaleWidth - Printer.TextWidth(Astr) - Printer.TextWidth(Space$(LR_MARGIN))
    Printer.Print Astr;
End Sub
Sub Set3DControls ()
'--------------------------------------------------
' Draw 3D effect around selected controls.
'--------------------------------------------------
    Make3D frmVSAwk, lstFileParts
    Make3D frmVSAwk, TxtCode
    Make3D frmVSAwk, lblFilename
    Make3D frmVSAwk, lblContents
    Make3D frmVSAwk, lblFonts
    Make3D frmVSAwk, lstFonts
    Make3D frmVSAwk, lblInfo
End Sub
Sub VSAwk1_Begin ()
'--------------------------------------------------
' Check whether we need to skip the "form definition"
' stuff at the beginning of a .FRM file.
'--------------------------------------------------
    If Right$(CMDialog1.Filename, 4) <> ".FRM" Then
        lstFileParts.AddItem DECLARE_STRING
        lstFileParts.ItemData(lstFileParts.NewIndex) = VSAwk1.CurrPos
    Else
        FoundDecl = False
    End If
End Sub
Sub VSAwk1_Scan ()
'--------------------------------------------------
' Build the list box with sub, function and
' declaration names.
'--------------------------------------------------
    If VSAwk1.NF = 0 Then Exit Sub
    If (Right$(CMDialog1.Filename, 4) = ".FRM") And (Not FoundDecl) And (VSAwk1.L = "End") Then
        FoundDecl = True
        lstFileParts.AddItem DECLARE_STRING
        lstFileParts.ItemData(lstFileParts.NewIndex) = VSAwk1.CurrPos + Len(VSAwk1.L) + 2
    End If
    If (VSAwk1.F(1) = "Sub") Or (VSAwk1.F(1) = "Function") Then
        lstFileParts.AddItem Trim$(VSAwk1.F(2))
        lstFileParts.ItemData(lstFileParts.NewIndex) = VSAwk1.CurrPos
    End If
End Sub
Sub VSAwk2_Begin ()
'--------------------------------------------------
' Prepare to view (and optionally print) a sub,
' function or declaration section.
'--------------------------------------------------
    VSAwk2.CurrPos = lstFileParts.ItemData(lstFileParts.ListIndex)
    CodeString = ""
    ' Define printer font and print first page header.
    If ActionType = GO_PRINT Then
        If lstFonts.ListIndex >= 0 Then
            Printer.FontName = lstFonts.List(lstFonts.ListIndex)
        End If
        Printer.FontSize = 8.25
        Printer.FontBold = False
        Printer.FontItalic = False
        Printer.FontUnderline = False
        PrintHeading
    End If
End Sub
Sub VSAwk2_End ()
'--------------------------------------------------
' Load VB code into text control and, if necessary,
' end the print job.
'--------------------------------------------------
    TxtCode = CodeString
    If ActionType = GO_PRINT Then Printer.EndDoc
End Sub
Sub VSAwk2_Scan ()
'--------------------------------------------------
' Process a source code line.
'--------------------------------------------------
Dim ShutDown As Integer
    ' Parsing [Declarations] section
    If lstFileParts.List(lstFileParts.ListIndex) = DECLARE_STRING Then
        If ((VSAwk2.F(1) = "Sub") Or (VSAwk2.F(1) = "Function")) Then
            VSAwk2.Action = AWK_CLOSEFILE
            Exit Sub
        End If
    ' Parsing sub or function
    Else
        If ((VSAwk2.L = "End Sub") Or (VSAwk2.L = "End Function")) Then
            ShutDown = True
        End If
    End If
    CodeString = CodeString & VSAwk2.L & Chr$(13) & Chr$(10)
    If ActionType = GO_PRINT Then
        PrintLine VSAwk2.L
    End If
    If ShutDown Then VSAwk2.Action = AWK_CLOSEFILE
End Sub