datatools.bas

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

Attribute VB_Name = "moddata"
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
'各种信息提示
Const MSG2 = "正在关闭记录集"
Const MSG3 = "表已经存在，删除吗？"
Const MSG4 = "输入新表名称："
Const MSG5 = "待命"
Const MSG6 = "，请等待..."
Const MSG7 = "正在刷新表列表"
Const MSG8 = "数："
Const MSG9 = "显示数据访问 Errors 集合吗？"
Const MSG10 = "不能在链接表上打开 Table 对象，使用动态集吗？"
Const MSG11 = "正在以动态集类型打开链接表"
Const MSG17 = "这是 SQL 传递查询吗？"
Const MSG18 = "输入连接属性值："
Const MSG22 = "SQL 语句"
Const MSG23 = "执行"
Const MSG24 = "查询吗？"
Const MSG25 = "正在执行查询"
Const MSG26 = "  [不可更新]"
Const MSG27 = "表已经存在，删除吗？"
Const MSG28 = "查询定义已经存在，删除吗？"
Const MSG29 = "输入值，对参数"
Const MSG30 = "没有数据访问错误！"
Const MSG31 = "此时不能显示错误！"
Const MSG32 = "数据已经改变，提交吗？"
Const MSG33 = "回滚所有改变吗？"
Const MSG34 = "正在处理事务，不能关闭！"
Const MSG35 = "必须首先关闭！"
Const MSG42 = "打开文本数据库 "
Const MSG43 = "正在打开数据库"
Const MSG44 = "注意：推荐使用附加表"
Const MSG47 = "输入新的 ISAM 数据库的目录名称："
Const MSG50 = "|所有文件 (*.*)|*.*"
Const MSG57 = "导出"
Const MSG58 = "在"
Const MSG61 = "成功导出 SQL 语句。"
Const MSG62 = "表已经存在，覆盖吗？"
Const MSG64 = "成功输入："
Const MSG65 = "无效的目录名称！"
'>>>>>>>>>>>>>>>>>>>>>>>>


'api declarations
Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Declare Function SQLDataSources% Lib "ODBC32.DLL" (ByVal henv&, ByVal fdir%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDesc$, ByVal cbDescMax%, pcbDesc%)

'Public object variables
Public gnodDBNode    As Node        'current database node in treeview
Public gnodDBNode2   As Node        'backup of current database node in treeview
Public gwsMainWS     As Workspace   'main workspace object
Public gdbConString  As String       '当前连接
Public gbDBOpenFlag  As Integer     'flag to know if a db is open
Public gPropObject   As Object      'object to show properties on
Public gDataCtlObj   As Object      'Public data control object
Public gtdfTableDef  As TableDef    'Public tabledef used by frmTblStruct
Public gnFormType    As Integer     'form type chosen on main form
                                    '0 = data control
                                    '1 = no data control
                                    '2 = grid control
Public gnRSType      As Integer     'recordset type chosen on main form
                                    '0 = table
                                    '1 = dynaset
                                    '2 = snapshot

'Public database variables
Public gsDataType       As String   'data backend = connect string
                                    'for everything accept Access
Public gsDBName         As String   'current database name
Public gsODBCDatasource As String   'Public odbc values
Public gsODBCDatabase   As String   '       "
Public gsODBCUserName   As String   '       "
Public gsODBCPassword   As String   '       "
Public gsODBCDriver     As String   '       "
Public gsODBCServer     As String   '       "
Public gsTblName        As String   '
Public glQueryTimeout   As Long     '
Public glLoginTimeout   As Long     '
Public gsTableDynaFilter As String  '
Public gnReadOnly       As Integer  'database readonly flag

'other Public vars
Public gsZoomData       As String   'pass info to the zoom form

'multi user variables
Public gnMURetryCnt     As Integer
Public gnMUDelay        As Integer
Public gnMULocking      As Integer  'flag for pessimistic or optimistic locking

'Public find values used to pass info between
'the dynaset form and find dialog
Public gbFindFailed     As Boolean
Public gsFindExpr       As String
Public gsFindOp         As String
Public gsFindField      As String
Public gnFindType       As Integer
Public gbFromTableView  As Boolean

'Public seek values used to pass info between
'the table form and find dialog
Public gsSeekOperator   As String
Public gsSeekValue      As String

'Public flags
Public gbDBChanged      As Boolean   '
Public gbTransPending   As Boolean   'used for transaction management
Public gbFromSQL        As Boolean   'source of sql statement was SQL form
Public gbAddTableFlag   As Boolean   'new or design designator
Public gbSettingDataCtl As Boolean   'used to reset data control props


