mmaketable.bas

用vb写的一个小程序。希望喜欢。 ＬＨＢＳＥＡＭＡＮ·１６３。ＣＯＭ

Attribute VB_Name = "mMakeTable"
Option Compare Text
Option Explicit

Sub subInitDB()
  '***  Visual Basic compatible 'CurrentDB' reference...
  Dim strDbName        As String

  strDbName = App.Path & strUSERDB

  If Dir$(strDbName) = vbNullString Then
    Set ActiveDB = Nothing

    If LenB(Dir$(strDbName)) <> 0 Then

      On Error Resume Next

      Kill strDbName
      If Err <> 0 Then
        '***  file could not be deleted
        MsgBox APPTITLE, vbCritical, "The file" & strUSERDB & " Could not be removed." & _
          vbNewLine & "Please close it and retry."
        End
      End If

      On Error GoTo 0

    End If
    Set ActiveDB = DAO.CreateDatabase(strDbName, dbLangGeneral, lngDBVER)
    ActiveDB.Close
    Set ActiveWS = DAO.DBEngine.CreateWorkspace("myspace", "Admin", vbNullString)
    DAO.DBEngine.Workspaces.Append ActiveWS
    Set ActiveDB = ActiveWS.OpenDatabase(strDbName, True, False)

    '***  creation of all tables
    subCreateConversionTable

    '***  loading the data
    subLoadConversionTable

    '***  set some indices
    fcnMakeIDX "convert", "key"
    fcnMakeIDX "convert", "original"
    fcnMakeIDX "convert", "changeto"
    fcnMakeIDX "convert", "iso"

    Set ActiveDB = Nothing
  End If

End Sub

Sub subRefreshDB()
  On Error Resume Next
  DAO.DBEngine.Workspaces.Delete "myspace"
  On Error GoTo 0

  Dim strDbName        As String
  strDbName = App.Path & strUSERDB
  Set ActiveWS = DAO.DBEngine.CreateWorkspace("myspace", "Admin", vbNullString)
  DAO.DBEngine.Workspaces.Append ActiveWS
  Set ActiveDB = ActiveWS.OpenDatabase(strDbName, True, False)
End Sub

Function fcnMakeIDX(strTable As String, strField As String) As Boolean
  Dim idxtemp          As DAO.Index
  Dim tdtemp           As DAO.TableDef

  On Error Resume Next

  Set tdtemp = ActiveDB.TableDefs(TBL & strTable)

  Set idxtemp = tdtemp.CreateIndex(IDX & strField)
  With idxtemp
    .Fields.Append .CreateField(FLD & strField)
    If strField = "key" Then
      .Unique = True
    End If
  End With
  tdtemp.Indexes.Append idxtemp

  ActiveDB.TableDefs(strTable).Indexes.Refresh
  fcnMakeIDX = True
End Function

Sub subCreateConversionTable()
  Dim tdTag            As DAO.TableDef
  Dim fldTemp          As DAO.Field

  With ActiveDB
    Set tdTag = .CreateTableDef(TBL & "convert")

    Set fldTemp = tdTag.CreateField(FLD & "key", dbLong)
    fldTemp.Attributes = dbAutoIncrField Or fldTemp.Attributes
    tdTag.Fields.Append fldTemp

    Set fldTemp = tdTag.CreateField(FLD & "type", dbText, 255)
    fldTemp.AllowZeroLength = True
    tdTag.Fields.Append fldTemp

    Set fldTemp = tdTag.CreateField(FLD & "original", dbText, 255)
    fldTemp.AllowZeroLength = True
    tdTag.Fields.Append fldTemp

    Set fldTemp = tdTag.CreateField(FLD & "changeto", dbText, 255)
    fldTemp.AllowZeroLength = True
    tdTag.Fields.Append fldTemp

    Set fldTemp = tdTag.CreateField(FLD & "description", dbMemo)
    fldTemp.AllowZeroLength = True
    tdTag.Fields.Append fldTemp

    Set fldTemp = tdTag.CreateField(FLD & "iso", dbText, 255)
    fldTemp.AllowZeroLength = True
    tdTag.Fields.Append fldTemp

    .TableDefs.Append tdTag
  End With

  Set tdTag = Nothing
End Sub

Sub subLoadConversionTable()
  Dim strFileName      As String
  Dim rstTable         As DAO.Recordset
  Dim lngRecordCount   As Long
  Dim lngFieldcount    As Long
  Dim arrLine          As Variant

  '***  load the CSV file
  strFileName = App.Path & "\" & "convert.data"

  arrLine = fcnGetDelimitedRecord(fcnGetFile(strFileName))

  Set rstTable = ActiveDB.OpenRecordset(TBL & "convert", dbOpenTable)

  With rstTable
    For lngRecordCount = 1 To arrLine(0) - 1 Step 6

      .AddNew
      For lngFieldcount = 1 To 5
        .Fields(lngFieldcount) = (arrLine(lngRecordCount + lngFieldcount))
      Next
      .Fields(2) = """" & fcnGetISO(.Fields(5)) & """"
      .Update
    Next
    .Close
  End With

  Set rstTable = Nothing

End Sub

Function fcnGetISO(strISO As String) As String
  fcnGetISO = Chr(Val(Mid$(strISO, 4&)))
End Function