Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/arrays/vsflex/mrgout.frm

Visual Basic Form | 1995-06-19 | 9.0 KB | 308 lines

VERSION 2.00
Begin Form fTotals
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "FlexTotals"
   ClientHeight    =   6030
   ClientLeft      =   900
   ClientTop       =   900
   ClientWidth     =   6270
   Height          =   6495
   Left            =   810
   LinkTopic       =   "Form1"
   ScaleHeight     =   6030
   ScaleWidth      =   6270
   Top             =   525
   Width           =   6450
   Begin CheckBox Check1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Only Subtotals"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   210
      Left            =   3405
      TabIndex        =   3
      Top             =   690
      Width           =   1395
   End
   Begin CommandButton Command1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Rollups"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   345
      Left            =   4935
      TabIndex        =   2
      Top             =   585
      Width           =   990
   End
   Begin vsFlexArray fa
      BackColor       =   &H00FFFFFF&
      BackColorFixed  =   &H00800000&
      Cols            =   4
      DragIcon        =   MRGOUT.FRX:0000
      FixedCols       =   0
      FocusRect       =   0  'None
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Arial"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      ForeColorFixed  =   &H00FFFFFF&
      FormatString    =   "^Region           |^Product       |^Employee    |>Sales            "
      Height          =   4905
      HighLight       =   0  'Never
      Left            =   270
      MergeCells      =   2  'Restrict Rows
      ScrollTrack     =   -1  'True
      TabIndex        =   0
      Top             =   1050
      Width           =   5760
   End
   Begin Label Label1
      BackColor       =   &H00000000&
      BackStyle       =   0  'Transparent
      Caption         =   "Drag headings over other columns to reorganize the summary sheet. You can show sales TOTALS by region, product, or employee."
      FontBold        =   -1  'True
      FontItalic      =   0   'False
      FontName        =   "Arial"
      FontSize        =   9.75
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H00000000&
      Height          =   915
      Left            =   240
      TabIndex        =   1
      Top             =   75
      Width           =   5760
   End
Option Explicit
Sub Check1_Click ()
   Dim i%
   For i = 1 To fa.Rows - 1
      If Not fa.MergeRow(i) Then fa.RowHeight(i) = check1 - 1
   Next i
End Sub
Sub Command1_Click ()
   MsgBox "Double-click on the yellow cells to collapse or expand detailed information"
End Sub
Sub DoCalculateTotals ()
    '----------------------------------------------------------------
    ' Loop thru all the cells and calculate totals and subtotals
    '
    ' SaveGroupingKeys
    ' Do
    '    ForAllLevels
    '       if SameCategory then
    '          AddTotals
    '       Else
    '          PrintTotals
    '          Totals = 0
    '          SaveSortingKeys
    '       endif
    ' Loop
    Dim i%, j%, k%, h%
    Dim s$(), tot()
    Dim TotLevels%, TotOnColumn%
    TotLevels = 2
    TotOnColumn = 3
    ReDim tot(TotLevels), s(TotLevels)
    ' save first grouping keys
    i = 1
    For k = 0 To TotLevels - 1
      s(k) = fa.TextArray(fai(1, k))
    Next
    Do
        For h = 0 To TotLevels - 1
           If s(h) = fa.TextArray(fai(i, h)) Then
               tot(h) = tot(h) + Val(fa.TextArray(fai(i, TotOnColumn)))
           Else
               ' print totals
               For k = TotLevels - 1 To h Step -1
                  DoSubTotals k, s(k), tot(), i - (k - 1)
               Next
               i = i + TotLevels - h
               ' reset totals
               For k = h + 1 To TotLevels - 1
                  tot(k) = 0
               Next
               For k = 0 To h
                  tot(h) = fa.TextArray(fai(i, TotOnColumn))
               Next
               ' save new category index
               For k = 0 To TotLevels - 1
                 s(k) = fa.TextArray(fai(i, k))
               Next
           End If
        Next h

        i = i + 1
        If i >= fa.Rows Then
            For k = TotLevels - 1 To 0 Step -1
                  DoSubTotals k, s(k), tot(), i - (k - 1)
            Next
            Exit Do
        End If
    Loop
    fa.MergeCells = 2
