datatools.bas

SQL数据库工具就是一种即可以进行数据浏览、添加、删除和修改等数据库管理操作

  For x = 1 To 8
    sTmp = GetRegistryString("MRUDatabase" & x, "")
    If Len(sTmp) > 0 Then
      frmMDI.mnuBarMRU.Visible = True
      frmMDI.mnuDBMRU(x).Caption = "&" & x & " " & sTmp
      frmMDI.mnuDBMRU(x).Visible = True
      sTmp = GetRegistryString("MRUConnect" & x, "")
      frmMDI.mnuDBMRU(x).Tag = sTmp
    End If
  Next

  'get the last used database out of the Registry
  gsODBCDatasource = GetRegistryString("ODBCDatasource", vbNullString)
  gsODBCDatabase = GetRegistryString("ODBCDatabase", vbNullString)
  gsODBCUserName = GetRegistryString("ODBCUserName", vbNullString)
  gsODBCPassword = GetRegistryString("ODBCPassword", vbNullString)
  gsODBCDriver = GetRegistryString("ODBCDriver", vbNullString)
  gsODBCServer = GetRegistryString("ODBCServer", vbNullString)

  sTmp = GetRegistryString("ViewMode", CStr(gnFORM_NODATACTL))
  Select Case Val(sTmp)
    Case gnFORM_NODATACTL
      gnFormType = gnFORM_NODATACTL
    Case gnFORM_DATACTL
      gnFormType = gnFORM_DATACTL
    Case gnFORM_DATAGRID
      gnFormType = gnFORM_DATAGRID
  End Select
  sTmp = GetRegistryString("RecordsetType", CStr(vbRSTypeDynaset))
  Select Case Val(sTmp)
    Case vbRSTypeTable
      gnRSType = gnRS_TABLE
    Case vbRSTypeDynaset
      gnRSType = gnRS_DYNASET
    Case vbRSTypeSnapShot
      gnRSType = gnRS_SNAPSHOT
    Case gnRS_PASSTHRU
      gnRSType = gnRS_PASSTHRU
  End Select
    
End Sub

'------------------------------------------------------------
'保存当前注册信息
'------------------------------------------------------------
Sub SaveRegistrySettings()
  On Error Resume Next

  Dim i As Integer
  SaveSetting APP_CATEGORY, APPNAME, "ODBCDatasource", gsODBCDatasource
  SaveSetting APP_CATEGORY, APPNAME, "ODBCDatabase", gsODBCDatabase
  SaveSetting APP_CATEGORY, APPNAME, "ODBCUserName", gsODBCUserName
  SaveSetting APP_CATEGORY, APPNAME, "ODBCPassword", gsODBCPassword
  SaveSetting APP_CATEGORY, APPNAME, "ODBCServer", gsODBCServer
  SaveSetting APP_CATEGORY, APPNAME, "QueryTimeout", glQueryTimeout
  SaveSetting APP_CATEGORY, APPNAME, "LoginTimeout", glLoginTimeout
  DBEngine.LoginTimeout = glLoginTimeout
  SaveSetting APP_CATEGORY, APPNAME, "OpenOnStartup", IIf(frmMDI.mnuPOpenOnStartup.Checked, "-1", "0")
  For i = 1 To 8
    If frmMDI.mnuDBMRU(i).Visible Then
      SaveSetting APP_CATEGORY, APPNAME, "MRUDatabase" & i, Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))
      SaveSetting APP_CATEGORY, APPNAME, "MRUConnect" & i, frmMDI.mnuDBMRU(i).Tag
    Else
      SaveSetting APP_CATEGORY, APPNAME, "MRUDatabase" & i, ""
      SaveSetting APP_CATEGORY, APPNAME, "MRUConnect" & i, ""
    End If
  Next
  
  SaveSetting APP_CATEGORY, APPNAME, "WindowState", frmMDI.WindowState
  If frmMDI.WindowState = vbNormal Then
    SaveSetting APP_CATEGORY, APPNAME, "WindowTop", frmMDI.Top
    SaveSetting APP_CATEGORY, APPNAME, "WindowLeft", frmMDI.Left
    SaveSetting APP_CATEGORY, APPNAME, "WindowWidth", frmMDI.Width
    SaveSetting APP_CATEGORY, APPNAME, "WindowHeight", frmMDI.Height
  End If
  SaveSetting APP_CATEGORY, APPNAME, "ViewMode", gnFormType
  SaveSetting APP_CATEGORY, APPNAME, "RecordsetType", gnRSType

