Programming Tool Box/SIMS_2.iso/vb_code1/fieldpak/fpdemo2r.frm

Text File | 1993-11-09 | 15KB | 501 lines

VERSION 2.00
Begin Form ReportFrm
   BorderStyle     =   3  'Fixed Double
   Caption         =   "FieldPack demo program 2 -- Report Set-up"
   ClientHeight    =   2625
   ClientLeft      =   1215
   ClientTop       =   1890
   ClientWidth     =   7470
   ControlBox      =   0   'False
   FontBold        =   -1  'True
   FontItalic      =   0   'False
   FontName        =   "Symbol"
   FontSize        =   9.75
   FontStrikethru  =   0   'False
   FontUnderline   =   0   'False
   Height          =   3030
   Left            =   1155
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2625
   ScaleWidth      =   7470
   Top             =   1545
   Width           =   7590
   Begin CommandButton cmdPreview
      Caption         =   "Preview"
      Height          =   315
      Left            =   6420
      TabIndex        =   16
      Top             =   900
      Width           =   855
   End
   Begin CommandButton cmdWider
      Caption         =   "+"
      Height          =   315
      Left            =   4860
      TabIndex        =   11
      Top             =   1920
      Width           =   315
   End
   Begin CommandButton cmdNarrower
      Caption         =   "-"
      Height          =   315
      Left            =   5220
      TabIndex        =   10
      Top             =   1920
      Width           =   315
   End
   Begin CommandButton cmdCancel
      Caption         =   "Cancel"
      Height          =   315
      Left            =   6420
      TabIndex        =   5
      Top             =   1920
      Width           =   855
   End
   Begin CommandButton cmdPrint
      Caption         =   "Print"
      Height          =   315
      Left            =   6420
      TabIndex        =   4
      Top             =   1410
      Width           =   855
   End
   Begin CommandButton cmdMoveDown
      Caption         =   "Dn"
      Height          =   315
      Left            =   5700
      TabIndex        =   9
      Top             =   1170
      Width           =   375
   End
   Begin CommandButton cmdDeselectField
      Caption         =   "<--"
      Height          =   315
      Left            =   2460
      TabIndex        =   3
      Top             =   1200
      Width           =   675
   End
   Begin CommandButton cmdSelectField
      Caption         =   "-->"
      Height          =   315
      Left            =   2460
      TabIndex        =   2
      Top             =   720
      Width           =   675
   End
   Begin CommandButton cmdMoveUp
      Caption         =   "Up"
      Height          =   315
      Left            =   5700
      TabIndex        =   8
      Top             =   750
      Width           =   375
   End
   Begin ListBox lstSelectedFields
      Height          =   1395
      Left            =   3360
      TabIndex        =   1
      Top             =   420
      Width           =   2175
   End
   Begin ListBox lstAvailableFields
      Height          =   1395
      Left            =   120
      TabIndex        =   0
      Top             =   420
      Width           =   2115
   End
   Begin Label lblTotalWidth
      Alignment       =   1  'Right Justify
      Caption         =   "0"
      Height          =   195
      Left            =   4440
      TabIndex        =   15
      Top             =   2280
      Width           =   375
   End
   Begin Label lblFieldWidth
      Alignment       =   1  'Right Justify
      Caption         =   "0"
      Height          =   195
      Left            =   4440
      TabIndex        =   14
      Top             =   1980
      Width           =   375
   End
   Begin Label Label4
      Alignment       =   1  'Right Justify
      Caption         =   "Total width:"
      Height          =   195
      Left            =   3240
      TabIndex        =   13
      Top             =   2280
      Width           =   1155
   End
   Begin Label Label3
      Alignment       =   1  'Right Justify
      Caption         =   "Field width:"
      Height          =   195
      Left            =   3240
      TabIndex        =   12
      Top             =   1980
      Width           =   1155
   End
   Begin Label Label2
      Alignment       =   2  'Center
      Caption         =   "Selected for report:"
      Height          =   195
      Left            =   3360
      TabIndex        =   7
      Top             =   120
      Width           =   2145
   End
   Begin Label Label1
      Alignment       =   2  'Center
      Caption         =   "Fields available:"
      Height          =   195
      Left            =   150
      TabIndex        =   6
      Top             =   120
      Width           =   2085
   End