'Public constants
Public Const APPNAME = "数据库工具"
Public Const gsDEFAULT_DRIVER = "SQL Server"  'used for registerdatabase
Public Const gnEOF_ERR = 626                  '
Public Const gnFTBLS = 0                      '
Public Const gnFFLDS = 1                      '
Public Const gnFINDX = 2                      '
Public Const gnMAX_GRID_ROWS = 31999          '
Public Const gnMAX_MEMO_SIZE = 20000          '
Public Const gnGETCHUNK_CUTOFF = 50           '

Public Const gnFORM_DATACTL = 0               '
Public Const gnFORM_NODATACTL = 1             '
Public Const gnFORM_DATAGRID = 2              '

Public Const gnRS_TABLE = vbRSTypeTable
Public Const gnRS_DYNASET = vbRSTypeDynaset
Public Const gnRS_SNAPSHOT = vbRSTypeSnapShot
Public Const gnRS_PASSTHRU = 8

Public Const gnCTLARRAYHEIGHT = 340&          '
Public Const gnSCREEN = 0                     'used to center forms on screen
Public Const gnMDIFORM = 1                    'used to center forms on frmMDI

Public Const TABLE_STR = "Table"
Public Const ATTACHED_STR = "Attached"
Public Const QUERY_STR = "Query"
Public Const FIELD_STR = "Field"
Public Const FIELDS_STR = "Fields"
Public Const INDEX_STR = "Index"
Public Const INDEXES_STR = "Indexes"
Public Const PROPERTY_STR = "Property"
Public Const PROPERTIES_STR = "Properties"

