PC World Komputer 1998 November/pcwk_11_98a.iso/Wtestowe/Vistdtk/Install/Data.Z/VBinv.BAS

BASIC Source File | 1996-09-04 | 8.9 KB | 303 lines

Attribute VB_Name = "VBINV1"
' -----------------------------------------------------------------------------
' 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.
' -----------------------------------------------------------------------------

Option Explicit
Option Base 0

'--
'-- Win 3.1 API Helpers
'--

Global Const OFN_HIDEREADONLY = &H4&
Global Const OFN_OVERWRITEPROMPT = &H2&

Global Const IDYES = 6
Global Const IDNO = 7

Global Const MB_YESNO = 4
Global Const MB_ICONQUESTION = 32
Global Const MB_ICONEXCLAMATION = 48
Global Const MB_ICONINFORMATION = 64


Global Const G_VERSION = "v1.1"

'--
'--   The globals below store the delimter and separator lists used in
'-- exporting.  g_TextDelims() contains the total text delimiters available
'-- and g_TextDelimIdx indicates which one is to be used.  The same goes for
'-- field separators.  Both arrays use zero based indexes.
'--
'--   Finally there is a boolean Integer which decided if field names are to
'-- be included during exports.
'--

Global g_TextDelims()  As String
Global g_iTextDelimIdx As Integer

Global g_FieldSeps() As String
Global g_iFieldSepIdx As Integer

Global g_bIncFieldNames As Integer

Sub AppConnect()
'----------------------------------------
'--- AppConnect -------------------------
'--
'--   Connects to Visio.  If not present we end.
'--

    If vaoGetObject() <> visOK Then
        MsgBox "Visio could not be run.", MB_ICONEXCLAMATION, ""
        End
    End If
End Sub

Function ApplyTextDel(ByVal strField As String) As String
'------------------------------------
'--- ApplyTextDel -------------------
'--
'--   Formats a text field for output by adding text delimiters if needed and
'-- checking for embedded delimiters.
'--

    Dim strTemp As String, strDelim As String, I As Integer

    strDelim = g_TextDelims(g_iTextDelimIdx)

    If strDelim <> "" Then                      '-- If Using A Delimiter
        strTemp = strTemp + strDelim

        For I = 1 To Len(strField)
            Select Case Mid(strField, I, 1)
                Case strDelim:
                    strTemp = strTemp + strDelim
            End Select

            strTemp = strTemp + Mid(strField, I, 1)
        Next I

        strTemp = strTemp + strDelim
    Else
        strTemp = strField
    End If

    ApplyTextDel = strTemp
End Function

Sub BeginWaitCursor()
'------------------------------------
'--- BeginWaitCursor ----------------
'--
'--   Use this procedure in conjuction with EndWaitCursor to toggle the cursor
'-- between an hourglass, wait mode, and a regular pointer.
'--

  Screen.MousePointer = 11                      '-- Set Cursor To Hourglass
End Sub

Function ConvertDelimSep(strSepDel As String) As String
'------------------------------------
'--- ConvertDelimSep ----------------
'--
'--   Converts the text separator or delimiter passed to it into a human
'-- readable form.  Only useful for special control characters.
'--

    Select Case strSepDel
        Case "": ConvertDelimSep = "{none}"
        Case Chr$(9): ConvertDelimSep = "{tab}"
        Case Chr$(10): ConvertDelimSep = "{LF}"
        Case Chr$(13): ConvertDelimSep = "{CR}"
        Case Chr$(32): ConvertDelimSep = "{space}"
        Case Else: ConvertDelimSep = strSepDel
    End Select
End Function

Sub EndWaitCursor()
'------------------------------------
'--- EndWaitCursor ------------------
'--
'--   Use this procedure in conjuction with BeginWaitCursor to toggle the cursor
'-- between an hourglass, wait mode, and a regular pointer.
'--

  Screen.MousePointer = 0                   '-- Restore Default Mouse Pointer
End Sub

