Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_2/REFORM/REFORMAT.FRM

Visual Basic Form | 1993-12-01 | 12.0 KB | 326 lines

VERSION 2.00
Begin Form Main
   BackColor       =   &H00FFFFFF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Reformat and Unpack Utility"
   ClientHeight    =   2745
   ClientLeft      =   810
   ClientTop       =   2550
   ClientWidth     =   8040
   ControlBox      =   0   'False
   Height          =   3150
   Left            =   750
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2745
   ScaleWidth      =   8040
   Top             =   2205
   Width           =   8160
   Begin TextBox TxtOutput
      Height          =   285
      Left            =   5160
      TabIndex        =   5
      Top             =   2160
      Width           =   2655
   End
   Begin TextBox TxtInput
      Height          =   285
      Left            =   1200
      TabIndex        =   4
      Top             =   2160
      Width           =   2535
   End
   Begin CommandButton cmdCompute
      Caption         =   "Compute"
      Height          =   735
      Left            =   6360
      TabIndex        =   0
      Top             =   2880
      Width           =   1095
   End
   Begin Gauge Gauge1
      Autosize        =   -1  'True
      BackColor       =   &H00FFFFFF&
      ForeColor       =   &H000000FF&
      Height          =   375
      InnerBottom     =   1
      InnerLeft       =   1
      InnerRight      =   1
      InnerTop        =   1
      Left            =   240
      Max             =   100
      NeedleWidth     =   1
      TabIndex        =   1
      Top             =   1320
      Width           =   7575
   End
   Begin Label Label4
      Caption         =   "Input File:"
      Height          =   255
      Left            =   120
      TabIndex        =   7
      Top             =   2160
      Width           =   975
   End
   Begin Label Label3
      Caption         =   "Output File:"
      Height          =   255
      Left            =   4080
      TabIndex        =   6
      Top             =   2160
      Width           =   1095
   End
   Begin Label Label1
      Alignment       =   2  'Center
      BackColor       =   &H00FFFFFF&
      Caption         =   "Reformatting File"
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Arial"
      FontSize        =   13.5
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   375
      Left            =   2280
      TabIndex        =   3
      Top             =   240
      Width           =   3855
   End
   Begin Shape Shape1
      Height          =   975
      Left            =   120
      Top             =   840
      Width           =   7815
   End
   Begin Label Label2
      BackColor       =   &H00FFFFFF&
      Caption         =   ".........10........20.........30.........40.........50.........60.........70.........80.........90......100%"
      Height          =   255
      Left            =   240
      TabIndex        =   2
      Top             =   960
      Width           =   7575
   End
