moddatafunctions.bas

很好用的通用库存管理程序

Attribute VB_Name = "ModDataFunctions"
Public gdbCurrentDB As Database
Public gtdfTableDef  As TableDef
Global gsDatabase As String
Global gsRecordsource As String
Global DataLocation As String
'  Fill List Box with Table Names

Public Sub GetTableList(rctl As Control, rbIncludeQDFs As Integer, rbIncludeSys As Integer, rbStripConnect As Integer)
  On Error GoTo FTLErr
  
  Dim i As Integer
  Dim sTmp As String
  Dim tbl As TableDef
  Dim qdf As QueryDef
  
  'add the tabledefs
  For Each tbl In gdbCurrentDB.TableDefs
    sTmp = tbl.Name
    If rbIncludeSys Then
      rctl.AddItem sTmp
      rctl.ItemData(rctl.NewIndex) = 0
    Else
      If (gdbCurrentDB.TableDefs(sTmp).Attributes And dbSystemObject) = 0 Then
        rctl.AddItem sTmp
        rctl.ItemData(rctl.NewIndex) = 0
      End If
    End If
  Next
  
  'add the querydefs
  If rbIncludeQDFs Then
    For Each qdf In gdbCurrentDB.QueryDefs
      rctl.AddItem qdf.Name
      rctl.ItemData(rctl.NewIndex) = 1
    Next
  End If
  
  Exit Sub
  
FTLErr:
  MsgBox ("ERROR" & vbCrLf & Err.Number & vbCrLf & Err.Description)
End Sub

'Dump the commondialog filename and just keep the path

Function StripFileName(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripFileName = Mid(rsFileName, 1, i - 1)

End Function

'Build the Filename portion of the Export String

Function ExportFileName(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer
  Dim temp1, temp2

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

temp1 = Mid(rsFileName, 1, i - 1)
temp2 = Mid(rsFileName, i + 1)
  
  ExportFileName = temp1 & "].[" & temp2 & "]"

End Function

'Fill List Boxes with objects, namely Fields

Sub ListItemNames(rcCollection As Object, rnCtl As Control, bClearList As Integer)
  
  
  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
  
End Sub

'Modify Export string to include Excel Worksheet name

Function ExcelExport(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer
  Dim temp1, temp2

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

temp1 = Mid(rsFileName, 1, i - 1)
temp2 = Mid(rsFileName, i + 1)
  
  ExcelExport = "].[" & temp2 & "]"

End Function