我使用的模板数据库是我很早以前在互联网上某个地方找到的。我真的希望我记得在哪里找到它，以便至少可以感谢作者的例程和备份想法，但是到目前为止我还没有运气。
我在加载数据库时进行后端检查时遇到问题。这是我正在使用的代码：
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Err_Handler
Const conFILENOTFOUND As Integer = 3024
Const conPATHNOTFOUND As Integer = 3044
Dim dbs As DAO.Database, rst As DAO.Recordset, tdf As DAO.TableDef
Dim strTable As String, strConnect As String
Set dbs = CurrentDb
' mimimize database window/navigation pane
' DoCmd.SelectObject acForm, Me.Name, True
' DoCmd.Minimize
' test validity of links to back end and open
' form to refersh links if not valid
CheckLinks:
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) > 0 Then
If tdf.Connect <> strConnect Then
strTable = tdf.Name
Set rst = dbs.OpenRecordset(strTable)
strConnect = tdf.Connect
End If
End If
Next tdf
Exit_Here:
Set rst = Nothing
Set tdf = Nothing
Set dbs = Nothing
Exit Sub
Err_Handler:
If Err.Number = conFILENOTFOUND Or Err.Number = conPATHNOTFOUND Then
DoCmd.OpenForm "frmUpdate_Links", _
WindowMode:=acDialog, _
OpenArgs:="ForceQuit"
Resume CheckLinks
Else
MsgBox Err.Description & " (" & Err.Number & ")"
Resume Exit_Here
End If
End Sub
问题在于，表单没有向我回信说后端是错误的（老实说，这是在做...），然后打开frmUpdate_Links来更新后端链接。我认为conFILENOTFOUND和/或conPATHNOTFOUND错误检查是不正确的。我目前正在使用一个数据库，该数据库在用来检查后端是否存在的两个表中没有任何条目。这些表是BackEndLocation和FileLocations。当这两个表中没有条目时，应该打开frmUpdate_Links。相反，当数据库找不到后端时，我会遇到典型错误。
有两个与该例程关联的模块。这是他们的代码：
第一个是BrowseForFileClass，它是一个类模块-
Option Compare Database
Option Explicit
' There are default values for the dialog box title and the list of file types
' in the 'file filter' section of the dialog box. The calling VBA code can
' use the following Properties and Methods of this class.
'
' Properties:
' DialogTitle -- the text that is displayed as the title of the
' dialog box. The default is "Browse For a File".
' AdditionalTypes -- one or more additional file types to be added as
' one item in the dialog box's file filter list,
' formatted like this sample:
' "My Files (*.mf1;*.mf2) | *.mf1;*.mf2 | Your Files (*.yf1;*.yf2) *.yf1;*.yf2"
' The following file types are in the built-in list:
' "All Files (*.*)"
' "Text Files (*.txt;*.prn;*.csv)"
' "Word Documents (*.doc)"
' "Word Templates (*.dot)"
' "Rich Text Files (*.rtf)"
' "Excel Files (*.xls)"
' "Databases (*.mdb)"
' "HTML Documents (*.html;*.htm)"
' DefaultType -- the item in the dialog's file filter list that will be
' active when the dialog box is activated. If the
' AdditionalTypes property is not used, the default
' is "All files (*.*)". If the AdditionalTypes property
' is used, this property cannot be used and the file type
' specified in the AdditionalTypes property will be active
' when the dialog box is activated. To set this property,
' specify a string that will match with the desired type,
' such as "*.doc" or "HTML".
' InitialFile -- the file name that is to be displayed in the File Name
' field in the dialog box when it is activated. The
' default is to leave the File Name field blank.
' InitialDir -- the directory/folder which should be active when the
' dialog box is activated. The default is the current
' directory.
'
' Methods:
' GetFileSpec() -- this function activates the dialog box and then returns
' the full path and filename of the file that the User
' has selected. If the User clicks Cancel, a zero
' length string is returned.
'
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Private strDialogTitle As String
Private intDefaultType As Integer
Private strNewTypes As String
Private strInitialFile As String
Private strInitialDir As String
Private strFilter As String
Private strFltrLst As String
Private strFltrCnt As String
' This 'Method' routine displays the Open dialog box for the user to
' locate the desired file. Returns the full path to the file.
'
Public Function GetFileSpec()
Dim of As OPENFILENAME
Dim intRet As Integer
'set up the file filter and the default type option
If strNewTypes <> "" Then
of.lpstrFilter = strNewTypes & strFilter
of.nFilterIndex = 1
Else
of.lpstrFilter = strFilter
If intDefaultType <> 0 Then
of.nFilterIndex = intDefaultType
Else
of.nFilterIndex = 1
End If
End If
'define some other dialog options
of.lpstrTitle = strDialogTitle
of.lpstrInitialDir = strInitialDir
of.lpstrFile = strInitialFile & String(512 - Len(strInitialFile), 0)
of.nMaxFile = 511
' Initialize other parts of the structure
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrDefExt = vbNullChar
of.Flags = 0
of.lStructSize = Len(of)
'call the Open dialog routine
intRet = GetOpenFileName(of)
If intRet Then
GetFileSpec = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
Else
GetFileSpec = ""
End If
End Function 'End of GetFileSpec
Public Property Let DialogTitle(strTitle As String)
'store the title for the dialog box
strDialogTitle = strTitle
End Property
Public Property Let AdditionalTypes(strAddTypes As String)
Dim Posn As Integer
Dim i As Integer
'don't accept additional types if a default type has been specified
If intDefaultType <> 0 Then
MsgBox "You cannot add to the file type filter if a default type is " & _
"being specified in the DefaultType property. When the " & _
"AdditionalTypes property is used, that item " & _
"is used as the default in the file type filter.", vbCritical, _
"Browse For File Dialog"
Exit Property
End If
'check for the "|" delimiter
Posn = InStr(strAddTypes, "|")
'save the new parameter or report an error
If Posn = 0 Then
MsgBox "The AdditionalTypes property string does not contain at least " & _
"one " & Chr$(34) & "|" & Chr$(34) & " character. " & _
"You must specify an AdditionalTypes property in the same " & _
"format that is shown in the " & _
"following example: " & vbCrLf & vbCrLf & Chr$(34) & _
"My Files (*.mf1;*.mf2) | *.mf1;*.mf2 | Your Files (*.yf1;*.yf2) *.yf1;*.yf2" _
& Chr$(34), vbCritical, "Browse For File Dialog"
strNewTypes = ""
Exit Property
Else
Do While True
If InStr(1, strAddTypes, "|") Then
strNewTypes = strNewTypes & Left$(strAddTypes, _
InStr(1, strAddTypes, "|") - 1) & vbNullChar
strAddTypes = Mid$(strAddTypes, InStr(1, strAddTypes, "|") + 1)
Else
strNewTypes = strNewTypes & vbNullChar
Exit Do
End If
Loop
End If
End Property 'End of AdditionalTypes
Public Property Let DefaultType(strType As String)
Dim Posn As Integer
Posn = InStr(strFltrLst, strType)
'don't accept a default if new types are being specified
If strNewTypes <> "" Then
MsgBox "You cannot set the DefaultType property if you are using the " & _
"AdditionalTypes property to expand the file types filter. " & _
"In that case the type specified in the AdditionalTypes property " & _
"will be the default type.", vbCritical, "Browse For File Dialog"
Exit Property
'make sure the selected default actually exists
ElseIf Posn = 0 Then
MsgBox "The file type you specified in the DefaultType " & _
"property is not in the built-in " & _
"list of file types. You must either specify one of the " & _
"built-in file types or use the AdditionalTypes property " & _
"to specify a complete entry similar to the " & _
"following example: " & vbCrLf & vbCrLf & Chr$(34) & _
"My Files (*.mf) | *.mf" & Chr$(34), vbCritical, _
"Browse For File Dialog"
Exit Property
Else
'set up the selected default
intDefaultType = Trim$(Mid$(strFltrCnt, Posn, 3))
End If
End Property
Public Property Let InitialFile(strIFile As String)
strInitialFile = strIFile
End Property
Public Property Let InitialDir(strIDir As String)
strInitialDir = strIDir
End Property
' This routine initializes the string constants that are used by this class
'
Private Sub Class_Initialize()
'define some initial conditions
strDialogTitle = "Browse For a File"
strInitialDir = ""
strInitialFile = ""
strNewTypes = ""
'define the filter string and the look-up strings
strFilter = "All Files (*.*)" & vbNullChar & "*.*" & vbNullChar & _
"Text Files (*.txt;*.prn;*.csv)" & vbNullChar & "*.txt;*.prn;*.csv" & vbNullChar & _
"Word Documents (*.doc)" & vbNullChar & "*.doc" & vbNullChar & _
"Word Templates (*.dot)" & vbNullChar & "*.dot" & vbNullChar & _
"Rich Text Files (*.rtf)" & vbNullChar & "*.rtf" & vbNullChar & _
"Excel Files (*.xls)" & vbNullChar & "*.xls" & vbNullChar & _
"Databases (*.mdb;*.accdb)" & vbNullChar & "*.mdb;*.accdb" & vbNullChar & _
"Personal Document Format (*.pdf)" & vbNullChar & "*.pdf" & vbNullChar & _
"HTML Documents (*.html;*.htm)" & vbNullChar & "*.html;*.htm" & vbNullChar
strFltrLst = "*.* *.txt *.prn *.csv *.doc *.dot *.rtf *.xls *.mdb *.accdb *.pdf *.html *.htm"
strFltrCnt = " 1 2 2 2 3 4 5 6 7 7 8 9 9"
End Sub
这是第二个模块modBackup-
Option Compare Database
Option Explicit
Declare Function CopyFile& Lib "kernel32" Alias "CopyFileA" (ByVal _
lpExistingFilename As String, ByVal lbNewFileName As String, ByVal _
bFailIfExists As Long)
Public AllowClose As Boolean
Public Sub MakeFileCopy(strExistingFile As String, _
strNewfile As String, _
blnDoNotOverWrite As Boolean, _
Optional blnShowMessage As Boolean = False)
Dim strMessage As String
strExistingFile = strExistingFile
strNewfile = strNewfile
If CopyFile(strExistingFile, strNewfile, blnDoNotOverWrite) = 1 Then
strMessage = "File successfully copied."
Else
strMessage = "File copy failed."
End If
If blnShowMessage Then
MsgBox strMessage, vbInformation, "Copy File"
End If
End Sub
Public Function BackUp(strBackEnd As String, strBackUp As String) As Boolean
Const FILEINUSE = 3356
Dim dbs As DAO.Database
Dim strMessage As String
Dim strBackUpTemp As String
' if back up file exists get user confirmation
' to delete it
If Dir(strBackUp) <> "" Then
strMessage = "Delete existing file " & strBackUp & "?"
If MsgBox(strMessage, vbQuestion + vbYesNo, "Confirm") = vbNo Then
strMessage = "Back up aborted."
MsgBox strMessage, vbInformation, "Back up"
Exit Function
Else
' make temporary copy of backend file and then delete it
strBackUpTemp = Left(strBackUp, InStr(strBackUp, ".")) & "bak"
MakeFileCopy strBackUp, strBackUpTemp, False
Kill strBackUp
End If
End If
On Error Resume Next
' attempt to open backend exclusively
Set dbs = OpenDatabase(Name:=strBackEnd, Options:=True)
Select Case Err.Number
Case 0
' no error so proceed
dbs.Close
Application.CompactRepair strBackEnd, strBackUp
If Err.Number = FILEINUSE Then
' file in use by current user
strMessage = "The file " & strBackEnd & _
" is currently unavailable. " & _
" You may have a table in it open."
MsgBox strMessage
' rename temporary copy of back up file
' if exists, back to original
If Dir(strBackUpTemp) <> "" Then
MakeFileCopy strBackUpTemp, strBackUp, False
Kill strBackUpTemp
End If
Exit Function
Else
On Error GoTo 0
' ensure back up file created
If Dir(strBackUp) = Mid(strBackUp, InStrRev(strBackUp, "\") + 1) Then
strMessage = "Back up successfully carried out."
BackUp = True
' delete temporary copy of back up file if exists
On Error Resume Next
Kill strBackUpTemp
On Error GoTo 0
Else
strMessage = "Back up failed."
' rename temporary copy of back up file
' if exists, back to original
If Dir(strBackUpTemp) <> "" Then
MakeFileCopy strBackUpTemp, strBackUp, False
Kill strBackUpTemp
End If
End If
MsgBox strMessage, vbInformation, "Back up"
End If
Case FILEINUSE
' file in use - inform user
strMessage = "The file " & strBackEnd & _
" is currently unavailable. " & _
" It may be in use by another user."
MsgBox strMessage
' rename temporary copy of back up file,
' if exists, back to original
If Dir(strBackUpTemp) <> "" Then
MakeFileCopy strBackUpTemp, strBackUp, False
Kill strBackUpTemp
End If
Case Else
' unknown error - inform user
MsgBox Err.Description, vbExclamation, "Error"
' rename temporary copy of back up file
' if exists, back to original
If Dir(strBackUpTemp) <> "" Then
MakeFileCopy strBackUpTemp, strBackUp, False
Kill strBackUpTemp
End If
End Select
End Function
Public Function GetBackEndPath() As Variant
GetBackEndPath = DLookup("BackEndPath", "FileLocations")
End Function
Public Function GetBackUpPath() As Variant
GetBackUpPath = DLookup("BackUpPath", "FileLocations")
End Function
我100％不确定CheckLinks子例程应该查找哪个错误。我试图找到一些有关不同错误的信息，例如3024和3044，但是它们没有为我提供有关这些错误代码与该例程的关联程度的任何有用信息。
古怪的部分是原始的“模板”数据库在各个方面都可以完美运行。我复制/粘贴了所有模块，例程，表单等，并使其成为自己的“所有者”以与宿主数据库的样式和主题匹配，但现在它们不起作用了。我到底在做什么错了？
谢谢！
答案 0 :(得分：0)
所以我弄清楚了问题所在。初始形式不得与任何数据绑定。它不需要依赖后端即可加载“ 到重点”来执行执行子例程，以检查适当的后端文件。