Liren Large Software Subsidy 10/10.iso/l/l406/4.ddi/VDMDI.FR_/VDMDI.bin

Visual Basic Form | 1992-10-21 | 18.9 KB | 654 lines

VERSION 2.00
Begin MDIForm VDMDI
   Caption         =   "Visual Data"
   Height          =   6900
   Icon            =   VDMDI.FRX:0000
   Left            =   105
   LinkTopic       =   "MDIForm1"
   Top             =   90
   Width           =   9135
   Begin PictureBox Picture1
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      Height          =   240
      Left            =   0
      ScaleHeight     =   210
      ScaleWidth      =   8985
      TabIndex        =   9
      Top             =   5970
      Width           =   9015
      Begin Label cMsg
         BackColor       =   &H00C0C0C0&
         Caption         =   "Ready"
         Height          =   200
         Left            =   120
         TabIndex        =   10
         Top             =   0
         Width           =   9372
      End
   End
   Begin PictureBox ToolBar
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      Height          =   420
      Left            =   0
      ScaleHeight     =   396
      ScaleMode       =   0  'User
      ScaleWidth      =   9002.344
      TabIndex        =   0
      Top             =   0
      Width           =   9015
      Begin TextBox cQueryTimeout
         Height          =   288
         Left            =   4319
         TabIndex        =   7
         Text            =   "5"
         Top             =   48
         Width           =   995
      End
      Begin CommandButton QueryButton
         Caption         =   "&Query Builder"
         Height          =   336
         Left            =   5400
         TabIndex        =   6
         Top             =   24
         Visible         =   0   'False
         Width           =   1331
      End
      Begin CommandButton BeginButton
         Caption         =   "&BeginTransaction"
         Height          =   336
         Left            =   6840
         TabIndex        =   5
         Top             =   24
         Visible         =   0   'False
         Width           =   1812
      End
      Begin CommandButton RollBackButton
         Caption         =   "&Rollback"
         Height          =   336
         Left            =   7920
         TabIndex        =   4
         Top             =   24
         Visible         =   0   'False
         Width           =   971
      End
      Begin CommandButton CommitButton
         Caption         =   "&Commit"
         Height          =   336
         Left            =   6840
         TabIndex        =   3
         Top             =   24
         Visible         =   0   'False
         Width           =   971
      End
      Begin OptionButton cTableView
         BackColor       =   &H00C0C0C0&
         Caption         =   "Table View"
         Height          =   252
         Left            =   1680
         TabIndex        =   2
         Top             =   50
         Width           =   1331
      End
      Begin OptionButton cSingleRecord
         BackColor       =   &H00C0C0C0&
         Caption         =   "Single Record"
         Height          =   252
         Left            =   120
         TabIndex        =   1
         Top             =   50
         Value           =   -1  'True
         Width           =   1572
      End
      Begin Label QueryTimeoutLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "QueryTimeout:"
         Height          =   252
         Left            =   2999
         TabIndex        =   8
         Top             =   100
         Width           =   1331
      End
   End
   Begin Menu DBMenu
      Caption         =   "&File"
      Begin Menu DBOpen
         Caption         =   "&Open DataBase..."
         Shortcut        =   ^O
      End
      Begin Menu DBClose
         Caption         =   "&Close DataBase"
         Visible         =   0   'False
      End
      Begin Menu DBProperties
         Caption         =   "&Properties..."
         Visible         =   0   'False
      End
      Begin Menu DBNew
         Caption         =   "&New (RegisterDataBase)..."
      End
      Begin Menu menubar1
         Caption         =   "-"
      End
      Begin Menu DBAbout
         Caption         =   "&About"
      End
      Begin Menu Exit
         Caption         =   "E&xit"
         Shortcut        =   ^X
      End
   End
   Begin Menu TblMenu
      Caption         =   "&Table"
      Visible         =   0   'False
      Begin Menu TblRefresh
         Caption         =   "&Refresh Table List"
         Shortcut        =   ^R
      End
      Begin Menu TblCopyStruct
         Caption         =   "&Copy Structure..."
      End
      Begin Menu TblDelete
         Caption         =   "&Delete Table"
      End
      Begin Menu TblZap
         Caption         =   "Remove &All Records"
      End
   End
   Begin Menu UtilMenu
      Caption         =   "&Utility"
      Visible         =   0   'False
      Begin Menu UtilCloseAll
         Caption         =   "&Close All Dynasets"
      End
      Begin Menu UtilReplace
         Caption         =   "&Global Replace..."
      End
      Begin Menu UtilExport
         Caption         =   "&Export to Tab Delimited File..."
      End
   End
   Begin Menu PrefMenu
      Caption         =   "&Preferences"
      Begin Menu PrefOpenOnStartup
         Caption         =   "&Open Last DataBase on Startup"
      End
      Begin Menu PrefFilter
         Caption         =   "&Table List Filter..."
      End
      Begin Menu PrefMaxRows
         Caption         =   "&Max Table View Rows"
      End
   End
   Begin Menu WinMenu
      Caption         =   "&Window"
      Begin Menu WinTile
         Caption         =   "&Tile"
      End
      Begin Menu WinCascade
         Caption         =   "&Cascade"
      End
      Begin Menu WinArrange
         Caption         =   "&Arrange Icons"
      End
      Begin Menu menubar2
         Caption         =   "-"
      End
      Begin Menu WinTables
         Caption         =   "Ta&bles"
      End
      Begin Menu WinSQL
         Caption         =   "&SQL"
      End
   End
