كود لا يعمل مع اكسيس 2016 - 64بت

[علي المصري]

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

الكود التالي

يعمل جيد مع 32بت ولا يعمل مع ال 64بت

يرحى التعديل مع الشكر

Private Sub zer1_Click()

On Error GoTo ErrHandler
'
Dim Filename As Variant
Dim SourceFile, DestinationFile
Dim picturepaht
 picturepaht = GetOpenFile_CLT("", "ÇÎÊÑ ÕæÑÉ :")
     With picturepaht
        If picturepaht <> "" Then
            Me.imgLogo.Picture = picturepaht
            logo = picturepaht
              Else
            MsgBox "No image selected."


        End If
    End With
  SourceFile = logo
 DestinationFile = CurrentProject.Path & "\" & "shar" & ".jpg"
 FileCopy SourceFile, DestinationFile
 MsgBox "Êã ÊÛííÑ ÇáÔÚÇÑ"
ErrHandler:
    If Err.Number = 94 Then
        imgLogo.Picture = CurrentProject.Path & "\" & "shar" & ".jpg"
 MsgBox " áã íÊã ÊÛííÑ ÇáÔÚÇÑ"
     End If
End Sub

 

GetOpenFile_CLT("", "اختر صورة")

MsgBox "لم يتم تغيير الشعار"

 

Option Compare Database

Private Type CLTAPI_OPENFILE
  strFilter As String
  intFilterIndex As Long
  strInitialDir As String
  strInitialFile As String
  strDialogTitle As String
  strDefaultExtension As String
  lngFlags As Long
  strFullPathReturned As String
  strFileNameReturned As String
  intFileOffset As Integer
  intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Private Type CLTAPI_WINOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    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 String
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10


#If Win64 = 1 And VBA7 = 1 Then
Declare PtrSafe Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As CLTAPI_WINOPENFILENAME) _
As LongPtr

Declare PtrSafe Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As CLTAPI_WINOPENFILENAME) _
As LongPtr

Declare PtrSafe Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" _
(ByVal hWnd As Long, rgb As Long)
#Else
Declare Function CLTAPI_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
  (pOpenfilename As CLTAPI_WINOPENFILENAME) _
As Boolean

Declare Function CLTAPI_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
  (pOpenfilename As CLTAPI_WINOPENFILENAME) _
As Boolean

Declare Sub CLTAPI_ChooseColor Lib "msaccess.exe" Alias "#53" _
  (ByVal hWnd As Long, rgb As Long)
#End If

