حل لمن يعاني من رسالة The code in this project must be updated for use on 64-bit system

مشكور اخي سليم

وتكملة للمعلومه جزاك الله خير 

قم باستبدال declare Function    الي   declare PtrSafe Function 

السلام عليكم و رحمة الله و بركاته

أخي الكريم قمت بما ذكرته في موضوعك هنا و نقلت القاعدة الى جهاز آخر عليه 64-bit فلم يتم الامر و هذا ما قمت به من تحويل فهل هناك امر آخر يجب اجراؤه ؟؟

Option Compare Database

Global Const SW_HIDE = 0
Private declare PtrSafe Function apiShowWindow Lib "user32" _
    Alias "ShowWindow" (ByVal hwnd As Long, _
          ByVal nCmdShow As Long) As Long

Function fSetAccessWindow(nCmdShow As Long)
Dim loX  As Long
Dim loForm As Form
loX = apiShowWindow(hWndAccessApp, nCmdShow)
End Function

Private declare PtrSafe  Function ts_apiGetOpenFileName Lib "comdlg32.dll" _
 Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean

Private declare PtrSafe  Function ts_apiGetSaveFileName Lib "comdlg32.dll" _
 Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean

Private declare PtrSafe  Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Private Type tsFileName
   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

' Flag Constants
Public Const tscFNAllowMultiSelect = &H200
Public Const tscFNCreatePrompt = &H2000
Public Const tscFNExplorer = &H80000
Public Const tscFNExtensionDifferent = &H400
Public Const tscFNFileMustExist = &H1000
Public Const tscFNPathMustExist = &H800
Public Const tscFNNoValidate = &H100
Public Const tscFNHelpButton = &H10
Public Const tscFNHideReadOnly = &H4
Public Const tscFNLongNames = &H200000
Public Const tscFNNoLongNames = &H40000
Public Const tscFNNoChangeDir = &H8
Public Const tscFNReadOnly = &H1
Public Const tscFNOverwritePrompt = &H2
Public Const tscFNShareAware = &H4000
Public Const tscFNNoReadOnlyReturn = &H8000
Public Const tscFNNoDereferenceLinks = &H100000

Public Function tsGetFileFromUser( _
 Optional ByRef rlngflags As Long = 0&, _
 Optional ByVal strInitialDir As String = "", _
 Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _
 Optional ByVal lngFilterIndex As Long = 1, _
 Optional ByVal strDefaultExt As String = "", _
 Optional ByVal strFileName As String = "", _
 Optional ByVal strDialogTitle As String = "", _
 Optional ByVal fOpenFile As Boolean = True) As Variant
   
   On Error GoTo tsGetFileFromUser_Err
   Dim tsFN As tsFileName
   Dim strFileTitle As String
   Dim fResult As Boolean

   ' Allocate string space for the returned strings.
   strFileName = Left(strFileName & String(256, 0), 256)
   strFileTitle = String(256, 0)

   ' Set up the data structure before you call the function
   With tsFN
      .lStructSize = Len(tsFN)
      .hwndOwner = Application.hWndAccessApp
      .strFilter = strFilter
      .nFilterIndex = lngFilterIndex
      .strFile = strFileName
      .nMaxFile = Len(strFileName)
      .strFileTitle = strFileTitle
      .nMaxFileTitle = Len(strFileTitle)
      .strTitle = strDialogTitle
      .Flags = rlngflags
      .strDefExt = strDefaultExt
      .strInitialDir = strInitialDir
      .hInstance = 0
      .strCustomFilter = String(255, 0)
      .nMaxCustFilter = 255
      .lpfnHook = 0
   End With
   
   ' Call the function in the windows API
   If fOpenFile Then
      fResult = ts_apiGetOpenFileName(tsFN)
   Else
      fResult = ts_apiGetSaveFileName(tsFN)
   End If

   ' If the function call was successful, return the FileName chosen
   ' by the user.  Otherwise return null.  Note, the CancelError property
   ' used by the ActiveX Common Dialog control is not needed.  If the
   ' user presses Cancel, this function will return Null.
   If fResult Then
      rlngflags = tsFN.Flags
      tsGetFileFromUser = tsTrimNull(tsFN.strFile)
   Else
      tsGetFileFromUser = Null
   End If
   