Public Const APP_CATEGORY = "My Applacation SavingData"

Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
Private Declare Function LoadStringA Lib "user32" (ByVal hInstance As Long, ByVal wID As Long, ByVal lpBuffer As String, ByVal nBufferMax As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

'LoadLibrary constants
Public Const LOAD_LIBRARY_AS_DATAFILE As Long = &H2

'GetLocaleInfo constants
Public Const LOCALE_SLANGUAGE = &H2
Public Const LOCALE_SABBREVLANGNAME = &H3
Private m_lcid  As Long
Private m_sHelpFile As String


Sub Main()
  frmMDI.Show
End Sub




'------------------------------------------------------------
'clear out the data fields on the table and dynasnap forms
'------------------------------------------------------------
Sub ClearDataFields(frm As Form, nCnt As Integer)
  Dim i As Integer

  'clear out the fields on the main form
  For i = 0 To nCnt - 1
    frm.txtFieldData(i).Text = vbNullString
  Next
End Sub

'------------------------------------------------------------
'this sub closes all frmDynaSnap, frmTableObj and frmDataGrid
'forms by looking for forms with a Tag set to "Recordset"
'------------------------------------------------------------
Sub CloseAllRecordsets()
  Dim i As Integer

  MsgBar MSG2, True
  While i < Forms.Count
    If Forms(i).Tag = "Recordset" Then
      Unload Forms(i)
    Else
      i = i + 1
    End If
  Wend
  MsgBar vbNullString, False

End Sub


'------------------------------------------------------------
'this function returns the Registry setting for the
'passed in item and section
'------------------------------------------------------------
Function GetRegistryString(ByVal vsItem As String, ByVal vsDefault As String) As String
  GetRegistryString = GetSetting(APP_CATEGORY, APPNAME, vsItem, vsDefault)
End Function

'------------------------------------------------------------
'this sub hides the menus and toolbar that only apply
'when a database is open
'------------------------------------------------------------
Sub HideDBTools()
  frmMDI.mnuDBClose.Enabled = False
  frmMDI.mnuDBImpExp.Enabled = False
  frmMDI.mnuBackup.Enabled = False
  frmMDI.mnuUBar1.Visible = False
End Sub

'------------------------------------------------------------
'this sub displays the passed in message in the status
'bar on the bottom of the MDI form
'------------------------------------------------------------
Sub MsgBar(rsMsg As String, rPauseFlag As Integer)
  If Len(rsMsg) = 0 Then
    Screen.MousePointer = vbDefault
    frmMDI.stsStatusBar.Panels(1).Text = MSG5
  Else
    If rPauseFlag Then
      frmMDI.stsStatusBar.Panels(1).Text = rsMsg & MSG6
    Else
      frmMDI.stsStatusBar.Panels(1).Text = rsMsg
    End If
  End If
  frmMDI.stsStatusBar.Refresh
End Sub



'------------------------------------------------------------
'this sub refreshs any table list passed in as an object
'------------------------------------------------------------
Sub RefreshTables(rListObject As Object)
  'On Error GoTo TRefErr

  Dim tdf As TableDef
  Dim qdf As QueryDef
  Dim sTmp As String
    
  Dim i As Integer
    
  MsgBar MSG7, True
  Screen.MousePointer = vbHourglass


  frmDatabase.LoadDatabase
  
  Screen.MousePointer = vbDefault
  MsgBar vbNullString, False
  Exit Sub

TRefErr:
  ShowError
End Sub



'------------------------------------------------------------
'this sub shows the menus and toolbar that only apply
'when a database is open
'------------------------------------------------------------
Sub ShowDBTools()
  frmMDI.mnuDBClose.Enabled = True
  frmMDI.mnuDBImpExp.Enabled = True
  frmMDI.mnuBackup.Enabled = True
  frmDatabase.Show
End Sub

'------------------------------------------------------------
'this sub displays the error message with it's Err code
'and prompts to show the Errors collection if it
'is a data access type error
'------------------------------------------------------------
Sub ShowError()
  Dim sTmp As String

  Screen.MousePointer = vbDefault
  MsgBar vbNullString, False

  sTmp = "The following Error occurred:" & vbCrLf & vbCrLf
  'add the error string
  sTmp = sTmp & Err.Description & vbCrLf
  'add the error number
  sTmp = sTmp & MSG8 & Err
  
  Beep
  'check to see if the error is from the db errors collection
  If DBEngine.Errors.Count > 0 Then
    If DBEngine.Errors(0).Number = Err Then
      'add the prompt to display the errors collection
      sTmp = sTmp & vbCrLf & vbCrLf & MSG9
      'beep and show the error
      If MsgBox(sTmp, vbYesNo + vbQuestion) = vbYes Then
        RefreshErrors
      End If
    Else
      MsgBox sTmp
    End If
  Else
    MsgBox sTmp
  End If

End Sub

'加上[]号
Function StripConnect(rsTblName As String) As String

  StripConnect = "[" & rsTblName & "]"
  
End Function



'------------------------------------------------------------
'this function strips the non ACSII chars off memo field
'data before displaying it (not sure this is always needed)
'------------------------------------------------------------
Function StripNonAscii(rvntVal As Variant) As String
  Dim i As Integer
  Dim sTmp As String

  'stubbed out to enable DBCS chars
  StripNonAscii = rvntVal
  Exit Function

  For i = 1 To Len(rvntVal)
    If Asc(Mid(rvntVal, i, 1)) < 32 Or Asc(Mid(rvntVal, i, 1)) > 126 Then
      sTmp = sTmp & " "
    Else
      sTmp = sTmp & Mid(rvntVal, i, 1)
    End If
  Next

  StripNonAscii = sTmp

End Function

'------------------------------------------------------------
'strips the owner off of ODBC table names
'------------------------------------------------------------
Function StripOwner(rsTblName As String) As String

  If InStr(rsTblName, ".") > 0 Then
    rsTblName = Mid(rsTblName, InStr(rsTblName, ".") + 1, Len(rsTblName))
  End If
  StripOwner = rsTblName

End Function

'------------------------------------------------------------
'returns the true or false string
'------------------------------------------------------------
Function stTrueFalse(rvntTF As Variant) As String
  If rvntTF Then
    stTrueFalse = "True"
  Else
    stTrueFalse = "False"
  End If
End Function

'------------------------------------------------------------
'returns "" if a field is Null
'------------------------------------------------------------
Function vFieldVal(rvntFieldVal As Variant) As Variant
  If IsNull(rvntFieldVal) Then
    vFieldVal = vbNullString
  Else
    vFieldVal = CStr(rvntFieldVal)
  End If
End Function

'------------------------------------------------------------
'载入所用注册信息
'------------------------------------------------------------
Sub LoadRegistrySettings()
  On Error Resume Next
  
  Dim sTmp As String
  Dim x As Integer

  glQueryTimeout = Val(GetRegistryString("QueryTimeout", "5"))
  glLoginTimeout = Val(GetRegistryString("LoginTimeout", "20"))
  
  frmMDI.mnuPOpenOnStartup.Checked = Val(GetRegistryString("OpenOnStartup", "0"))

  'get the most recently used databases