PC World Komputer 1999 January/pcwk_01_1999.iso/Wtestowe/Vistdstd/Install/Data.Z/Query.BAS

BASIC Source File | 1996-09-04 | 10.9 KB | 338 lines

Attribute VB_Name = "QUERY"
' -----------------------------------------------------------------------------
' Copyright (C) 1993-1996 Visio Corporation. All rights reserved.
'
' You have a royalty-free right to use, modify, reproduce and distribute
' the Sample Application Files (and/or any modified version) in any way
' you find useful, provided that you agree that Visio has no warranty,
' obligations or liability for any Sample Application Files.
' -----------------------------------------------------------------------------
'-- Description : Contains the database support.  The grid control serves as
'--               the viewport onto a query displaying the inventory. All
'--               aspects of the query are maintained here and no direct
'--               access to the grid should occur unless otherwise specified.
'--

Option Explicit                                 '-- All Variable Explicit!

Dim iDBaseInit As Integer

Dim m_iSortIndex As Integer

Dim m_dbDatabase As Database
Dim m_MainTable As New TableDef
Dim m_MainTableIdx As New Index

Const QI_DBASE_FILE_NAME = "~vbinv.mdb"
Const QI_MTABLE_NAME = "Shapes_Table"
Const QI_MTABLE_IDX_NAME = "MTable_Index"

Private Sub AddTableField(iIndex As Integer)
'------------------------------------
'--- AddTableField ------------------
'--
'--   Adds a field to the main table.
'--

    Dim TempField As New Field

    TempField.Name = FieldNames(iIndex)
    TempField.Type = dbText
    TempField.Size = 255

    m_MainTable.FIELDS.Append TempField
End Sub

Private Sub ClearGrid()
'------------------------------------
'--- ClearGrid ----------------------
'--
'--   Clears the query grid, erasing any query currently displayed.  To clear
'-- the grid we use RemoveItem on all indexes 1 and greater.  Don't remove
'-- index 0 as it is the fixed title row.  Because we can't remove the last
'-- row I instead clear out the last row's (Row = 1) column text.
'--

  Dim iRow As Integer, iCol As Integer

  For iRow = (frmMainWindow.ctlQueryGrid.Rows - 1) To 2 Step -1
    frmMainWindow.ctlQueryGrid.RemoveItem iRow      '--   Remove Row
  Next iRow

  frmMainWindow.ctlQueryGrid.Row = 1                '-- Go To First Row

  For iCol = 0 To frmMainWindow.ctlQueryGrid.Cols - 1  '-- For Every Column...
    frmMainWindow.ctlQueryGrid.Col = iCol              '--   Go To Column
    frmMainWindow.ctlQueryGrid.Text = ""               '--   Reset Contents
  Next iCol
End Sub

Private Sub CopyShapesToTable(shpsShapeColl As Visio.Shapes)
'------------------------------------
'--- CopyShapesToTable --------------
'--
'--   Copies the current pages shape collection into the database main table.
'--
'--

    Dim I As Integer, strStatus As String
    Dim MTable As Table, shpCurshape As Visio.Shape

    Set MTable = m_dbDatabase.OpenTable(QI_MTABLE_NAME)

    EmptyTable MTable

    For I = 1 To shpsShapeColl.Count              '-- Loop Through Shapes...
        strStatus = "Retrieving Shape " & Str$(I) & " of "
        strStatus = strStatus & Str$(shpsShapeColl.Count)
        StatusLineMsg strStatus                     '-- Update Status Line

        Set shpCurshape = shpsShapeColl(I)          '-- Get Next Shape

        MTable.AddNew

        MTable.FIELDS(IDX_NAME) = "" & shpCurshape.Name & " "
        MTable.FIELDS(IDX_DATA1) = "" & shpCurshape.Data1 & " "
        MTable.FIELDS(IDX_DATA2) = "" & shpCurshape.Data2 & " "
        MTable.FIELDS(IDX_DATA3) = "" & shpCurshape.Data3 & " "

        If shpCurshape.Type = visTypeShape Or shpCurshape.Type = visTypeGroup Then
            MTable.FIELDS(IDX_TEXT) = "" & shpCurshape.Text & " "
        Else
            MTable.FIELDS(IDX_TEXT) = " "
        End If

        MTable.FIELDS(IDX_WIDTH) = "" & shpCurshape.Cells("Width") & " "
        MTable.FIELDS(IDX_HEIGHT) = "" & shpCurshape.Cells("Height") & " "

        MTable.Update
    Next I

    MTable.Close
    ClearStatusLine