tsGetFileFromUser_End:
   On Error GoTo 0
   Exit Function

tsGetFileFromUser_Err:
   Beep
   MsgBox Err.Description, , "Error: " & Err.Number _
    & " in function basBrowseFiles.tsGetFileFromUser"
   Resume tsGetFileFromUser_End

End Function

' Trim Nulls from a string returned by an API call.

Private Function tsTrimNull(ByVal strItem As String) As String
   
   On Error GoTo tsTrimNull_Err
   Dim I As Integer
   
   I = InStr(strItem, vbNullChar)
   If I > 0 Then
       tsTrimNull = Left(strItem, I - 1)
   Else
       tsTrimNull = strItem
   End If
    
tsTrimNull_End:
   On Error GoTo 0
   Exit Function

tsTrimNull_Err:
   Beep
   MsgBox Err.Description, , "Error: " & Err.Number _
    & " in function basBrowseFiles.tsTrimNull"
   Resume tsTrimNull_End

End Function

Option Compare Database
Option Explicit

Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Function OpenFile(sFileName As String)
On Error GoTo Err_OpenFile

    OpenFile = ShellExecute(Application.hWndAccessApp, "Open", sFileName, "", "C:\", 1)

Exit_OpenFile:
    Exit Function

Err_OpenFile:
    MsgBox Err.Number & " - " & Err.Description
    Resume Exit_OpenFile

End Function

Option Compare Database
Option Explicit

Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
  strInitialDir As String
End Type

Private Declare PtrSafe  Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare PtrSafe  Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function BrowseFolder(Optional szDialogTitle As String, _
                            Optional szInitialDir As String) As String

  Dim x As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .strInitialDir = szInitialDir
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If
End Function

Option Compare Database
Option Explicit
Private Type SHITEMID 'mkid
    cb As Long
    abID As Byte
End Type

Private Type ITEMIDLIST 'idl
    mkid As SHITEMID
End Type

Private Type BROWSEINFO 'bi
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare PtrSafe  Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Private Declare PtrSafe  Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Private Const BIF_RETURNONLYFSDIRS = &H1

Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Private Const FO_MOVE As Long = &H1
Private Const FO_COPY As Long = &H2
Private Const FO_DELETE As Long = &H3
Private Const FO_RENAME As Long = &H4

Private Const FOF_MULTIDESTFILES As Long = &H1
Private Const FOF_CONFIRMMOUSE As Long = &H2
Private Const FOF_SILENT As Long = &H4
Private Const FOF_RENAMEONCOLLISION As Long = &H8
Private Const FOF_NOCONFIRMATION As Long = &H10
Private Const FOF_WANTMAPPINGHANDLE As Long = &H20
Private Const FOF_CREATEPROGRESSDLG As Long = &H0
Private Const FOF_ALLOWUNDO As Long = &H40
Private Const FOF_FILESONLY As Long = &H80
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Const FOF_NOCONFIRMMKDIR As Long = &H200

Private Declare PtrSafe  Function apiSHFileOperation Lib "shell32.dll" _
            Alias "SHFileOperationA" _
            (lpFileOp As SHFILEOPSTRUCT) _
            As Long

Function fMakeBackup() As Boolean
Dim strMsg As String
Dim tshFileOp As SHFILEOPSTRUCT
Dim lngRet As Long
Dim strSaveFile As String
Dim lngFlags As Long
Dim FolderToCopy
Const cERR_USER_CANCEL = vbObjectError + 1
Const cERR_DB_EXCLUSIVE = vbObjectError + 2
    On Local Error GoTo fMakeBackup_Err

    If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE
    
    strMsg = "åá ÊÑíÏ Úãá äÓÎÉ ÅÍÊíÇØíÉ áåÐÇ ÇáÈÑäÇãÌ ¿"
 If MsgBox(strMsg, vbQuestion + vbYesNo + vbMsgBoxRight + _
    vbMsgBoxRtlReading, "ÊÃßíÏ ÇáäÓÎ") = vbNo Then _
            Err.Raise cERR_USER_CANCEL
            
    lngFlags = FOF_SIMPLEPROGRESS Or _
                            FOF_FILESONLY Or _
                            FOF_RENAMEONCOLLISION
    strSaveFile = CurrentDb.Name
    With tshFileOp
        .wFunc = FO_COPY
        .hwnd = hWndAccessApp
        .pFrom = CurrentDb.Name & vbNullChar
        FolderToCopy = BrowseForFolder
        If Len(FolderToCopy & "") = 1 Then
        Exit Function
        Else
        .pTo = FolderToCopy
        End If
        .fFlags = lngFlags
    End With
    lngRet = apiSHFileOperation(tshFileOp)
    fMakeBackup = (lngRet = 0)
    
fMakeBackup_End:
    Exit Function
fMakeBackup_Err:
    fMakeBackup = False
    Select Case Err.Number
        Case cERR_USER_CANCEL:
            'do nothing
        Case cERR_DB_EXCLUSIVE:
 MsgBox "The current database " & vbCrLf & CurrentDb.Name & vbCrLf & _
 vbCrLf & "is opened exclusively.  Please reopen in shared mode" & _
  " and try again.", vbCritical + vbOKOnly, "Database copy failed"
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fMakeBackup" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbInformation, "fMakeBackup"

    End Select
    Resume fMakeBackup_End
End Function

Private Function fCurrentDBDir() As String

Dim strDBPath As String
Dim strDBFile As String
    strDBPath = CurrentDb.Name
    strDBFile = Dir(strDBPath)
    fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)