Option Explicit
Sub BeginButton_Click ()
  On Error GoTo BeginErr
  gCurrentDB.BeginTrans
  gfDBChanged = False
  gfTransPending = True
  BeginButton.Visible = False
  CommitButton.Visible = True
  RollBackButton.Visible = True
  CommitButton.SetFocus
  GoTo BeginTransEnd
BeginErr:
  ShowError
  Resume BeginTransEnd
BeginTransEnd:
End Sub
Sub CommitButton_Click ()
  On Error GoTo CommitErr
  gCurrentDB.CommitTrans
  gfDBChanged = False
  gfTransPending = False
  BeginButton.Visible = True
  CommitButton.Visible = False
  RollBackButton.Visible = False
  BeginButton.SetFocus
  GoTo DBCommitTransEnd
CommitErr:
  ShowError
  Resume DBCommitTransEnd
DBCommitTransEnd:
End Sub
Sub cQueryTimeout_KeyPress (KeyAscii As Integer)
  'throw away non numeric chars
  'allow backspace
  If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then
    Beep
    KeyAscii = 0
  End If
End Sub
Sub cQueryTimeout_LostFocus ()
  On Error GoTo QTErr
  'try to set the new value
  gCurrentDB.QueryTimeout = Val(cQueryTimeout)
  GoTo QTEnd
QTErr:
  ShowError
  'reset the form control after the error
  cQueryTimeout = gCurrentDB.QueryTimeout
  Resume QTEnd
QTEnd:
End Sub
Sub DBAbout_Click ()
  MsgBar "Press any key to Close About Box", False
  AboutBox.Show MODAL
  MsgBar "", False
End Sub
Sub DBClose_Click ()
  On Error GoTo DBCloseErr
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
      gfDBChanged = False
    Else
      If MsgBox("RollBack All changes?", MSGBOX_TYPE) = YES Then
        gCurrentDB.Rollback
        gfDBChanged = False
      Else
        Beep
        MsgBox "Can't Close with Transactions Pending!", 48
        Exit Sub
      End If
    End If
  End If
  gCurrentDB.Close
  fTables.Caption = "<none>"
  fTables.cTableList.Clear
  DBProperties.Visible = False
  DBClose.Visible = False
  TblMenu.Visible = False
  UtilMenu.Visible = False
  QueryButton.Visible = False
  BeginButton.Visible = False
  gfDBOpenFlag = False
  gfTransPending = False
  CloseAllDynasets
  Unload fQuery
  GoTo DBCloseEnd
DBCloseErr:
  ShowError
  Resume DBCloseEnd
DBCloseEnd:
End Sub
Sub DBNew_Click ()
  Dim driver As String
  On Error GoTo DBNErr
  MsgBar "Enter New Database Parameters", False
  'driver must be an valid entry in ODBCINST.INI
  driver = InputBox("Enter Driver Name from ODBCINST.INI File:", "Driver Name", DEFAULTDRIVER)