End Sub

Private Sub CopyTableToGrid()
'------------------------------------
'--- CopyTableToGrid ----------------
'--
'--   Copies the shape table to the query grid by first sizing it and then
'-- copying each record into a row.
'--

    Dim I As Integer, MTable As Dynaset, ctlGrid As Grid, iCol As Integer

    Set MTable = m_dbDatabase.CreateDynaset(QI_MTABLE_NAME)
    Set ctlGrid = frmMainWindow.ctlQueryGrid

    If MTable.RecordCount = 0 Then Exit Sub

    SetupColumns                                  '-- Display Col Labels

    MTable.Sort = "[" & IncludeNames(m_iSortIndex) & "] Asc"
    Set MTable = MTable.CreateDynaset()
    MTable.MoveFirst                              '-- Move To Record

    ctlGrid.Rows = MTable.RecordCount + 1         '-- Set Grid Rows

    For I = 1 To MTable.RecordCount               '-- Loop Through Shapes...
        ctlGrid.Row = I                           '--   Go To Next Row

        For iCol = 0 To IncludeCount() - 1
            ctlGrid.Col = iCol
            ctlGrid.Text = MTable.FIELDS(IncludeNames(iCol)).Value
        Next iCol

        MTable.MoveNext                           '--   Go To Next Record
    Next I

    MTable.Close
    ClearStatusLine
End Sub

Private Sub EmptyTable(TheTable As Table)
'------------------------------------
'--- EmptyTable ---------------------
'--
'--   Deletes all records from the table passed.
'--

    If TheTable.RecordCount > 0 Then
        TheTable.MoveFirst

        Do Until TheTable.EOF
            TheTable.Delete
            TheTable.MoveNext
        Loop
    End If
End Sub

Private Sub FitColumns()
'------------------------------------
'--- FitColumns ---------------------
'--
'--   Fits the columns of the grid to the data within.  Does so by iterating
'-- through each cell in a column, saving the largest text width and setting
'-- the width to it.  We also add a leading space iLead for clipping.
'--

    Dim iCol As Integer, iRow As Integer, twipsBiggest As Integer
    Dim strTemp As String, iLead As Integer
    Dim ctlGrid As Grid

    Set ctlGrid = frmMainWindow.ctlQueryGrid    '-- Alias Grid Control
    iLead = 90                                  '-- 1/16" = 90 * 1/(72*20)

    For iCol = 0 To (ctlGrid.Cols - 1)          '-- For Every Column...
        ctlGrid.Col = iCol                      '--   Set Next Column
        twipsBiggest = 1                        '--   Reset For Each Column

        For iRow = 0 To (ctlGrid.Rows - 1)      '--   For Every Row In Column...
            ctlGrid.Row = iRow                  '--     Set Next Row
            strTemp = ctlGrid.Text              '--     Get Cell Text

            twipsBiggest = iMax(frmMainWindow.TextWidth(strTemp), twipsBiggest)
        Next iRow

        ctlGrid.ColWidth(iCol) = twipsBiggest + iLead
    Next iCol
End Sub