Sub ExportToFile(strFile As String)
'------------------------------------
'--- ExportToFile -------------------
'--
'--   Exports the grid to a file.
'--

    On Error GoTo FileExportErrHandler

    Dim iRow As Integer, iCol As Integer, Temp As String
    Dim iOldRow As Integer, iOldCol As Integer
    Dim iFileNum As Integer, ctlQueryGrid As Grid
    Dim sFieldSep As String

    Set ctlQueryGrid = frmMainWindow.ctlQueryGrid      '-- Alias Grid

    sFieldSep = g_FieldSeps(g_iFieldSepIdx)
    iFileNum = FreeFile

    Open strFile For Output As iFileNum

    iOldRow = ctlQueryGrid.Row                  '-- Save Last Row And Column
    iOldCol = ctlQueryGrid.Col

    If g_bIncFieldNames Then
        ctlQueryGrid.Row = 0                    '-- Move To Field Row

        For iCol = 0 To ctlQueryGrid.Cols - 1
            ctlQueryGrid.Col = iCol

            If iCol <> 0 Then Temp = Temp + sFieldSep

            Temp = Temp + ApplyTextDel(ctlQueryGrid.Text)
        Next iCol

        Temp = Temp + Chr$(13) + Chr$(10)       '-- Append CR/LF
        Print #iFileNum, Temp;                  '-- Print Field Names
    End If

    For iRow = 1 To ctlQueryGrid.Rows - 1
        ctlQueryGrid.Row = iRow
        Temp = ""

        For iCol = 0 To ctlQueryGrid.Cols - 1
            ctlQueryGrid.Col = iCol

            If iCol <> 0 Then Temp = Temp + sFieldSep

            Temp = Temp + ApplyTextDel(ctlQueryGrid.Text)
        Next iCol

        Temp = Temp + Chr$(13) + Chr$(10)       '-- Append CR/LF
        Print #iFileNum, Temp;                  '-- Output To File
    Next iRow

    ctlQueryGrid.Row = iOldRow                  '-- Restore Last Row And Column
    ctlQueryGrid.Col = iOldCol

    Close iFileNum
    Exit Sub

FileExportErrHandler:
    If iFileNum > 0 Then Close iFileNum
    Exit Sub
    Resume Next
End Sub

Function iIsWithin%(CompVal As Integer, LowerBnd As Integer, UpperBnd As Integer)
'------------------------------------
'--- iIsWithin ----------------------
'--
'--   Performs a range check on the two parameters.  Note, it checks that
'-- CompVal is equal to or within the bounds, not inbetween.
'--
'-- To overload this function just use a new prefix/suffix combination for the
'-- type you want to compare on and adjust the parameter types.
'--
'-- Parameters : CompVal      Value to apply range check to.
'--              LowerBnd     Lower bound of range.
'--              UpperBnd     Upper bound of range.
'--
'--
'--    Returns : BOOLEAN    True if
'--

  If CompVal >= LowerBnd And CompVal <= UpperBnd Then
    iIsWithin% = True
  Else
    iIsWithin% = False
  End If
End Function

Function iMax(Param1 As Integer, Param2 As Integer) As Integer
'------------------------------------
'--- iMax ---------------------------
'--
'--   Returns the largest object of the two passed.  To overload this function
'-- just use a new prefix/suffix combination for the type you want to compare
'-- on and adjust the parameter types.
'--
'-- Parameters : Param1, Param2     Values to compare.
'--
'--    Returns : The larger of the two values passed.
'--

  If Param1 < Param2 Then
    iMax = Param2
  Else
    iMax = Param1
  End If
End Function

Sub InitExportOptions()
'------------------------------------
'--- InitExportOptions --------------
'--
'--   Sets up the text delimiters and field separators for exporting.
'--

    g_bIncFieldNames = True                 '-- Default To Include Field Names

  '-- Setup Text Delimiters

    ReDim g_TextDelims(0 To 2)              '-- Setup Text Delimiters....
    g_TextDelims(0) = ""                    '--   Nothing
    g_TextDelims(1) = Chr$(34)              '--   Double Quote
    g_TextDelims(2) = "'"                   '--   Single Quote


    g_iTextDelimIdx = 0                     '-- Default To First Delimiter

  '-- Setup Field Separators

    ReDim g_FieldSeps(0 To 2)               '-- Setup Field Separators....
    g_FieldSeps(0) = Chr$(9)                '--   Tab
    g_FieldSeps(1) = ","                    '--   Comma
    g_FieldSeps(2) = " "                    '--   Space

    g_iFieldSepIdx = 0                      '-- Default To First Separator
End Sub

Function StripPath(strFileName As String) As String
'------------------------------------
'--- StripPath ----------------------
'--
'--   Strips the path out of a string passed.
'--
'-- Parameters : strFileName  String containing the file name whose path is to
'--                           be stripped out.
'--
'--    Returns : String containg file name with path stripped out.
'--

  Dim I As Integer
  Dim strFile As String

  strFile = strFileName                     '-- Default To No Path

  For I = Len(strFileName) To 1 Step -1
    If Mid$(strFileName, I, 1) = "\" Or Mid$(strFileName, I, 1) = ":" Then
      strFile = Right$(strFileName, Len(strFileName) - I)
      Exit For
    End If
  Next I

  StripPath = strFile                       '-- Return File Name
End Function