'  driver = DEFAULTDRIVER
  RegisterDatabase "", driver, False, ""
  GoTo DBNEnd
DBNErr:
  ShowError
  Resume DBNEnd
DBNEnd:
  MsgBar "", False
End Sub
Sub DBOpen_Click ()
   If gfDBOpenFlag = True Then
     Call DBClose_Click
   End If
   If gfDBOpenFlag = True Then
     Beep
     MsgBox "You must Close First!", 48
   Else
     fOpenDB.Show MODAL
   End If
   If gfDBOpenFlag = True Then
     DBProperties.Visible = True
     DBClose.Visible = True
     TblMenu.Visible = True
     UtilMenu.Visible = True
     RefreshTables fTables.cTableList
   End If
End Sub
Sub DBProperties_Click ()
   Dim f As New fDataBox
   Dim s As String, t As String
   Dim i As Integer
   On Error GoTo PropErr
   f.Caption = gCurrentDB.Name + " Properties"
   f.Top = Top + 900
   f.Left = Left + 100
   'process the connect string
   t = gCurrentDB.Connect
   i = 1
   While i <= Len(t) + 1
     If Mid(t, i, 1) = ";" Or i = Len(t) + 1 Then
       f.cData.AddItem s
       s = ""
     Else
       s = s + Mid(t, i, 1)
     End If
     i = i + 1
   Wend
   f.cData.AddItem ""
   'set the value of the updatable flag
   If gCurrentDB.Updatable Then
     s = TRUE_ST
   Else
     s = FALSE_ST
   End If
   f.cData.AddItem "Updatable = " + s
   'set the value of the transactions flag
   If gCurrentDB.Transactions Then
     s = TRUE_ST
   Else
     s = FALSE_ST
   End If
   f.cData.AddItem "Transactions = " + s
   f.cData.AddItem "Query Timeout = " + cQueryTimeout + " seconds"
   f.Show
  GoTo DBPropEnd
PropErr:
  ShowError
  Resume DBPropEnd
DBPropEnd:
End Sub
Sub Exit_Click ()
  Unload Me
End Sub
Sub MDIForm_Load ()
  Dim st As String
  Dim x As Integer
  gwMaxGridRows = Val(GetINIString("MaxRows", "250"))
  cQueryTimeout = Val(GetINIString("QueryTimeout", "5"))
  st = GetINIString("ViewMode", "Single")
  If UCase(st) = "SINGLE" Then
    cSingleRecord = True
  Else
    cTableView = True
  End If
  st = GetINIString("OpenOnStartup", "No")
  If UCase(st) = "YES" Then
    PrefOpenOnStartup.Checked = True
  Else
    PrefOpenOnStartup.Checked = False
  End If
  'get the last used database out of the INI file
  gstDBNAme = GetINIString("Server", "")
  gstDataBase = GetINIString("DataBase", "")
  gstUserNAme = GetINIString("UserName", "")
  gstPassword = GetINIString("Password", "")
  If PrefOpenOnStartup.Checked = True Then
    SendKeys "%FO{Enter}"   'force open database
  Else
    SendKeys "%FO"   'force open database dialog
  End If
  x = Val(GetINIString("WindowState", "2"))
  If x <> 1 Then
    WindowState = x
  Else
    WindowState = 0
  End If
  If x = 0 Then
    x = Val(GetINIString("WindowLeft", "0"))
    Left = x
    x = Val(GetINIString("WindowTop", "0"))
    Top = x
    x = Val(GetINIString("WindowWidth", "9135"))
    Width = x
    x = Val(GetINIString("WindowHeight", "6900"))
    Height = x
  End If
  Me.Show
  fSQL.Show
