تغيير مسار قاعدة البيانات ACCESS

قائمة أدوات ---> أدوات مساعدة لقاعدة البيانات ---> إدارة الجداول المرتبطة

شكرا للاخ الكريم مهند عبادي ولقد استفدت من معلوماتك ولكن جاتني مشكله جديده وهي :

عندما غيرت مسار الجداول في قاعدة البيانات الى مجلد في فلاش مومري المشكلة ادا وضعته في كمبيوتر البيت يكون اسم القرص H وادا وضعته في العمل يكون G

اتمنى ان اجد حلا ادا امكن

Assalamu alaykum,

use 2 functions at startup ..

Follow the steps

1- fRefreshLinks To check for the tables

2- if the path is not correct u must call the 2nd fucntion which will open the wndow 2 get the path of the TABLES

here's the 1st func

1-

'***************** Code Start ***************

'

Function fRefreshLinks() As Boolean

Dim strMsg As String, collTbls As Collection

Dim i As Integer, strDBPath As String, strTbl As String

Dim dbCurr As DATABASE, dbLink As DATABASE

Dim tdfLocal As TableDef

Dim varRet As Variant

Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000

Const cERR_NOREMOTETABLE = vbObjectError + 2000

On Local Error GoTo fRefreshLinks_Err

If MsgBox("Are you sure you want to reconnect all Access tables?", _

vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise cERR_USERCANCEL

'First get all linked tables in a collection

Set collTbls = fGetLinkedTables

'now link all of them

Set dbCurr = CurrentDb

strMsg = "Do you wish to specify a different path for the Access Tables?"

If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then

strNewPath = fGetMDBName("Please select a new datasource")

Else

strNewPath = vbNullString

End If

For i = collTbls.Count To 1 Step -1

strDBPath = fParsePath(collTbls(i))

strTbl = fParseTable(collTbls(i))

varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")

If Left$(strDBPath, 4) = "ODBC" Then

'ODBC Tables

'ODBC Tables handled separately

' Set tdfLocal = dbCurr.TableDefs(strTbl)

' With tdfLocal

' .Connect = pcCONNECT

' .RefreshLink

' collTbls.Remove (strTbl)

' End With

Else

If strNewPath <> vbNullString Then

'Try this first

strDBPath = strNewPath

Else

If Len(Dir(strDBPath)) = 0 Then

'File Doesn't Exist, call GetOpenFileName

strDBPath = fGetMDBName("'" & strDBPath & "' not found.")

If strDBPath = vbNullString Then

'user pressed cancel

Err.Raise cERR_USERCANCEL

End If

End If

End If

'backend database exists

'putting it here since we could have

'tables from multiple sources

Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

'check to see if the table is present in dbLink

strTbl = fParseTable(collTbls(i))

If fIsRemoteTable(dbLink, strTbl) Then

'everything's ok, reconnect

Set tdfLocal = dbCurr.TableDefs(strTbl)

With tdfLocal

.Connect = ";Database=" & strDBPath

.RefreshLink

collTbls.Remove (.Name)

End With

Else

Err.Raise cERR_NOREMOTETABLE

End If

End If

Next

fRefreshLinks = True

varRet = SysCmd(acSysCmdClearStatus)

MsgBox "All Access tables were successfully reconnected.", _

vbInformation + vbOKOnly, _

"Success"

fRefreshLinks_End:

Set collTbls = Nothing

Set tdfLocal = Nothing

Set dbLink = Nothing

Set dbCurr = Nothing

Exit Function

fRefreshLinks_Err:

fRefreshLinks = False

Select Case Err

Case 3059:

Case cERR_USERCANCEL:

MsgBox "No Database was specified, couldn't link tables.", _

vbCritical + vbOKOnly, _

"Error in refreshing links."

Resume fRefreshLinks_End

Case cERR_NOREMOTETABLE:

MsgBox "Table '" & strTbl & "' was not found in the database" & _

vbCrLf & dbLink.Name & ". Couldn't refresh links", _

vbCritical + vbOKOnly, _

"Error in refreshing links."

Resume fRefreshLinks_End

Case Else:

strMsg = "Error Information..." & vbCrLf & vbCrLf

strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf

strMsg = strMsg & "Description: " & Err.Description & vbCrLf

strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf

MsgBox strMsg, vbOKOnly + vbCritical, "Error"

Resume fRefreshLinks_End

End Select

End Function

Function fIsRemoteTable(dbRemote As DATABASE, strTbl As String) As Boolean

Dim tdf As TableDef

On Error Resume Next

Set tdf = dbRemote.TableDefs(strTbl)

fIsRemoteTable = (Err = 0)

Set tdf = Nothing

End Function

Function fGetMDBName(strIn As String) As String

'Calls GetOpenFileName dialog

Dim strFilter As String

strFilter = ahtAddFilterItem(strFilter, _

"Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _

"*.mdb; *.mda; *.mde; *.mdw")

strFilter = ahtAddFilterItem(strFilter, _

"All Files (*.*)", _

"*.*")

fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _

OpenFile:=True, _

DialogTitle:=strIn, _

Flags:=ahtOFN_HIDEREADONLY)