End
Option Explicit

Sub cmdCancel_Click ()

    Unload ReportFrm

End Sub

Sub cmdDeselectField_Click ()
    Dim i As Integer
    Dim w As Integer

    If lstSelectedFields.ListIndex <> -1 Then
        lstAvailableFields.AddItem lstSelectedFields.Text
        w% = Val(DS_GetField((lstSelectedFields.Text), FldDlm$, 3))
        If lstAvailableFields.ListCount = 1 Then
            lstAvailableFields.ListIndex = 0
        End If
        i% = lstSelectedFields.ListIndex
        lstSelectedFields.RemoveItem lstSelectedFields.ListIndex
        If lstSelectedFields.ListCount > 0 Then
            If i% >= lstSelectedFields.ListCount Then
                i% = lstSelectedFields.ListCount - 1
            End If
            lstSelectedFields.ListIndex = i%
            lblTotalWidth.Caption = Format$(Val(lblTotalWidth.Caption) - w% - 1)
        Else
            lblFieldWidth.Caption = "0"
            lblTotalWidth.Caption = "0"
        End If
    End If

End Sub

Sub cmdMoveDown_Click ()
    Dim i As Integer
    Dim temp As String

    If lstSelectedFields.ListIndex <> -1 Then
        If lstSelectedFields.ListIndex < lstSelectedFields.ListCount - 1 Then
            i% = lstSelectedFields.ListIndex
            temp$ = lstSelectedFields.List(i%)
            lstSelectedFields.RemoveItem i%
            lstSelectedFields.AddItem temp$, i% + 1
            lstSelectedFields.ListIndex = i% + 1
        End If
    End If

End Sub

Sub cmdMoveUp_Click ()
    Dim i    As Integer
    Dim temp As String

    If lstSelectedFields.ListIndex <> -1 Then
        If lstSelectedFields.ListIndex > 0 Then
            i% = lstSelectedFields.ListIndex
            temp$ = lstSelectedFields.List(i%)
            lstSelectedFields.RemoveItem i%
            lstSelectedFields.AddItem temp$, i% - 1
            lstSelectedFields.ListIndex = i% - 1
        End If
    End If

End Sub

Sub cmdNarrower_Click ()
    Dim w As Integer

    If lstSelectedFields.ListCount > 0 Then
        w% = Val(lblFieldWidth.Caption)
        If w% > 0 Then
            lblFieldWidth.Caption = Str$(w% - 1)
            lblTotalWidth.Caption = Format$(Val(lblTotalWidth.Caption) - 1)
            lstSelectedFields.List(lstSelectedFields.ListIndex) = DS_PutField((lstSelectedFields.List(lstSelectedFields.ListIndex)), FldDlm$, 3, (lblFieldWidth.Caption))
        End If
    End If

End Sub

Sub cmdPreview_Click ()
    Dim i As Integer
    Dim t As String

    If lstSelectedFields.ListCount > 0 Then
        pr_num_fields% = lstSelectedFields.ListCount
        ReDim pr_fld_numbers(pr_num_fields% + 1)
        ReDim pr_fld_widths(pr_num_fields% + 1)
        For i% = 1 To pr_num_fields%
            t$ = lstSelectedFields.List(i% - 1)
            t$ = DS_ReplaceDlms(t$, String$(40, " "), "")   ' trim   ???
            pr_fld_numbers(i%) = Val(DS_GetField(t$, FldDlm$, 2))
            pr_fld_widths(i%) = Val(DS_GetField(t$, FldDlm$, 3))
        Next i%
    End If

    preview_report