Sub cmdCompute_GotFocus ()
    DoEvents
    If Len(Dir$("parms.txt")) = 0 Then
        MsgBox "Parms.txt file not found"
        End
    End If
    Dim vparmarray()
    Open "parms.txt" For Input As 3
    Line Input #3, vparm
    If UCase$(Left$(vparm, 7)) <> "INPUT=(" Then
        MsgBox "No INPUT parameter record "
        Close #3
        End
    Else
        vpostart = 8           ' point to Input file Path Name
        vpoend = InStr(vpostart, vparm, ")")
        If vpoend = 0 Then
            MsgBox "Error in INPUT statement"
            Close #3
            End
        End If
        vInput = Mid(vparm, vpostart, vpoend - vpostart) ' save Input file path name
    End If
    Line Input #3, vparm
    If UCase$(Left$(vparm, 8)) <> "OUTPUT=(" Then
        MsgBox "No OUTPUT parameter record "
        Close #3
        End
    Else
        vpostart = 9           ' point to Output file Path Name
        vpoend = InStr(vpostart, vparm, ")")
        If vpoend = 0 Then
            MsgBox "Error in OUTPUT statement"
            Close #3
            End
        End If
        vOutput = Mid(vparm, vpostart, vpoend - vpostart) ' save Output file path name
    End If
    txtInput.Text = vInput
    txtOutput.Text = vOutput
    vparms = 0                    ' Set field statement counter to zero
    Do While Not EOF(3)
        Line Input #3, vparm
        vparms = vparms + 1       ' Get number of fields statements
    Loop
    Close #3
    If vparms = 0 Then
        MsgBox "There are no FIELD statements"
        End
    End If
    ReDim vparmarray(vparms * 3)     ' Provide array space for field statements
    Open "parms.txt" For Input As 3
    Line Input #3, vparm      ' Skip INPUT rec
    Line Input #3, vparm      ' Skip OUTPUT rec
    vreccount = 0                 ' Set record count for field statements to zero
    varraycount = 0               ' Set array index to zero
    Do While Not EOF(3)           ' Process field statements
        vreccount = vreccount + 1 ' Add 1 to record counter
        Line Input #3, vparm      ' read field statement
        If UCase$(Left$(vparm, 7)) <> "FIELD=(" Then
            MsgBox "Error in Parm record " + vreccount + Chr$(10) + vparm
            Close #3
            End
        Else
            vpostart = 8           ' point to first paramenter (start position)
            vpoend = InStr(vpostart, vparm, ",")
            If vpoend = 0 Then
                MsgBox "Error in Parm record " + vreccount + Chr$(10) + vparm
                Close #3
                End
            End If
            vparmarray(varraycount) = Mid(vparm, vpostart, vpoend - vpostart) ' save position parameter
            varraycount = varraycount + 1      ' bump up array index by 1
            vpostart = vpoend + 1              ' point to next parameter (length)
            vpoend = InStr(vpostart, vparm, ",")
            If vpoend = 0 Then
                MsgBox "Error in Parm record " + vreccount + Chr$(10) + vparm
                Close #3
                End
            End If
            vparmarray(varraycount) = Mid(vparm, vpostart, vpoend - vpostart) ' save length parameter
            varraycount = varraycount + 1    ' bump up array index
            vpostart = vpoend + 1            ' point to next parameter
            vpoend = InStr(vpostart, vparm, ")")
            If vpoend = 0 Then
                MsgBox "Error in Parm record " + vreccount + Chr$(10) + vparm
                Close #3
                End
            End If
            vparmarray(varraycount) = Mid(vparm, vpostart, vpoend - vpostart) ' save unpack flag
            varraycount = varraycount + 1      ' bump up array index
        End If
    Loop
    Close #3      ' close fields file

    If Len(Dir$(vInput)) = 0 Then
        MsgBox "Input file " + vInput + " not found"
        End
    End If
    If Len(Dir$(vOutput)) <> 0 Then
        vmsg = "Write over " + vOutput + " ?"
        vreply = MsgBox(vmsg, 33)
        If vreply <> 1 Then
            End
        End If
    End If
    Open vInput For Input As 1
    Open vOutput For Output As 2
    vFilesize = LOF(1)
    gauge1.Min = 0
    gauge1.Max = vFilesize
    gauge1.Value = 0
    vinrecs = 0                       ' Input file record counter
    Do While Not EOF(1)               ' Process input records
        vinrecs = vinrecs + 1         ' Add 1 to record counter
        Line Input #1, vInput         ' Read record from input file
        gauge1.Value = gauge1.Value + Len(vInput) + 2' Update gauge
        varraycount = 0               ' Set array index to 0
        vparmcount = 0                ' Set number of field statements to zero
        voutline = ""                 ' Set output line to Null
        Do Until vparmcount = vparms        ' Process all field statements against input record
            vparmcount = vparmcount + 1     ' increment field statement counter
            If vparmarray(varraycount + 2) = 0 Then   ' if pack flag is zero then just move input data
                voutline = voutline + Mid$(vInput, vparmarray(varraycount), vparmarray(varraycount + 1))
            Else
                vbytes% = vparmarray(varraycount + 1)  ' get length of packed field
                vbytepos = vparmarray(varraycount)    ' get input record postion of packed field
                vcounter% = 0                          ' set byte count of packed filed to zero
                Do Until vcounter% = vbytes%            ' do until all packed bytes are processed
                    vcounter% = vcounter% + 1           ' increment packed byte counter
                    vbyte = Mid$(vInput, vbytepos, 1) ' get packed byte
                    vbyte = Asc(vbyte) And 240        ' Turn off low order bits
                    vbyte = highbyte(vbyte)           ' convert result to unpacked character
                    If vbyte = " " Then
                        MsgBox "Invalid Packed data in input record " + vinrecs
                        Close #1, #2
                        End
                    End If
                    voutline = voutline + vbyte            ' move unpacked char to output line
                    If vcounter% < vbytes% Then              ' if were not working on the last byte process low order bits
                        vbyte = Mid$(vInput, vbytepos, 1)  ' get the packed byte again
                        vbyte = Asc(vbyte) And 15          ' turn off the high order bits
                        vbyte = lowbyte(vbyte)             ' convert result to unpacked character
                        If vbyte = " " Then
                            MsgBox "Invalid Packed data in input record " + vinrecs
                            Close #1, #2
                            End
                        End If
                        voutline = voutline + vbyte  ' move unpacked char to output line
                    Else
                        vbyte = Mid$(vInput, vbytepos, 1)  ' get the packed byte again
                        vbyte = Asc(vbyte) And 15          ' turn off the high order bits
                        If vbyte = &HD Then                ' D denotes negative data
                            voutline = voutline + "-"      ' Anything else is treated as positive
                        Else
                            voutline = voutline + "+"
                        End If
                    End If
                    vbytepos = vbytepos + 1          ' point to next packed character
                Loop
            End If
            varraycount = varraycount + 3      ' point to next field statement
        Loop
        Print #2, voutline
    Loop
    Close #1
    Close #2
    End
End Sub
Function highbyte (vbyte) As Variant
    Select Case vbyte
        Case &H0
            highbyte = "0"
        Case &H10
            highbyte = "1"
        Case &H20
            highbyte = "2"
        Case &H30
            highbyte = "3"
        Case &H40
            highbyte = "4"
        Case &H50
            highbyte = "5"
        Case &H60
            highbyte = "6"
        Case &H70
            highbyte = "7"
        Case &H80
            highbyte = "8"
        Case &H90
            highbyte = "9"
        Case Else
            highbyte = " "
    End Select
End Function
Function lowbyte (vbyte) As Variant
    Select Case vbyte
        Case &H0
            lowbyte = "0"
        Case &H1
            lowbyte = "1"
        Case &H2
            lowbyte = "2"
        Case &H3
            lowbyte = "3"
        Case &H4
            lowbyte = "4"
        Case &H5
            lowbyte = "5"
        Case &H6
            lowbyte = "6"
        Case &H7
            lowbyte = "7"
        Case &H8
            lowbyte = "8"
        Case &H9
            lowbyte = "9"
        Case Else
            lowbyte = " "
    End Select
End Function