End Function

Function fGetLinkedTables() As Collection

'Returns all linked tables

Dim collTables As New Collection

Dim tdf As TableDef, db As DATABASE

Set db = CurrentDb

db.TableDefs.Refresh

For Each tdf In db.TableDefs

With tdf

If Len(.Connect) > 0 Then

If Left$(.Connect, 4) = "ODBC" Then

' collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name

'ODBC Reconnect handled separately

Else

collTables.Add Item:=.Name & .Connect, Key:=.Name

End If

End If

End With

Next

Set fGetLinkedTables = collTables

Set collTables = Nothing

Set tdf = Nothing

Set db = Nothing

End Function

Function fParsePath(strIn As String) As String

If Left$(strIn, 4) <> "ODBC" Then

fParsePath = Right(strIn, Len(strIn) _

- (InStr(1, strIn, "DATABASE=") + 8))

Else

fParsePath = strIn

End If

End Function

Function fParseTable(strIn As String) As String

fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)

End Function

'***************** Code End ***************

2- To Get the path

***************** Code Start **************

Type tagOPENFILENAME

lStructSize As Long

hwndOwner As Long

hInstance As Long

strFilter As String

strCustomFilter As String

nMaxCustFilter As Long

nFilterIndex As Long

strFile As String

nMaxFile As Long

strFileTitle As String

nMaxFileTitle As Long

strInitialDir As String

strTitle As String

Flags As Long

nFileOffset As Integer

nFileExtension As Integer

strDefExt As String

lCustData As Long

lpfnHook As Long

lpTemplateName As String

End Type

Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _

Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean

Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _

Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean

Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Global Const ahtOFN_READONLY = &H1

Global Const ahtOFN_OVERWRITEPROMPT = &H2

Global Const ahtOFN_HIDEREADONLY = &H4

Global Const ahtOFN_NOCHANGEDIR = &H8

Global Const ahtOFN_SHOWHELP = &H10

' You won't use these.

'Global Const ahtOFN_ENABLEHOOK = &H20

'Global Const ahtOFN_ENABLETEMPLATE = &H40

'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80

Global Const ahtOFN_NOVALIDATE = &H100

Global Const ahtOFN_ALLOWMULTISELECT = &H200

Global Const ahtOFN_EXTENSIONDIFFERENT = &H400

Global Const ahtOFN_PATHMUSTEXIST = &H800

Global Const ahtOFN_FILEMUSTEXIST = &H1000

Global Const ahtOFN_CREATEPROMPT = &H2000

Global Const ahtOFN_SHAREAWARE = &H4000

Global Const ahtOFN_NOREADONLYRETURN = &H8000

Global Const ahtOFN_NOTESTFILECREATE = &H10000

Global Const ahtOFN_NONETWORKBUTTON = &H20000

Global Const ahtOFN_NOLONGNAMES = &H40000

' New for Windows 95

Global Const ahtOFN_EXPLORER = &H80000

Global Const ahtOFN_NODEREFERENCELINKS = &H100000

Global Const ahtOFN_LONGNAMES = &H200000

Function TestIt()

Dim strFilter As String

Dim lngFlags As Long

strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _

"*.MDA;*.MDB")

strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")

strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")

strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")

MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _

Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _

DialogTitle:="Hello! Open Me!")

' Since you passed in a variable for lngFlags,

' the function places the output flags value in the variable.

Debug.Print Hex(lngFlags)

End Function

Function GetOpenFile(Optional varDirectory As Variant, _

Optional varTitleForDialog As Variant) As Variant

' Here's an example that gets an Access database name.

Dim strFilter As String

Dim lngFlags As Long

Dim varFileName As Variant

' Specify that the chosen file must already exist,

' don't change directories when you're done

' Also, don't bother displaying

' the read-only box. It'll only confuse people.

lngFlags = ahtOFN_FILEMUSTEXIST Or _

ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR

If IsMissing(varDirectory) Then

varDirectory = ""

End If

If IsMissing(varTitleForDialog) Then

varTitleForDialog = ""

End If

' Define the filter string and allocate space in the "c"

' string Duplicate this line with changes as necessary for

' more file templates.

strFilter = ahtAddFilterItem(strFilter, _

"Access (*.mdb)", "*.MDB;*.MDA")

' Now actually call to get the file name.

varFileName = ahtCommonFileOpenSave( _

OpenFile:=True, _

InitialDir:=varDirectory, _

Filter:=strFilter, _

Flags:=lngFlags, _

DialogTitle:=varTitleForDialog)

If Not IsNull(varFileName) Then

varFileName = TrimNull(varFileName)

End If

GetOpenFile = varFileName

End Function