End Sub
Sub DoFillData ()
    Dim i%
    Dim sreg$, sprod$, semp$, ssale$
    For i = fa.FixedRows To fa.Rows - 1
      sreg = Region()
      sprod = Product()
      semp = Employee()
      ssale = Sales()
      fa.TextArray(fai(i, 0)) = sreg
      fa.TextArray(fai(i, 1)) = sprod
      fa.TextArray(fai(i, 2)) = semp
      fa.TextArray(fai(i, 3)) = ssale
    Next
End Sub
Sub DoRemoveTotals ()
   Dim i%
    '-------------------------------------------------
    ' remove old totals
    i = 1
    While i < fa.Rows
        fa.RowHeight(i) = -1
        If fa.MergeRow(i) Then
            fa.RemoveItem i
        Else
            i = i + 1
        End If
    Wend
End Sub
Sub DoSort ()
    DoRemoveTotals
    ' sort
    fa.Col = 0
    fa.ColSel = fa.Cols - 1
    fa.Sort = 1
    DoCalculateTotals
End Sub
Sub DoSubTotals (Level%, s$, tot(), i%)
    Dim itm$, t$, k%
    t = Chr(9)
    Select Case Level
      Case 1   ' Second Column Totals
         itm = fa.TextArray(fai(i - 1, 0)) + t
         For k = Level To fa.Cols - 2
            itm = itm + s & " Total " & t
         Next k
         itm = itm + Format(tot(1), "#,##0.00")

         fa.AddItem itm, i
         fa.MergeRow(i) = True

         ' change visual attributes
         fa.Row = i
         fa.Col = 1
         fa.ColSel = 3
         fa.CellBackColor = &H80FFFF    ' yellow
         fa.CellFontBold = True
      Case 0
         itm = s + " Total"
         itm = itm + t + itm + t + itm + t + Format(tot(0), "#,##0.00")

         fa.AddItem itm, i
         fa.MergeRow(i) = True

         fa.Row = i
         fa.Col = 0
         fa.ColSel = 3
         fa.CellBackColor = 1
         fa.CellForeColor = RGB(255, 255, 255)
         fa.CellFontBold = True
    End Select

End Sub
Function Employee () As String
    Select Case (Rnd * 1000) Mod 3
        Case 0: Employee = "Mary"
        Case 1: Employee = "Sarah"
        Case Else: Employee = "Paula"
    End Select
End Function
Sub fa_DblClick ()
    Dim r%
    ' find totals row
    r = fa.MouseRow
    If r = 0 Then Exit Sub
    If Not fa.MergeRow(r) Then Exit Sub
    While Not fa.MergeRow(r)
        r = r - 1
    Wend
    ' expand or contract?
    r = r - 1
    If fa.RowHeight(r) = 0 Then
        Do While Not fa.MergeRow(r)
            fa.RowHeight(r) = -1
            r = r - 1
            If r = 0 Then Exit Do
        Loop
    Else
        Do While Not fa.MergeRow(r)
            fa.RowHeight(r) = 0
            r = r - 1
            If r = 0 Then Exit Do
        Loop
    End If
End Sub
Sub fa_DragDrop (Source As Control, X As Single, Y As Single)
    If fa.Tag = "" Then Exit Sub
    If fa.Tag = fa.MouseCol Then Exit Sub
    fa.Redraw = False
    fa.ColPosition(Val(fa.Tag)) = fa.MouseCol
    DoSort
    fa.Redraw = True
End Sub
Sub fa_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
    fa.Tag = ""
    If fa.MouseRow <> 0 Or fa.MouseCol = 3 Then Exit Sub
    fa.Tag = Str(fa.MouseCol)
    fa.Drag 1
End Sub
Function fai (r%, c%) As Integer
    fai = c + fa.Cols * r
End Function
Sub Form_Load ()
    DoFillData
    fa.MergeCol(0) = True
    fa.MergeCol(1) = True
    fa.MergeCol(2) = True
    fa.FillStyle = 1
    DoSort
    check1 = 0
End Sub
Function Product () As String
    Select Case (Rnd * 1000) Mod 4
        Case 0: Product = "Wahoos"
        Case 1: Product = "Foobars"
        Case Else: Product = "Applets"
    End Select
End Function
Function Region () As String
    Select Case (Rnd * 1000) Mod 4
        Case 0: Region = "North"
        Case 1: Region = "South"
        Case 2: Region = "West"
        Case Else: Region = "East"
    End Select
End Function
Function Sales () As String
    Sales = Format(Rnd * 10000, "#.00")
End Function