Function GetOpenFile_CLT(strInitialDir As String, strTitle As String) As String
  Dim fOK As Boolean
  Dim typWinOpen As CLTAPI_WINOPENFILENAME
  Dim typOpenFile As CLTAPI_OPENFILE
  Dim strFilter As String
  
  On Error GoTo PROC_ERR
  
  strFilter = CreateFilterString_CLT("JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0) & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0))
  If strInitialDir <> "" Then
    typOpenFile.strInitialDir = strInitialDir
  Else
    typOpenFile.strInitialDir = CurDir()
  End If
  
  If strTitle <> "" Then
    typOpenFile.strDialogTitle = strTitle
  End If
  
  typOpenFile.strFilter = strFilter
  typOpenFile.lngFlags = OFN_HIDEREADONLY Or OFN_SHOWHELP
  
  ConvertCLT2Win typOpenFile, typWinOpen
  
  fOK = CLTAPI_GetOpenFileName(typWinOpen)
  
  ConvertWin2CLT typWinOpen, typOpenFile
  
  GetOpenFile_CLT = typOpenFile.strFullPathReturned
      
PROC_EXIT:
  Exit Function
  
PROC_ERR:
  GetOpenFile_CLT = ""
  Resume PROC_EXIT

End Function

Sub ConvertCLT2Win(CLT_Struct As CLTAPI_OPENFILE, Win_Struct As CLTAPI_WINOPENFILENAME)
  Dim strFile As String * 512

  On Error GoTo PROC_ERR
  
  Win_Struct.hwndOwner = Application.hWndAccessApp
  Win_Struct.hInstance = 0

  If CLT_Struct.strFilter = "" Then
    Win_Struct.lpstrFilter = ALLFILES & Chr$(0) & "*.*" & Chr$(0)
  Else
    Win_Struct.lpstrFilter = CLT_Struct.strFilter
  End If
  Win_Struct.nFilterIndex = CLT_Struct.intFilterIndex

  Win_Struct.lpstrFile = String(512, 0)
  Win_Struct.nMaxFile = 511
  
  Win_Struct.lpstrFileTitle = String$(512, 0)
  Win_Struct.nMaxFileTitle = 511

  Win_Struct.lpstrTitle = CLT_Struct.strDialogTitle
  Win_Struct.lpstrInitialDir = CLT_Struct.strInitialDir
  Win_Struct.lpstrDefExt = CLT_Struct.strDefaultExtension

  Win_Struct.Flags = CLT_Struct.lngFlags

  Win_Struct.lStructSize = Len(Win_Struct)
  
PROC_EXIT:
  Exit Sub
  
PROC_ERR:
  Resume PROC_EXIT
   
End Sub

Sub ConvertWin2CLT(Win_Struct As CLTAPI_WINOPENFILENAME, CLT_Struct As CLTAPI_OPENFILE)
  '
  On Error GoTo PROC_ERR
      
  CLT_Struct.strFullPathReturned = left(Win_Struct.lpstrFile, InStr(Win_Struct.lpstrFile, vbNullChar) - 1)
  CLT_Struct.strFileNameReturned = RemoveNulls_CLT(Win_Struct.lpstrFileTitle)
  CLT_Struct.intFileOffset = Win_Struct.nFileOffset
  CLT_Struct.intFileExtension = Win_Struct.nFileExtension
  
PROC_EXIT:
  Exit Sub
  
PROC_ERR:
  Resume PROC_EXIT
  
End Sub

Function CreateFilterString_CLT(ParamArray varFilt() As Variant) As String
  Dim strFilter As String
  Dim intCounter As Integer
  Dim intParamCount As Integer

  On Error GoTo PROC_ERR
  
  intParamCount = UBound(varFilt)
  
  If (intParamCount <> -1) Then
    
    For intCounter = 0 To intParamCount
      strFilter = strFilter & varFilt(intCounter) & Chr$(0)
    Next
    
    If (intParamCount Mod 2) = 0 Then
      strFilter = strFilter & "*.*" & Chr$(0)
    End If
    
  End If

  CreateFilterString_CLT = strFilter
  
PROC_EXIT:
  Exit Function
  
PROC_ERR:
  CreateFilterString_CLT = ""
  Resume PROC_EXIT
  
End Function

Function RemoveNulls_CLT(strIn As String) As String
  Dim intChr As Integer

  intChr = InStr(strIn, Chr$(0))

  If intChr > 0 Then
    RemoveNulls_CLT = left$(strIn, intChr - 1)
  Else
    RemoveNulls_CLT = strIn
  End If

End Function

 

تم تعديل أكتوبر 20, 2017 بواسطه علي المصري

[أبو إبراهيم الغامدي]

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

أهلا بك علي..

إذهب إلى مكتبة المراجع واخثر المكتبة الموضحة في الصورة

 

أضف الشفرة التالية إلى وحدة نمطية عامة

Function GetFilePath()
  Dim FDlg As FileDialog
  Set FDlg = FileDialog(msoFileDialogFilePicker)
  FDlg.Title = "Select Picture File"
  FDlg.Filters.Clear
  FDlg.Filters.Add "Pictures", "*.Png,*.Jpg,*.Bmp,*.Tiff,*.Gif"
  FDlg.Filters.Add "All Files", "*.*"
  FDlg.AllowMultiSelect = False
  If FDlg.Show Then
    GetFilePath = FDlg.SelectedItems(1)
    Debug.Print GetFilePath
  End If
End Function

استبدل السطر التالي

picturepaht = GetOpenFile_CLT("", "ÇÎÊÑ ÕæÑÉ :")

بالسطر هذا

picturepaht = GetFilePath()

 

[علي المصري]

جزاك الله خيرا استاذنا الفاضل ابو ابراهيم

هل كل مستخدم للبرنامج الذي يحتوي على هذا الكود يحتاج لاضافة هذه المكتبة

اريد ان يكون البرنامج خالي من هذه النقطة

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

-

[ali_20]

استاذي على 

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

يوجد لدي برنامج للعمل على الاكسس كنت قبل 5 سنوات اقدر اعدل على الصغحات واليوم

نسيت كيف الدخول على الكاينات او الصفحات علماً انني كنت اعدل علية بالاكسل 2003 وحالياً 2010 

 

ارغب ارسالة لشخصكم على الايميل لو تكرمتم لكي لفك الحماية او تشرحلي 

كنت افكة alt +f5 h او cntrl او 

aidl1430@Gmail.com

[jjafferr]

السلام عليكم

 

اخي علي ، وحسب البحث الذي قمت به ، رجاء:

استبدال السطر
Win_Struct.lStructSize = Len(Win_Struct)

بالسطر
Win_Struct.lStructSize = LenB(Win_Struct)

 

او تستطيع ان تستبدل كودك بهذا الكود:

Dim f    As Object 
Set f = Application.FileDialog(3) 
f.AllowMultiSelect = True 
f.Show 

MsgBox "file choosen = " & f.SelectedItems.Count 

 

كما ان الموقع التالي به اداة لعمل الكود المطلوب ، والذي يعمل على 32 و 64 بت، 

http://www.avenius.de/en/index.php?Products:IDBE_Tools

 

جعفر