End Sub
Sub MDIForm_QueryUnload (Cancel As Integer, UnloadMode As Integer)
  Dim x As Integer
  Dim st As String
  On Error Resume Next
  x = OSWritePrivateProfileString("VISDATA", "Server", gstDBNAme, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "DataBase", gstDataBase, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "UserName", gstUserNAme, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "Password", gstPassword, "VISDATA.INI")
  If PrefOpenOnStartup.Checked = True Then
    st = "Yes"
  Else
    st = "No"
  End If
  x = OSWritePrivateProfileString("VISDATA", "OpenOnStartup", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "WindowState", CStr(WindowState), "VISDATA.INI")
  If WindowState <> 2 Then
    x = OSWritePrivateProfileString("VISDATA", "WindowTop", CStr(Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowLeft", CStr(Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowWidth", CStr(Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "WindowHeight", CStr(Height), "VISDATA.INI")
  End If
  x = OSWritePrivateProfileString("VISDATA", "TableFilter", gstTableFilter, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "MaxRows", CStr(gwMaxGridRows), "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "QueryTimeout", cQueryTimeout, "VISDATA.INI")
  If VDMDI.cSingleRecord = True Then
    st = "Single"
  Else
    st = "Table"
  End If
  x = OSWritePrivateProfileString("VISDATA", "ViewMode", st, "VISDATA.INI")
  x = OSWritePrivateProfileString("VISDATA", "SQLStatement", fSQL.cSQLStatement, "VISDATA.INI")
  If fSQL.WindowState <> 1 Then
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowTop", CStr(fSQL.Top), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowLeft", CStr(fSQL.Left), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowWidth", CStr(fSQL.Width), "VISDATA.INI")
    x = OSWritePrivateProfileString("VISDATA", "SQLWindowHeight", CStr(fSQL.Height), "VISDATA.INI")
  End If
  If gfDBChanged Then
    If MsgBox("Data has been changed, Commit it?", MSGBOX_TYPE) = YES Then
      gCurrentDB.CommitTrans
    End If
  End If
  If gfDBOpenFlag Then gCurrentDB.Close
  End
End Sub
Sub PrefFilter_Click ()
  Dim st As String
  Dim CR As String
  MsgBar "Enter New Table List Filter", False
  CR = Chr(13) + Chr(10)
  st = InputBox("Enter ',' Delimited Set of Table List Filters:" + CR + CR + "Use - to Exclude." + CR + CR + "test* Includes test* Tables." + CR + CR + "-sys* Excludes sys* Tables." + CR + CR + "* Alone Shows All Tables.", "Table Filter", gstTableFilter)
  If st <> gstTableFilter Then
    If UCase(st) = "*" Then
      gstTableFilter = ""
    Else
      gstTableFilter = st
    End If
    If gfDBOpenFlag = True Then RefreshTables fTables.cTableList
  End If
  MsgBar "", False
End Sub
Sub PrefMaxRows_Click ()
  Dim st As String
  Dim CR As String
  MsgBar "Enter Maximum Rows to Show in Table View", False
  st = InputBox("Enter New Value:", "Max Table View Rows", CStr(gwMaxGridRows))
  If st <> "" Then
    If Val(st) > MAX_GRID_ROWS Then
      MsgBox "Maximum Rows is " + CStr(MAX_GRID_ROWS), 48
      gwMaxGridRows = MAX_GRID_ROWS
    ElseIf Val(st) = 0 Then
      MsgBox "Minimum Rows is 1.", 48
      gwMaxGridRows = 1
    Else
      gwMaxGridRows = Val(st)
    End If
  End If
  MsgBar "", False
End Sub
Sub PrefOpenOnStartup_Click ()
  'toggle the menu item
  If PrefOpenOnStartup.Checked = True Then
    PrefOpenOnStartup.Checked = False
  Else
    PrefOpenOnStartup.Checked = True
  End If
End Sub
Sub QueryButton_Click ()
  fQuery.WindowState = 0
End Sub
Sub RollBackButton_Click ()
  On Error GoTo RollbackErr
  If MsgBox("All changes will be gone, Rollback anyway?", MSGBOX_TYPE) = YES Then
    gCurrentDB.Rollback
    gfDBChanged = False
    gfTransPending = False
    QueryButton.Visible = True
    BeginButton.Visible = True
    CommitButton.Visible = False
    RollBackButton.Visible = False
    BeginButton.SetFocus
  End If
  GoTo DBRollbackEnd
RollbackErr:
  ShowError
  Resume DBRollbackEnd
DBRollbackEnd:
End Sub
Sub TblCopyStruct_Click ()
  fCpyStru.Show MODAL
End Sub
Sub TblDelete_Click ()
  On Error GoTo TblDelErr
  If fTables.cTableList = "" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  If MsgBox("Delete """ + fTables.cTableList + """ table?", MSGBOX_TYPE) = YES Then
    gCurrentDB.TableDefs.Delete gCurrentDB.TableDefs(fTables.cTableList)
    fTables.cTableList.RemoveItem fTables.cTableList.ListIndex
  End If
  GoTo TblDelEnd
TblDelErr:
  ShowError
  Resume TblDelEnd
TblDelEnd:
End Sub
Sub TblRefresh_Click ()
  RefreshTables fTables.cTableList
End Sub
Sub TblZap_Click ()
  Dim RetSQL As Long
  If fTables.cTableList = "" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  On Error GoTo ZapErr
  If MsgBox("Delete All Records in " + fTables.cTableList + "?", MSGBOX_TYPE) = YES Then
    'delete all rows with a sql statement
    RetSQL = gCurrentDB.ExecuteSQL("delete from " + fTables.cTableList)
    If RetSQL > 0 Then
      MsgBox CStr(RetSQL) + " rows deleted!", 48
      If gfTransPending Then gfDBChanged = True
    End If
  End If
  GoTo ZapEnd
ZapErr:
  If Err = EOF_ERR Then Resume Next
  ShowError
  Resume ZapEnd
ZapEnd:
End Sub
Sub UtilCloseAll_Click ()
  CloseAllDynasets
End Sub
Sub UtilExport_Click ()
  Dim ds As Dynaset
  Dim l As Long
  Dim i As Integer
  Dim fn As String
  Dim st As String
  On Error GoTo ExportErr
  If fTables.cTableList = "" And UCase(Mid(fSQL.cSQLStatement, 1, 6)) <> "SELECT" Then
    MsgBox "No Table Selected", 48
    Exit Sub
  End If
  fn = InputBox("Enter Path\FileName to Export to:", "Export File", "VISDATA.TXT")
  If fn = "" Then Exit Sub
  SetHourGlass Me
  MsgBar "Exporting Data to " + fn, True
  If UCase(Mid(fSQL.cSQLStatement, 1, 6)) = "SELECT" Then
    Set ds = gCurrentDB.CreateDynaset(fSQL.cSQLStatement)
  Else
    Set ds = gCurrentDB.CreateDynaset(fTables.cTableList)
  End If
  Open fn For Output As #1
  'output the field names
  For i = 0 To ds.Fields.Count - 1
    st = Chr$(9)
    st = st + ds(i).Name + Chr$(9)
  Next
  Print #1, st
  'output the field contents
  l = 1
  While ds.EOF = False
    st = CStr(l) + Chr$(9)
    For i = 0 To ds.Fields.Count - 1
      st = st + ds(i) + Chr$(9)
    Next
    Print #1, st
    ds.MoveNext
    l = l + 1
  Wend
  GoTo ExportEnd
ExportErr:
  ShowError
  Resume ExportEnd
ExportEnd:
  Close #1
  ResetMouse Me
  MsgBar "", False
End Sub
Sub UtilReplace_Click ()
  Dim i As Integer
  Dim sb As String
  On Error GoTo ReplaceErr
  RefreshTables fReplace.cTableList
  fReplace.Show
  GoTo ReplaceEnd
ReplaceErr:
  ShowError
  Resume ReplaceEnd
ReplaceEnd:
End Sub
Sub WinArrange_Click ()
  Me.Arrange 3
End Sub
Sub WinCascade_Click ()
  Me.Arrange 0
End Sub
Sub WinSQL_Click ()
  fSQL.WindowState = 0
End Sub
Sub WinTables_Click ()
  fTables.WindowState = 0
  If fTables.cTableList.ListCount = 0 And gfDBOpenFlag = True Then
    RefreshTables fTables.cTableList
  End If
End Sub
Sub WinTile_Click ()
  Me.Arrange 2
End Sub