End Sub

Sub cmdPrint_Click ()
    Dim i As Integer
    Dim t As String

    If lstSelectedFields.ListCount > 0 Then
        pr_num_fields% = lstSelectedFields.ListCount
        ReDim pr_fld_numbers(pr_num_fields% + 1)
        ReDim pr_fld_widths(pr_num_fields% + 1)
        For i% = 1 To pr_num_fields%
            t$ = lstSelectedFields.List(i% - 1)
            t$ = DS_ReplaceDlms(t$, String$(40, " "), "")   ' trim   ???
            pr_fld_numbers(i%) = Val(DS_GetField(t$, FldDlm$, 2))
            pr_fld_widths(i%) = Val(DS_GetField(t$, FldDlm$, 3))
        Next i%
    End If

    i% = MsgBox("OK to send report to printer?", 4 + 32, "FieldPack Demo Program 2")
    If i% = 6 Then
        print_report
    End If

End Sub

Sub cmdSelectField_Click ()
    Dim i    As Integer
    Dim temp As String
    Dim tmp  As String

    If lstAvailableFields.ListIndex <> -1 Then
        lstSelectedFields.AddItem lstAvailableFields.Text
        If lstSelectedFields.ListCount = 1 Then
            lstSelectedFields.ListIndex = 0
            temp$ = lstSelectedFields.List(lstSelectedFields.ListIndex)
            tmp$ = DS_GetField(temp$, FldDlm$, 3)
            lblTotalWidth.Caption = tmp$
        Else
            lstSelectedFields.ListIndex = lstSelectedFields.ListCount - 1
            temp$ = lstSelectedFields.List(lstSelectedFields.ListIndex)
            tmp$ = DS_GetField(temp$, FldDlm$, 3)
            lblTotalWidth.Caption = Format$(Val(lblTotalWidth.Caption) + 1 + Val(tmp$))
        End If
        i% = lstAvailableFields.ListIndex
        lstAvailableFields.RemoveItem lstAvailableFields.ListIndex
        If lstAvailableFields.ListCount > 0 Then
            If i% >= lstAvailableFields.ListCount Then
                i% = lstAvailableFields.ListCount - 1
            End If
            lstAvailableFields.ListIndex = i%
        End If
    End If

End Sub

Sub cmdWider_Click ()
    Dim w As Integer

    If lstSelectedFields.ListCount > 0 Then
        w% = Val(lblFieldWidth.Caption)
        lblFieldWidth.Caption = Str$(w% + 1)
        lblTotalWidth.Caption = Format$(Val(lblTotalWidth.Caption) + 1)
        lstSelectedFields.List(lstSelectedFields.ListIndex) = DS_PutField((lstSelectedFields.List(lstSelectedFields.ListIndex)), FldDlm$, 3, (lblFieldWidth.Caption))
    End If

End Sub

Sub Form_Load ()
    Dim i As Integer
    Dim n As Integer

    n% = DS_CountDlms(field_names$, FldDlm$) + 1
    For i% = 1 To n%
        lstAvailableFields.AddItem DS_GetField(field_names$, FldDlm$, i%) + String$(40, " ") + FldDlm$ + Format$(i%) + FldDlm$ + Format$(DS_GetField(field_widths, FldDlm$, i%))
    Next i%
    lstAvailableFields.ListIndex = 0

End Sub

Function format_hdg$ (opt%)
    Dim rec As String
    Dim buf As String
    Dim fc  As String
    Dim i   As Integer

    buf$ = ""

    If opt% = 0 Then
        ' show field names
        For i% = 1 To pr_num_fields
            If i% > 1 Then
                buf$ = buf$ + " "
            End If
            buf$ = buf$ + US_CJustify(DS_GetField(field_names$, FldDlm$, pr_fld_numbers(i%)), pr_fld_widths(i%), " ")
        Next i%
    Else
        ' underline
        For i% = 1 To pr_num_fields
            If i% > 1 Then
                buf$ = buf$ + " "
            End If
            buf$ = buf$ + String$(pr_fld_widths(i%), "-")
        Next i%
    End If

    format_hdg = buf$