Function ahtCommonFileOpenSave( _

Optional ByRef Flags As Variant, _

Optional ByVal InitialDir As Variant, _

Optional ByVal Filter As Variant, _

Optional ByVal FilterIndex As Variant, _

Optional ByVal DefaultExt As Variant, _

Optional ByVal FileName As Variant, _

Optional ByVal DialogTitle As Variant, _

Optional ByVal hwnd As Variant, _

Optional ByVal OpenFile As Variant) As Variant

' This is the entry point you'll use to call the common

' file open/save dialog. The parameters are listed

' below, and all are optional.

'

' In:

' Flags: one or more of the ahtOFN_* constants, OR'd together.

' InitialDir: the directory in which to first look

' Filter: a set of file filters, set up by calling

' AddFilterItem. See examples.

' FilterIndex: 1-based integer indicating which filter

' set to use, by default (1 if unspecified)

' DefaultExt: Extension to use if the user doesn't enter one.

' Only useful on file saves.

' FileName: Default value for the file name text box.

' DialogTitle: Title for the dialog.

' hWnd: parent window handle

' OpenFile: Boolean(True=Open File/False=Save As)

' Out:

' Return Value: Either Null or the selected filename

Dim OFN As tagOPENFILENAME

Dim strFileName As String

Dim strFileTitle As String

Dim fResult As Boolean

' Give the dialog a caption title.

If IsMissing(InitialDir) Then InitialDir = CurDir

If IsMissing(Filter) Then Filter = ""

If IsMissing(FilterIndex) Then FilterIndex = 1

If IsMissing(Flags) Then Flags = 0&

If IsMissing(DefaultExt) Then DefaultExt = ""

If IsMissing(FileName) Then FileName = ""

If IsMissing(DialogTitle) Then DialogTitle = ""

If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp

If IsMissing(OpenFile) Then OpenFile = True

' Allocate string space for the returned strings.

strFileName = Left(FileName & String(256, 0), 256)

strFileTitle = String(256, 0)

' Set up the data structure before you call the function

With OFN

.lStructSize = Len(OFN)

.hwndOwner = hwnd

.strFilter = Filter

.nFilterIndex = FilterIndex

.strFile = strFileName

.nMaxFile = Len(strFileName)

.strFileTitle = strFileTitle

.nMaxFileTitle = Len(strFileTitle)

.strTitle = DialogTitle

.Flags = Flags

.strDefExt = DefaultExt

.strInitialDir = InitialDir

' Didn't think most people would want to deal with

' these options.

.hInstance = 0

'.strCustomFilter = ""

'.nMaxCustFilter = 0

.lpfnHook = 0

'New for NT 4.0

.strCustomFilter = String(255, 0)

.nMaxCustFilter = 255

End With

' This will pass the desired data structure to the

' Windows API, which will in turn it uses to display

' the Open/Save As Dialog.

If OpenFile Then

fResult = aht_apiGetOpenFileName(OFN)

Else

fResult = aht_apiGetSaveFileName(OFN)

End If

' The function call filled in the strFileTitle member

' of the structure. You'll have to write special code

' to retrieve that if you're interested.

If fResult Then

' You might care to check the Flags member of the

' structure to get information about the chosen file.

' In this example, if you bothered to pass in a

' value for Flags, we'll fill it in with the outgoing

' Flags value.

If Not IsMissing(Flags) Then Flags = OFN.Flags

ahtCommonFileOpenSave = TrimNull(OFN.strFile)

Else

ahtCommonFileOpenSave = vbNullString

End If

End Function

Function ahtAddFilterItem(strFilter As String, _

strDescription As String, Optional varItem As Variant) As String

' Tack a new chunk onto the file filter.

' That is, take the old value, stick onto it the description,

' (like "Databases"), a null character, the skeleton

' (like "*.mdb;*.mda") and a final null character.

If IsMissing(varItem) Then varItem = "*.*"

ahtAddFilterItem = strFilter & _

strDescription & vbNullChar & _

varItem & vbNullChar

End Function

Private Function TrimNull(ByVal strItem As String) As String

Dim intPos As Integer

intPos = InStr(strItem, vbNullChar)

If intPos > 0 Then

TrimNull = Left(strItem, intPos - 1)

Else

TrimNull = strItem

End If

End Function

'************** Code End *****************

شكرا للاخت جنان

والمشكلة اعتقد ما لها حل لانها من نظام الويندوز لان بعطينى في كل جهاز حرف مختلف لنفس الدسك مرة بيطلع H ومرة G و هذا يسبب مشكلة في ارتباط الجداول

وهل بستطاعتي عمل مسارين لقاعدة البيانات؟

يا أخي هذه الfunctions تتيح لك انتقاء مسارات الجداول منذ البداية -startup أليس هذا ما تريد ؟؟؟

شكرا للاخت جنان

يسرني ان احصل على حل وطبعا كلامك صحيح اهم شي موقع قاعدة الجداول

ولكن ممكن توضحي عملية startup + لfunctions ?? وانتقاء الجداول