End Sub



'------------------------------------------------------------
'this sub unloads all forms except for the
'SQL, Tables and MDI form
'------------------------------------------------------------
Sub UnloadAllForms()
  On Error Resume Next
  
  Dim i As Integer
  
  For i = Forms.Count - 1 To 1 Step -1
    Unload Forms(i)
  Next
End Sub

'------------------------------------------------------------
'this sub walks the parameters collection in a parameterized
'query and prompts the user for a value for each parameter
'------------------------------------------------------------
Sub SetQDFParams(rqdf As QueryDef)
  On Error GoTo SPErr
  
  Dim prm As Parameter
  Dim sTmp As String
  
  For Each prm In rqdf.Parameters
    'get the value from the user
    sTmp = InputBox(MSG29, "'" & prm.Name & "':")
    'store the value
    prm.Value = CVar(sTmp)
  Next
  
  Exit Sub
    
SPErr:
  ShowError
End Sub

'------------------------------------------------------------
'this sub refreshs the Error form with the latest Errors
'------------------------------------------------------------
Sub RefreshErrors()
  On Error GoTo RErr
  
  Dim errObj As Error
  Dim i As Integer

  If DBEngine.Errors.Count = 0 Then
    MsgBox MSG30, 48
    Unload frmErrors
    Exit Sub
  End If

  frmErrors.Show
  frmErrors.lstErrors.Clear
  For i = 0 To DBEngine.Errors.Count - 1
    Set errObj = DBEngine.Errors(i)
    frmErrors.lstErrors.AddItem errObj.Number & vbTab & errObj.Source & vbTab & errObj.Description
  Next
  frmErrors.SetFocus

  Exit Sub
  
RErr:
  MsgBox MSG31, 48
  Unload frmErrors
  Exit Sub
End Sub

'------------------------------------------------------------
'this sub adds the just opened database to the most recently
'used list in the File menu
'------------------------------------------------------------
Sub AddMRU()
  On Error GoTo AMErr

  Dim i As Integer, j As Integer

  '1st look to see if it alread exists and swap it if it does
  For i = 1 To 8
    If UCase(Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))) = UCase(gsODBCServer) Then
      For j = i To 2 Step -1
        frmMDI.mnuDBMRU(j).Caption = "&" & j & " " & Mid(frmMDI.mnuDBMRU(j - 1).Caption, 4, Len(frmMDI.mnuDBMRU(j - 1).Caption))
        frmMDI.mnuDBMRU(j).Tag = frmMDI.mnuDBMRU(j - 1).Tag
      Next
      GoTo Finish
    End If
  Next

  'wasn't there so move everything down one
  For i = 7 To 1 Step -1
    frmMDI.mnuDBMRU(i + 1).Caption = "&" & i + 1 & " " & Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))
    frmMDI.mnuDBMRU(i + 1).Tag = frmMDI.mnuDBMRU(i).Tag
  Next

Finish:
  frmMDI.mnuDBMRU(1).Caption = "&1 " & gsODBCServer
  frmMDI.mnuBarMRU.Visible = True
  For i = 1 To 8
    If Len(Mid(frmMDI.mnuDBMRU(i).Caption, 4, Len(frmMDI.mnuDBMRU(i).Caption))) > 0 Then
      frmMDI.mnuDBMRU(i).Visible = True
    End If
  Next

  Exit Sub

AMErr:
  ShowError
End Sub

'------------------------------------------------------------
'过程获得odbc的各项参数并赋值给公共变量
'------------------------------------------------------------
Sub GetODBCConnectParts(rsConnect As String)
  On Error Resume Next
  
  Dim i As Integer
  Dim sTmp As String
  
  'process the connect string just in case the
  'values came from the ODBC dialogs
  If InStr(rsConnect, "=") Then
    i = 1
    While i <= Len(rsConnect) + 1
      If Mid(rsConnect, i, 1) = ";" Or i = Len(rsConnect) + 1 Then
        If Len(sTmp) > 0 And InStr(sTmp, "=") > 0 Then
          Select Case Mid(sTmp, 1, InStr(1, sTmp, "=") - 1)
            Case "DSN"
              gsODBCDatasource = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "DATABASE"
              gsODBCDatabase = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "DBQ"
              gsODBCDatabase = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "UID"
              gsODBCUserName = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "PWD"
              gsODBCPassword = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "Driver"
              gsODBCDriver = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
            Case "Server"
              gsODBCServer = Mid(sTmp, InStr(1, sTmp, "=") + 1, Len(sTmp))
             Case Else
              'nothing
          End Select
        End If
        sTmp = vbNullString
      Else
        sTmp = sTmp + Mid(rsConnect, i, 1)
      End If
      i = i + 1
    Wend
  End If
