PC Shareware 2000 January/PCShareware-1-00.iso/trials/Fc7/ABC.Z/EXCELDAT.FRM

Visual Basic Form | 1996-12-16 | 11.4 KB | 356 lines

VERSION 4.00
Begin VB.Form ExcelSample
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Excel Data DEMO"
   ClientHeight    =   4125
   ClientLeft      =   3480
   ClientTop       =   1800
   ClientWidth     =   4815
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   4815
   Icon            =   "EXCELDAT.frx":0000
   Left            =   3420
   LinkTopic       =   "Form1"
   ScaleHeight     =   4125
   ScaleWidth      =   4815
   Top             =   1170
   Width           =   4935
   Begin VB.CommandButton ReadData
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "&Read Data"
      Height          =   375
      Left            =   3360
      TabIndex        =   8
      Top             =   3120
      Width           =   1215
   End
   Begin VB.ListBox ExcelFields
      Appearance      =   0  'Flat
      Height          =   1590
      Left            =   360
      MultiSelect     =   2  'Extended
      TabIndex        =   3
      TabStop         =   0   'False
      Top             =   1560
      Width           =   2655
   End
   Begin VB.CommandButton Browse
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "&Browse..."
      Height          =   375
      Left            =   3240
      TabIndex        =   2
      Top             =   600
      Width           =   1215
   End
   Begin VB.CommandButton Quit
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Cancel          =   -1  'True
      Caption         =   "&Quit"
      Height          =   375
      Left            =   3360
      TabIndex        =   1
      Top             =   1320
      Width           =   1215
   End
   Begin VB.CommandButton MakeChart
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Make &Chart"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   3360
      TabIndex        =   0
      Top             =   3600
      Width           =   1215
   End
   Begin VB.Frame Frame1
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      Caption         =   "Source Excel Data File"
      ForeColor       =   &H80000008&
      Height          =   975
      Left            =   240
      TabIndex        =   4
      Top             =   120
      Width           =   4335
      Begin VB.TextBox DataFilename
         Appearance      =   0  'Flat
         Height          =   300
         Left            =   120
         TabIndex        =   5
         Text            =   "DataFilename"
         Top             =   510
         Width           =   2715
      End
   End
   Begin VB.Frame Frame2
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0C0&
      Caption         =   "Fields"
      ForeColor       =   &H80000008&
      Height          =   2775
      Left            =   240
      TabIndex        =   6
      Top             =   1200
      Width           =   2895
      Begin VB.Label HintText
         Appearance      =   0  'Flat
         BackColor       =   &H00C0C0C0&
         Caption         =   "To multi-select, click on items in the list while holding the CTRL key."
         ForeColor       =   &H80000008&
         Height          =   615
         Left            =   120
         TabIndex        =   7
         Top             =   2040
         Width           =   2655
      End
   End
   Begin MSComDlg.CommonDialog CMDialog1
      Left            =   3720
      Top             =   2160
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Menu Help
      Caption         =   "Help"
      Begin VB.Menu About
         Caption         =   "About"
      End
   End
Attribute VB_Name = "ExcelSample"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Const xlR1C1 = -4150
Dim TraderData(40, 15) As String
Dim Record_Count As Integer
Dim CreateFailed As Integer
Dim Col As Integer, Row As Integer
Dim ExcelApp As Object
Private Sub About_Click()
    Load AboutForm
    AboutForm.Visible = True
    ExcelSample.Enabled = False
End Sub
Private Sub Browse_Click()
    On Error GoTo ErrHandler2        'CancelError is True
                                    'Set filters
    CMDialog1.Filter = "Excel Files (*.xls)|*.XLS|Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
    CMDialog1.FilterIndex = 1       'Set default filter
    CMDialog1.Action = 1            'Display the Open dialog box
    DataFilename = CMDialog1.filename
ErrHandler2:                         'User pressed Cancel button
    Exit Sub
End Sub
Private Sub CreateExcel()
    On Error GoTo ExcelFail
    CreateFailed = False
    Set ExcelApp = CreateObject("Excel.Application")
    Exit Sub
ExcelFail:
    Call HourGlassOff
    MsgBox "You must have MS Excel installed to run this DEMO!", 16, "Critical Error"
    CreateFailed = True
    Resume Next
End Sub
Private Sub DataFilename_Change()
    Call ValidateFilename
End Sub
Private Sub Form_Load()
    DataFilename = App.Path + "\ABCSAMPL.XLS"
End Sub
Private Sub GetDataFile(DataFile As String)
    Dim ExcelSheet As Object, xlWorkbooks As Object
    Dim Cell As Object
    Dim Rowz As Integer, Colz As Integer
    ' Load up Excel - sets ExcelApp Object
    Call CreateExcel
    If CreateFailed Then Exit Sub
    ExcelApp.Application.Visible = True
    Set xlWorkbooks = ExcelApp.Workbooks
    xlWorkbooks.Open DataFile
    Set ExcelSheet = ExcelApp.ActiveSheet
    ExcelSheet.Activate
    ExcelApp.ReferenceStyle = xlR1C1
    ExcelSample.Visible = False
    ' Find the first row with data
    ' (check only the first 256 rows)
    For FirstRow = 1 To 256
        Set Cell = ExcelSheet.Cells(FirstRow, 1)
        Cell.Select
        If Not Cell.Value = Empty Then Exit For
    Next FirstRow
    ' Find the last row with data
    ' (check only the first 256 rows)
    For Rows = FirstRow To FirstRow + 256
        Set Cell = ExcelSheet.Cells(Rows, 1)
        Cell.Select
        If Cell.Value = Empty Then
            Rows = Rows - FirstRow - 1
            Exit For
        End If
    Next Rows
    ' Now count the number of columns
    ' (Again only up to 256)
    For Col = 1 To 256
        Set Cell = ExcelSheet.Cells(FirstRow, Col)
        Cell.Select
        If Cell.Value = Empty Then
            Col = Col - 1
            Exit For
        End If
    Next Col
    DoEvents
    Call HourGlassOn
    For Rowz = 1 To Rows + 1
        For Colz = 1 To Col
            Set Cell = ExcelSheet.Cells(FirstRow + Rowz - 1, Colz)
            Cell.Select
            TraderData(Rowz, Colz) = Cell.Value
        Next Colz
    Next Rowz
    Call HourGlassOff
    Record_Count = Rows
    For Colz = 1 To Col
        ExcelFields.AddItem TraderData(1, Colz)
    Next Colz
    ExcelSheet.Application.DisplayAlerts = False
    ExcelSheet.Application.ActiveWorkbook.Close
    ExcelApp.Application.Quit
    ExcelSample.Visible = True
    MakeChart.Enabled = True
    Call SelectAll(ExcelFields)