End Function

Function fDBExclusive() As Integer
Dim hFile As Integer
    hFile = FreeFile
    On Error Resume Next
    Select Case Err
        Case 0
            fDBExclusive = False
        Case 70
            fDBExclusive = True
        Case Else
            fDBExclusive = Err
    End Select
    Close hFile
    On Error GoTo 0
End Function


Private Sub ÃãÑ0_Click()
Call fMakeBackup
End Sub

Private Function BrowseForFolder()
Dim bi As BROWSEINFO
Dim IDL As ITEMIDLIST
Dim pidl As Long
Dim r As Long
Dim pos As Integer
Dim spath As String
Dim lblSelected As String
bi.pidlRoot = 0&
bi.lpszTitle = "ÍÏÏ æÌåÉ ÇáäÓÎÉ ÇáÃÍÊíÇØíÉ :"
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl& = SHBrowseForFolder(bi)
spath$ = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal spath$)
If r Then
pos = InStr(spath$, Chr$(0))
'pos = spath
lblSelected = Left(spath$, pos - 0)
Else: lblSelected = ""
End If
BrowseForFolder = lblSelected & "\"
End Function

السلام عليكم

هل من حل يمكن من خلاله جعل الوحدات النمطية او الكودات تعمل على الـ bit-64 أو الـ 32- bit في نفس الوقت و دون الحاجة لاي تعديل حين يتم نقل قاعدة البيانات من جهاز لآخر ؟؟

والله يا إخوان أكثر شي نعانيه هو هذه المشكلة . 

هل من حل لها .

هل من حل لهذه المشكلة .

وعليكم السلام :)

هذا الرابط لأختنا الفاضلة الدكتورة أم عهود حفظها الله ، وفيه المطلوب :)

/index.php/topic/288430-هل-يمكن-جعل-الوحدات-النمطية-او-الكودات-تعمل-على-ا/?p=1382204

جعفر

أخي الغالي لكن المشكلة عند تحويل القاعدة إلى ACCDE