End Sub

'------------------------------------------------------------
'this is a generic sub that adds the name of each item
'in a collection to the passed in control
'------------------------------------------------------------
Sub ListItemNames(rcCollection As Object, rnCtl As Control, bClearList As Integer)
  On Error GoTo LINErr
  
  Dim objTmp As Object
  Dim i As Integer
  
  If bClearList Then
    rnCtl.Clear
  End If
  
  For Each objTmp In rcCollection
    rnCtl.AddItem objTmp.Name
  Next

  Exit Sub
  
LINErr:
  ShowError
End Sub

'------------------------------------------------------------
'this sub closes the current DB and performs any cleanup
'and resetting of controls, menus, etc.
'------------------------------------------------------------
Sub CloseCurrentDB()
  On Error GoTo DBCloseErr

  frmMDI.Caption = "数据库工具"
  
  HideDBTools
  
  gbDBOpenFlag = False
  gbTransPending = False
  gsDBName = vbNullString
  gnReadOnly = False
  
  UnloadAllForms

  Exit Sub

DBCloseErr:
  ShowError
End Sub





'------------------------------------------------------------
'关闭程序，清理数据
'------------------------------------------------------------
Sub ShutDownAll()
  On Error Resume Next

  Dim nRet As Integer

  'save all the current Registry settings
  SaveRegistrySettings

  If gbDBChanged Then
    If MsgBox(MSG32, vbYesNo + vbQuestion) = vbYes Then
      gwsMainWS.CommitTrans
    End If
  End If

  UnloadAllForms
  'close the help file

  
  End

End Sub

'*********************************************************
'* 名称：FieldType
'* 功能：返回字段类型
'* 用法：FieldType(nType as integer)
'*********************************************************
 Function FieldType(nType As Integer) As String
      Select Case nType
        Case 128
            FieldType = "BINARY"
        Case 11
            FieldType = "BIT"
        Case 129
            FieldType = "CHAR"
        Case 135
            FieldType = "DATETIME"
        Case 131
            FieldType = "DECIMAL"
        Case 5
            FieldType = "FLOAT"
        Case 205
            FieldType = "IMAGE"
        Case 3
            FieldType = "INT"
        Case 6
            FieldType = "MONEY"
        Case 130
            FieldType = "NCHAR"
        Case 203
            FieldType = "NTEXT"
        Case 131
            FieldType = "NUMERIC"
        Case 202
            FieldType = "NVARCHAR"
        Case 4
            FieldType = "REAL"
        Case 135
            FieldType = "SMALLDATETIME"
        Case 2
            FieldType = "SMALLINT"
        Case 6
            FieldType = "TIMESTAMP"
        Case 201
            FieldType = "TEXT"
        Case 128
            FieldType = "BYTES"
        Case 17
            FieldType = "TINYINT"
        Case 72
            FieldType = "VARBINARY"
        Case 204
            FieldType = "VARCHAR"
        Case 200
            FieldType = "VARCHAR"
    End Select
End Function

Public Function ChangeDB(Constr As String) As String
Dim n As Integer
n = InStr(1, Constr, "Initial Catalog")
ChangeDB = Left(Constr, n - 1) & "Initial Catalog="
End Function

'*********************************************************
'* 名称：FieldNULL
'* 功能：返回字段是否为空
'*********************************************************
 Function FieldNULL(rsFiled As ADODB.Field) As String
     Dim x As Integer
     x = rsFiled.Attributes And adFldIsNullable
     If x = 0 Then
     FieldNULL = "否 "
     Else
     FieldNULL = "是"
     End If
 End Function
' 返回正确的字段大小
 Function FieldSize(rsFiled As ADODB.Field) As Integer
    If rsFiled.DefinedSize = 1073741823 Or rsFiled.DefinedSize = 2147483647 Then
    FieldSize = 16
    Else
    FieldSize = rsFiled.DefinedSize
    End If
 End Function