End Sub
Private Sub GetExcel()
    On Error GoTo TryCreate
    Call HourGlassOn
    Set ExcelApp = GetObject(, "Excel.Application")
    Call HourGlassOff
    Exit Sub
TryCreate:
    Call CreateExcel
    Resume Next
End Sub
Private Sub HourGlassOff()
    Screen.MousePointer = 0
End Sub
Private Sub HourGlassOn()
    Screen.MousePointer = 11
End Sub
Private Sub MakeChart_Click()
Dim ABC As Object, Chart As Object, Field1 As Object, Field2 As Object
Dim X As Integer, Y As Integer, Index_1 As Integer, ShapeCount As Integer
Dim Line1 As Object, FieldNameIndex As Integer
Static Fields() As Object
Static Shape() As Object
    Dim Units as Integer
    ' Reset counters for the PercentGauge
    TotalLoops = 3
    CurrentLoop = 0
    ReDim Fields(ExcelFields.ListCount)
    'Start ABC
    Call HourGlassOn
    Set ABC = CreateObject("ABCFlow.Application")
    ABC.Visible = True
    ABC.FieldViewerVisible = False
    Call HourGlassOff
    'Make a new chart
    Set Chart = ABC.New
    Units = Chart.Units ' save current units to restore them later
    Chart.Units = 0     ' set units to inches for all measurements below
    'Set up some parameters for chart
    Chart.DrawPositionX = 1
    Chart.DrawSpacingX = 1.5
    Chart.FieldNamesHidden = True
    Chart.NoRepaint = True
    Rem Use right angle lines
    Chart.CurrentLineRouting = 1
    ABC.Activate         ' Bring FlowCharter to the foreground
    ABC.PercentGauge
    'Get the shape count
    ReDim Shape(Record_Count)
    ShapeCount = Record_Count
    For X = 1 To ShapeCount
        If ABC.PercentGaugeCancelled Then Exit For
        'Draw shapes
        Set Shape(X) = Chart.DrawShape("FlowCharter Palettes\Standard\Operation")
        Shape(X).Shape.FillColor = ABC.Blue
        'Create another row of shapes
        If (X Mod 5) = 0 Then
            Chart.DrawPositionX = 1
            Chart.DrawPositionY = Chart.DrawPositionY + 2
        End If
        ABC.PercentGaugeValue = ((X / ShapeCount) * (1 / TotalLoops) + CurrentLoop / TotalLoops) * 100
    Next X
    CurrentLoop = CurrentLoop + 1
    'Draw Lines
    For X = 2 To ShapeCount
        If ABC.PercentGaugeCancelled Then Exit For
        Set Line1 = Chart.DrawLine(Shape(X), Shape(X - 1))
        Line1.Line_.DestArrowStyle = 0
        ABC.PercentGaugeValue = ((X / ShapeCount) * (1 / TotalLoops) + CurrentLoop / TotalLoops) * 100
    Next X

    'Position fields below shapes
    Chart.FieldPlacement = 3
    'Add Field Ttemplates to Chart
    For X = 0 To ExcelFields.ListCount - 1
        If ExcelFields.Selected(X) Then
            Set Fields(X) = Chart.FieldTemplates.Add(ExcelFields.List(X))
            'Format field as text
            Fields(X).Format = 0
        End If
    Next X
    CurrentLoop = CurrentLoop + 1
    'Put Field data into shapes
    For X = 1 To ShapeCount
        If ABC.PercentGaugeCancelled Then Exit For
        For Y = 1 To Col
            Shape(X).FieldValues.Item(TraderData(1, Y)).Value = TraderData(X + 1, Y)
        Next Y
        ABC.PercentGaugeValue = ((X / ShapeCount) * (1 / TotalLoops) + CurrentLoop / TotalLoops) * 100
    Next X
    ABC.HidePercentGauge
    Chart.Units = Units
    Chart.NoRepaint = False
    Chart.Repaint
End Sub
Private Sub Quit_Click()
    Unload ExcelSample
End Sub
Private Sub ReadData_Click()
    ExcelFields.Clear
    GetDataFile (DataFilename) 'Open the selected file
End Sub
Private Sub SelectAll(ListBox As ListBox)
    For it = 0 To ListBox.ListCount - 1
        ListBox.Selected(it) = True
    Next it
End Sub
Private Sub ValidateFilename()
   On Error Resume Next
   Attr = GetAttr(DataFilename)
   If Err Then
        ReadData.Enabled = False
   Else
        ReadData.Enabled = True
   End If
End Sub