كيف أقوم بادراج مسار ملف في نموذج ؟

الأخ ابو بشاير

إذا كنت تقصد بالمسار فقط المجلد دون اسم الملف فاستخدم التالي :

أنشئ زر أمر على النموذج وضع في حدث عند النقر :

[اسم الحقل الذي تخزن فيه المسار] = OpenDirectoryTV(Me, "اختر ملف")

وفي أعلى الوحدة النمطية للنموذج ضع الدالة :

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260

Private Type BrowseInfo
   hwndOwner      As Long
   pIDLRoot       As Long
   pszDisplayName As Long
   lpszTitle      As Long
   ulFlags        As Long
   lpfnCallback   As Long
   lParam         As Long
   iImage         As Long
End Type

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long


Public Function OpenDirectoryTV(odtvOwner As Form, Optional odtvTitle As String) As String
   Dim lpIDList As Long
   Dim sBuffer As String
   Dim szTitle As String
   Dim tBrowseInfo As BrowseInfo
   szTitle = odtvTitle
   With tBrowseInfo
      .hwndOwner = odtvOwner.hwnd
      .lpszTitle = lstrcat(szTitle, "")
      .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
   End With
   lpIDList = SHBrowseForFolder(tBrowseInfo)
   If (lpIDList) Then
      sBuffer = Space(MAX_PATH)
      SHGetPathFromIDList lpIDList, sBuffer
      sBuffer = left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
      OpenDirectoryTV = sBuffer
   End If
End Function

أما إذا رغبت في إدراج اسم الملف مع المسار كاملا :

1- أدرج كائن ActiveX المسمى 6Micosoft Common Dialog Control Version

2- غير اسم الكائن الى loComm .

3- في حدث نقر زر أمر ضع التالي :

Dim loComm As CommonDialog
  Dim strFilter As String
  Set loComm = New CommonDialog
  'strFilter = "Access Databases (*.mdb)|*.md?|All Files(*.*)|*.*" ' فلتر لقواعد البيانات
  strFilter = "BMP (*.bmp)|*.bmp|All Files(*.*)|*.*" ' فلتر للصور
  With loComm
    .Filter = strFilter
    .DialogTitle = "استعراض ملفات"
     .ShowOpen
    Me!txtref = .FileName
  End With

علما أن اسم مربع النص الذي تخزن فيه القيمة العائدة في المثال هو txtref .

ولك تحياتي

الأخ / أبو حمود

شكرا جزيلا لتكرمك بالرد سريعا وقد حاولت تطبيق الحل الثاني فظهرت لي الرسالة التالية : ( ليس لديك الترخيص باستخدام عنصر تحكم ActiveX ) مع العلم بأني أعمل على أكسس 97

فهل من طريقة لذلك وكيف يمكن الحصول على الترخيص ولك جزيل الشكر وعظيم الامتنان مرة أخرى

الأخ ابو بشاير

انقر زر أبدأ ثم تشغيل ثم اكتب العبارة التالية كاملة :

C:WindowsSystemRegsvr32.exe C:WindowsSystemmscomctl.ocx

إذا كانت الوندوز على غير C فغير رمز القرص وكذلك إذا كانت في مجلد غير Windows فغير اسم المجلد .

لمزيد من المعلومات عن التسجيل انظر الرابط :

http://arabteam.nicmatic.com/vb/showthread...3?threadid=4517

وأخبرني بالنتيجة .

ولك تحياتي

الأخ العزيز / أبو حمود حفظه الله

أشكرك مرة أخرى على تجاوبك السريع

ولكن للأسف لم تنجح تلك الطريقة فقد حاولت وحصلت على مسج بنجاح التسجيل إلا أنه بالعودة للأكسس ومحاولة استخدام عنصر ActiveX أحصل على نفس الرسالة التي تقول بأنه ليس لديك ترخيص باستخدام ذلك العنصر

ولك الشكر مرة أخرى

الأخ ابو بشاير

في حدث نقر زر الأمر ضع :

' اسم مربع النص الذي يخزن فيه مسار الصورة txtPicture
    Me![txtPicture] = GetOpenFile_CLT("C:", "اختر ملف الصورة")
    Me![txtPicture] = LCase(Me![txtPicture])
    ' السطر التالي إذا رغبت في عرض الصورة بعد إدراجها مباشرة
    Me![اسم الصورة].Picture = Me!txtPicture

مع ملاحظة السطر السابق إذا كنت في حاجة له وإلا قم بإلغاءه .

وفي الوحدة النمطية العامة ضع الأسطر التالية :

Option Compare Database
Option Explicit