End Function

Function format_line$ (recno%)
    Dim rec As String
    Dim buf As String
    Dim i   As Integer

    rec$ = DS_GetField(DatabaseMemoryBuffer$, RecDlm$, recno%)
    'Rearrange record in "normal" field order for simplicity of field extraction:
    rec$ = DS_InsertField(DS_RemoveField(rec$, FldDlm$, 1), FldDlm$, FirstField, DS_GetField(rec$, FldDlm$, 1))

    buf$ = ""

    For i% = 1 To pr_num_fields
        If i% > 1 Then
            buf$ = buf$ + " "
        End If
        buf$ = buf$ + US_LJustify(DS_GetField(rec$, FldDlm$, pr_fld_numbers(i%)), pr_fld_widths(i%), " ")
    Next i%

    format_line = buf$

End Function

Sub lstAvailableFields_DblClick ()

    cmdSelectField_Click

End Sub

Sub lstSelectedFields_Click ()
    Dim i    As Integer
    Dim iw   As Integer
    Dim tw   As Integer
    Dim temp As String
    Dim tmp  As String

    If lstSelectedFields.ListIndex <> -1 Then
        i% = lstSelectedFields.ListIndex
        temp$ = lstSelectedFields.List(i%)
        tmp$ = DS_GetField(temp$, FldDlm$, 3)
        lblFieldWidth.Caption = tmp$
    End If

End Sub

Sub lstSelectedFields_DblClick ()

    cmdDeselectField_Click

End Sub

Sub preview_report ()
    Dim buf   As String
    Dim i     As Integer
    Dim crlf  As String
    Dim pr_num_recs As Integer

    If FlagNewRecordInProgress Then
        pr_num_recs = NumberOfRecords - 1
    Else
        pr_num_recs = NumberOfRecords
    End If

    Load PreviewFrm

    crlf$ = Chr$(13) + Chr$(10)

    buf$ = crlf$

    buf$ = buf$ + "Records sequenced by " + EditFrm.lblCurrentSortField.Caption + crlf$

    buf$ = buf$ + crlf$

    buf$ = buf$ + format_hdg$(0) + crlf$

    buf$ = buf$ + format_hdg$(1) + crlf$

    For i% = 1 To pr_num_recs
        buf$ = buf$ + format_line$(i%) + crlf$
    Next i%

    buf$ = buf$ + "--- " + Format$(pr_num_recs, "0") + " records ---" + crlf$

    PreviewFrm.txtReportPreview.Text = buf$
    PreviewFrm.Show 1

End Sub

Sub print_report ()
    Dim buf   As String
    Dim i     As Integer
    Dim tw    As Integer
    Dim pr_num_recs As Integer

    If FlagNewRecordInProgress Then
        pr_num_recs = NumberOfRecords - 1
    Else
        pr_num_recs = NumberOfRecords
    End If

    tw% = 0
    For i% = 1 To pr_num_fields%
        If i% > 1 Then
            tw% = tw% + 1
        End If
        tw% = tw% + pr_fld_widths(i%)
    Next i%

    Printer.Print US_CJustify(DatabaseFileName$, tw%, " ")
    Printer.Print ""
    Printer.Print US_CJustify("Records sequenced by " + EditFrm.lblCurrentSortField.Caption, tw%, " ")
    Printer.Print ""
    Printer.Print format_hdg$(0)
    Printer.Print format_hdg$(1)

    For i% = 1 To pr_num_recs
        Printer.Print format_line$(i%)
    Next i%

    Printer.Print ""
    Printer.Print Format$(pr_num_recs, "0") + " records"

    Printer.Print Chr$(12)

    Printer.EndDoc

End Sub