Private Function InitDatabase() As Integer
'------------------------------------
'--- InitDatabase -------------------
'--
'--   Initializes the local access database and table for inventory.
'--

    Dim I As Integer

    InitDatabase = True                             '-- Default To True

    If iDBaseInit Then Exit Function

    On Error GoTo KillErrorHandler
    Kill QI_DBASE_FILE_NAME

    On Error GoTo InitDBaseErrHandler
    StatusLineMsg "Creating New Database..."
    Set m_dbDatabase = CreateDatabase(QI_DBASE_FILE_NAME, dbLangGeneral)

    m_MainTableIdx.Name = QI_MTABLE_IDX_NAME
    m_MainTableIdx.Unique = False
    m_MainTableIdx.Primary = True
    m_MainTableIdx.FIELDS = FieldNames(IDX_NAME)

    m_MainTable.Name = QI_MTABLE_NAME

    StatusLineMsg "Adding Database Fields..."
    For I = 0 To FieldCount() - 1
        AddTableField I
    Next I

    m_MainTable.Indexes.Append m_MainTableIdx
    m_dbDatabase.TableDefs.Append m_MainTable

    ClearStatusLine
    m_iSortIndex = 0
    iDBaseInit = True
    Exit Function

KillErrorHandler:
    Resume Next

InitDBaseErrHandler:
    MsgBox "Error Creating Database"
    InitDatabase = False
    ClearStatusLine

    Exit Function
    Resume 0
End Function

Sub RePaint()
'------------------------------------
'--- RePaint ------------------------
'--
'--   Repaints the database grid control with the current table contents.  Does
'-- not perform a requery.
'--

  If Not iDBaseInit Then Exit Sub

  BeginWaitCursor                                   '-- Display Wait Cursor

  ClearGrid                                         '-- Clear Current Query
  SetupColumns                                      '-- Grid Column Headings
  CopyTableToGrid                                   '-- Display Query
  FitColumns                                        '-- Fit Grid Columns

  EndWaitCursor                                     '-- Remove Wait Cursor
End Sub

Sub ReQuery(iDocIndex As Integer, iPageIndex As Integer)
'------------------------------------
'--- ReQuery ------------------------
'--
'-- Requery is responsible for reading in the current pages' shapes.  Once
'-- the table is updated the grid is repainted.
'--

    Dim docDoc As Visio.DOCUMENT, shpsShapeColl As Visio.Shapes

    BeginWaitCursor                                 '-- Display Wait Cursor

    If Not InitDatabase() Then                      '-- Error During Init...
        EndWaitCursor                               '--   Reset Wait Cursor
        Exit Sub                                    '--   Get Outa Here
    End If

    Dim MTable As Table
    Set MTable = m_dbDatabase.OpenTable(QI_MTABLE_NAME)
    EmptyTable MTable

    If Not (iDocIndex > 0 And iPageIndex > 0) Then Exit Sub

    AppConnect
    Set docDoc = g_appVisio.Documents(iDocIndex)  '--  "  Document
    Set shpsShapeColl = docDoc.Pages(iPageIndex).Shapes

    CopyShapesToTable shpsShapeColl                 '-- Create Shapes Table

    EndWaitCursor                                   '-- Remove Wait Cursor
End Sub

Sub SetSort(iNewIndex As Integer)
'------------------------------------
'--- SetSort ------------------------
'--
'--   Sets the sort index for the table.
'--
'-- Parameters : iNewIndex - 0 based index to sort by.
'--

    m_iSortIndex = iNewIndex
End Sub

Private Sub SetupColumns()
'------------------------------------
'--- SetupColumns -------------------
'--
'--   Handles displaying the column headings for the query grid by setting the
'-- grid width to the number of fields and placing the field names into each
'-- column header.
'--

  Dim iCol As Integer

  frmMainWindow.ctlQueryGrid.Cols = IncludeCount()  '-- Set Grid Columns
  frmMainWindow.ctlQueryGrid.Row = 0                '-- Use Top Row

  For iCol = 0 To IncludeCount() - 1                '-- For Every Column...
    frmMainWindow.ctlQueryGrid.Col = iCol           '--   Select Column

    frmMainWindow.ctlQueryGrid.Text = IncludeNames(iCol)
  Next iCol
End Sub