' Declarations for Windows Common Dialogs procedures
Private Type CLTAPI_OPENFILE
  strFilter As String             ' Filter string
  intFilterIndex As Long          ' Initial Filter to display.
  strInitialDir As String         ' Initial directory for the dialog to open in.
  strInitialFile As String        ' Initial file name to populate the dialog with.
  strDialogTitle As String        ' Dialog title
  strDefaultExtension As String   ' Default extension to append to file if user didn't specify one.
  lngFlags As Long                ' Flags (see constant list) to be used.
  strFullPathReturned As String   ' Full path of file picked.
  strFileNameReturned As String   ' File name of file picked.
  intFileOffset As Integer        ' Offset in full path (strFullPathReturned) where the file name (strFileNameReturned) begins.
  intFileExtension As Integer     ' Offset in full path (strFullPathReturned) where the file extension begins.
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

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)

Function GetOpenFile_CLT(strInitialDir As String, strTitle As String) As String
  ' Comments  : Simple file open routine. For additional options, use GetFileOpenEX_CLT()
  ' Parameters: strInitialDir - path for the initial directory, or blank for the current directory
  '             strTitle - title for the dialog
  ' Returns   : string path, name and extension of the file selected
  '
  Dim fOK As Boolean
  Dim typWinOpen As CLTAPI_WINOPENFILENAME
  Dim typOpenFile As CLTAPI_OPENFILE
  Dim strFilter As String

  On Error GoTo PROC_ERR

  ' Set reasonable defaults for the structure
strFilter = CreateFilterString_CLT("صور (*.BMP)", "*.BMP", "صور (*.GIF)", "*.GIF", "All Files (*.*)", "*.*")

  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

  ' Convert the CLT structure to a Win structure
  ConvertCLT2Win typOpenFile, typWinOpen

  ' Call the Common dialog
  fOK = CLTAPI_GetOpenFileName(typWinOpen)

  ' Convert the Win structure back to a CLT structure
  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)
  ' Comments  : Converts the passed CLTAPI structure to a Windows structure
  ' Parameters: CLT_Struct - record of type CLTAPI_OPENFILE
  '             Win_Struct - record of type CLTAPI_WINOPENFILENAME
  ' Returns   : Nothing
  '
  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)
  ' Comments  : Converts the passed CLTAPI structure to a Windows structure
  ' Parameters: Win_Struct - record of type CLTAPI_WINOPENFILENAME
  '             CLT_Struct - record of type CLTAPI_OPENFILE
  ' Returns   : Nothing
  '
  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
  ' Comments  : Builds a Windows formatted filter string for "file type"
  ' Parameters: varFilter - parameter array in the format:
  '                          Text, Filter, Text, Filter ...
  '                         Such as:
  '                          "All Files (*.*)", "*.*", "Text Files (*.TXT)", "*.TXT"
  ' Returns   : windows formatted filter string
  '
  Dim strFilter As String
  Dim intCounter As Integer
  Dim intParamCount As Integer

  On Error GoTo PROC_ERR

  ' Get the count of paramaters passed to the function
  intParamCount = UBound(varFilt)

  If (intParamCount <> -1) Then

    ' Count through each parameter
    For intCounter = 0 To intParamCount
      strFilter = strFilter & varFilt(intCounter) & Chr$(0)
    Next

    ' Check for an even number of parameters
    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
  ' Comments  : Removes terminator from a string
  ' Parameters: strIn - string to modify
  ' Return    : modified 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

ولك تحياتي

أشكرك أخي أبو حمود فأنت حقا أكثر من رائع

لقد نجح الكود الأخير في معالجة الأمر ، أسأل الله العلى القدير أن يزيدك علما ومعرفة وينفع بك ويعطيك الصحة والعافية

من يتصدق علينا بترجمة كود الأخ أبو حمود إلى مثال جزاكم الله خيرا إنني حاولت و لكن يبدو أنني سأحتاج لوقت لفهم ذلك

الاخ العزيز / محسن محمد

اليك هذا المثال

http://mypage.ayna.com/bshr8/Shell.zip

أخي أبو البشاير يسلم إيديك وصل المثال جزاك الله خيرا و أحسن إليك

جهد عظيم من أبو حمود ...

أبو بشاير بشايرك حلوة ....

أشرف خليل

السلام عليكم

الأخ أبو بشاير

جهد تشكر عليه

وجزاك الله خيرا

masteri7@hotmail.com

الأخ ناصر :

قم بوضع الماوس على اسم الملف ثم اضغط زر الماوس الأيمن واختار حفظ الهدف باسم أو save target as وإن شاء الله يمشى الحال معاك .

أشرف خليل

الأخ أشرف

لقد عملت طريقة الحفط اولا ولم تعمل لدي

ولقد حاولت اكثر من مرة وبعد ذلك حصلت على البرنامج

بارك الله فيك

على سرعة الرد

السلام عليكم هل يتكرم علي احد الاخوه ويرسل لي المثال

shell.zip

المنشاء بواسطه الاخ ابو البشاير لاني لا استطيع انزاله

وبريدي هو

shawky_a@yahoo.com

وجزاكم الله خيرا