اكواد للتعامل مع الملفات و المجلدات

[عصام ربيع]

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

هل يمكن عند تشغيل قاعدة بيانات الآكسيس المطالبة دائماً بوجود السى دى الخاص بالقاعدة؟

[zakwan]

الاخ عصام

ماالمقصود بقاعدة بيانات الاكسيس هل هي القاعدة التي قمت انت بأنشائها ام المقصود برنامج الاكسيس نفسة ؟؟؟؟؟

الرجاء التوضيح

[محمد طاهر عرفه]

هذه المجموعة من الاكواد من تجميع ابو حمود

--------------------------------------------------

— للبحث عن ملف :

Set fs = Application.FileSearch
With fs
.LookIn = "C:\My Documents"
.FileName = "DO.*"
If .Execute > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For I = 1 To .FoundFiles.Count
MsgBox .FoundFiles(I)
Next I
Else
MsgBox "There were no files found."
End If
End With
ولإعادة البحث :
With Application.FileSearch
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
Else
MsgBox "There were no files found."
End If
End With
ولإعادة البحث مع تحديد معيار أكثر تفصيلاً :
With Application.FileSearch
.NewSearch
.LookIn = "C:\My Documents"
.SearchSubFolders = True
.FileName = "Run"
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
End With
انظر التفصيلات في هذا المثال :
With Application.FileSearch
.NewSearch
.LookIn = "C:\My Documents"
.SearchSubFolders = True
.FileName = "run"
.TextOrProperty = "San*"
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For I = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next I
Else
MsgBox "There were no files found."
End If
End With

— لنسخ ملف إلى دليل آخر باستخدام الطريقة CopyFile

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile "C:\My Documents\شهادة.Gif", 
"c:\My Documents\My Pictures\", True
True للكتابة فوق نسخة موجودة وFalse للنسخ بدون كتابة ، ويعطي رسالة خطأ إذا وجد نسخة .

— لنسخ ملف باستخدام FileCopy

Dim SourceFile, DestinationFile
SourceFile = "اسم الملف مع القرص والدليل" 
DestinationFile = "اسم المحرك والمجلد" 
FileCopy SourceFile, DestinationFile

— نسخ محتويات مجلد Folder إلى مجلد آخر باستخدام الطريقة CopyFolder

Dim fs 
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFolder "C:\My Documents\مجلد جديد"
"c:\My Documents\برامج", True

— لإنشاء مجلد جديد باستخدام الطريقة CreateFolder

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateFolder "C:\My Documents\مجلد جديد"

● لإنشاء مجلد folder استخدم :

MkDir "اسم المجلد الجديد"

لاحظ إذا لم يكتب اسم محرك الأقراص قبل المجلد فسوف ينشأ المجلد على محرك الأقراص الحالي . — لحذف ملف باستخدام الطريقة DeleteFile

Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile "C:\My Documents\نسخ من شهادة.gif", True
True لحذف ملف للقراء فقط وFalse لعدم حذفه .

— لحذف مجلد باستخدام الطريقة DeleteFolder

Dim fs 
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFolder "C:\My Documents\مجلد جديد", True

True لحذف مجلد للقراء فقط وFalse لعدم حذفه ، لاحظ أنه يحذف المجلد وكل الملفات التي بداخله . — لحذف مجلد :

Rmdir "اسم المجلد"

لابد أن يكون هذا المجلد خالي من الملفات ليتم حذفه وإلا استخدم Kill لحذف الملفات أولا : Kill ("اسم القرص والدليل والملف مع اللاحقة") ولحدف كافة محتويات المجلد استخدم بعد القرص ثم المجلد : *.* ولحذف نوع ملفات استخدم النجمة واللاحقة مثال : *.TXT — لمعرفة أقراص المحركات الموجودة باستخدام الطريقة DriveExists

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DriveExists("c")

يعيد السطر الأخير True إذا وجد المحرك وFalse إذا لم يجده ، لاحظ أن المحركات القابلة للإزالة يعيد السطر الأخير لها True ولو لم تكن موجودة . — لمعرفة الملفات الموجودة باستخدام الطريقة FileExists

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
MsgBox fs.FileExists("c:\my documents\شهادة.gif")

يعيد السطر الأخير True إذا وجد الملف وFalse إذا لم يجده ، لاحظ أنه يجي عليك كتابة المجلد واسم الملف واللاحقة . — لمعرفة المجلدات الموجودة باستخدام الطريقة FolderExists

Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
MsgBox fs.FolderExists ("c:\my documents")

يعيد السطر الأخير True إذا وجد المجلد وFalse إذا لم يجده ، لاحظ أنه يجي عليك كتابة المحرك واسم المجلد . لمعرفة محركات الأقراص الموجودة في الحاسب :

Sub ShowDriveList
Dim fs, d, dc, s, n
Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
For Each d in dc
s = s & d.DriveLetter & " - " 
If d.DriveType = 3 Then
n = d.ShareName
Else
n = d.VolumeName ' هذا السطر يظهر اسم محرك الأقراص قد يسبب مشاكل ويفضل تعطيله
End If
s = s & n & vbCrLf
Next
MsgBox s
End Sub

● لإظهار المحركات في قائمة منسدلة ؛ ضع في حدث عند التركيز :

Dim fs, d, dc
Dim الكل As Variant
Dim محركات_الأقراص As String

Set fs = CreateObject("Scripting.FileSystemObject")
Set dc = fs.Drives
For Each d In dc
محركات_الأقراص = d
If IsEmpty(الكل) Then
الكل = محركات_الأقراص & "\"
Else
الكل = الكل & ";" & محركات_الأقراص & "\"
End If
Next
Me![اسم القائمة المنسدلة].RowSource = الكل
ملاحظة هامة جداً : يجب جعل نوع مصدر الصف للقائمة هي قائمة القيم .

— لإظهار الملفات في دليل

Sub ShowFileList(folderspec)
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set fc = f.Files
For Each f1 in fc
s = s & f1.name 
s = s & vbCrLf
Next
MsgBox s
End Sub
ويستدعى من إجراء مع وسيطة اسم المجلد أو القرص ، مثال :
Call ShowFileList("C:\My Documents")

- لمعرفة حجم ونوع ملف

Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile("c:\My Documents\db1.mdb")
s = " اسم الملف هو :" & UCase(f.Name) & " وحجمه : " & "(" & (f.Size) & ")" & " ونوعه : " & f.Type
MsgBox s, vbMsgBoxRight + vbMsgBoxRtlReading, "معلومات ملف"

- لإظهار قائمة بأسماء ملفات الخطوط وليس أسماء الخطوط

Dim fs, f, f1, fc, s
Dim الملفات As String
Dim الكل As Variant
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("C:\WINDOWS\FONTS")
Set fc = f.Files
For Each f1 In fc
If f1.Type = "ملف خط تروتايب" Then
الملفات = f1.Name
If IsEmpty(الكل) Then
الكل = الملفات
Else
الكل = الكل & ";" & الملفات
End If
End If
Next
List1.RowSource = UCase(الكل)

- لمعرفة حجم ونوع مجلد

Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder("c:\My Documents")
s = " اسم المجلد هو :" & UCase(f.Name) & " وحجمه : " & "(" & (f.Size) & ")" & " ونوعه : " & f.Type
MsgBox s, vbMsgBoxRight + vbMsgBoxRtlReading, "معلومات مجلد"

- لإعادة اسم ملف من دليل :

Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
MsgBox fs.GetFileName("c:\My Documents\db1.mdb")
يعيد السطر الأخير اسم الملف الموجود بعد اسم المجلد .
ولإعادة المجلد كاملاً استخدم :
MsgBox fs.GetFile("c:\My Documents\db1.mdb")

- لإعادة المجلد بعد المحرك من دليل :

Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
MsgBox fs.GetParentFolderName("c:\KPCMS\My Documents")

- لنقل ملف استخدم الطريقة MoveFile

Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFile "c:\My Documents\سوند فورج.htm", "c:\My Documents\My Htmal\"

- نقل مجلد باستخدام MoveFolder

Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFolder "c:\المجلد المطلوب نقله", "c:\المجلد الذي سينقل إليه المجد السابق\"

- لإظهار قائمة بالمجلدات قم باستدعاء التالي:

Sub ShowFolderList(folderspec)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
s = s & f1.Name
s = s & vbCrLf
Next
MsgBox s
End Sub
ولجعلها تظهر في قائمة منسدلة :
Dim fs, f, f1, s, sf 
Dim الكل As Variant
Dim كل_المجلدات As String

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder([قرص])
Set sf = f.SubFolders
For Each f1 In sf
كل_المجلدات = f1.Name
If IsEmpty(الكل) Then
الكل = كل_المجلدات
Else
الكل = الكل & ";" & كل_المجلدات
End If
Next
Me![اسم القائمة المنسدلة].RowSource = الكل
مع وضع وسيطه إما محرك أقراص أو مجلد ، مثال :
Call ShowFolderList("c:\")

— لإظهار كافة المجلدات في قرص أو دليل وطباعتها في الدبج :

MyPath = "c:\" 
MyName = Dir(MyPath, vbDirectory) 
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
Debug.Print MyName 
End If 
End If
MyName = Dir 
Loop

ولإظهارها في قائمة منسدلة :

Dim الكل As Variant
Dim كل_المجلدات As String
MyPath = قرص
كل_المجلدات = Dir([MyPath], vbDirectory)
Do While كل_المجلدات <> ""
If كل_المجلدات <> "." And كل_المجلدات <> ".." Then
If (GetAttr(MyPath & كل_المجلدات) And vbDirectory) = vbDirectory Then
If IsEmpty(الكل) Then
الكل = كل_المجلدات
Else
الكل = الكل & ";" & كل_المجلدات
End If
End If
End If
كل_المجلدات = Dir
Loop
Me![اسم القائمة المنسدلة].RowSource = الكل
— لإظهار أول ملف بخاصية معينة
Dim MyFile 
MyFile = Dir("*.TXT", vbHidden)

- لإظهار معلومات عن ملف استدعي الإجراء التالي :

Sub ShowFileAccessInfo(filespec)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(filespec)
s = UCase(filespec) & vbCrLf
s = s & "تاريخ الإنشاء: " & f.DateCreated & vbCrLf
s = s & "التشغيل الأخير: " & f.DateLastAccessed & vbCrLf
s = s & "التعديل الأخير: " & f.DateLastModified
MsgBox s, 0, "معلومات ملف"
End Sub
مع وضع وسيطه إما محرك أقراص أو مجلد ، مثال :
Call ShowFileAccessInfo("c:\My Documents\do.mdb")

— لتغيير اسم ملف أو مجلد للملف :

Dim OldName, NewName
OldName = "C:\MY Documents\1.bmp": NewName = "C:\MY Documents\خلفية.bmp"
Name OldName As NewName

للمجلد

Dim OldName, NewName
OldName = "C:\MY Documents\مجلد جديد": NewName = "C:\MY Documents\احذفه لو سمحت"
Name OldName As NewName

- لمعرفة نوع المجلد هل هو جذر مجلدات root folder أو مجلد داخل جذر أو مجلد آخر ومستواه

Sub DisplayLevelDepth(pathspec)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Dim f, n
Set f = fs.GetFolder(pathspec)
If f.IsRootFolder Then
MsgBox "The specified folder is the root folder."
Else
Do Until f.IsRootFolder
Set f = f.ParentFolder
n = n + 1
Loop
MsgBox "The specified folder is nested " & n & " levels deep."
End If
End Sub
ويحتاج إلى تمرير وسيطة اسم المجلد أو القرص .

— لمعرفة حجم القرص الصلب والمتاح منه

Sub ShowSpaceInfo(drvpath)
Dim fs, d, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath)))
s = "Drive " & d.DriveLetter & ":"
s = s & vbCrLf
s = s & "السعة: " & FormatNumber(d.TotalSize / 1024, 0) & " Kbytes"
s = s & vbCrLf
s = s & "المساحة الحرة: " & FormatNumber(d.AvailableSpace / 1024, 0) & " Kbytes"
s = s & vbCrLf
s = s & "المساحة المستخدمة: " & FormatNumber((d.TotalSize - d.AvailableSpace) / 1024, 0) & " Kbytes"
MsgBox s
End Sub
يمكنك استبدال سطر المساحة الحرة بالسطر التالي وهو يؤدي إلى نفس النتيجة :
s = s & "المساحة الحرة: " & FormatNumber(d.FreeSpace / 1024, 0)

رسالة بمسار سطح المكتب

Option Compare Database

Private Enum SpecialFolderIDs
sfidDESKTOP = &H0 ' سطح المكتب
sfidPROGRAMS = &H2 ' البرامج
sfidPERSONAL = &H5 ' شخصي
sfidFAVORITES = &H6 ' المفضلة
sfidSTARTUP = &H7 ' بدء التشغيل
sfidRECENT = &H8 ' قائمة الملفات المفتوحة حديثا
sfidSENDTO = &H9 ' إرسال إلى
sfidSTARTMENU = &HB ' قائمة بدء التشغيل
sfidDESKTOPDIRECTORY = &H10 ' مجلد سطع المكتب
sfidNETHOOD = &H13
sfidFONTS = &H14 ' الخطوط
sfidTEMPLATES = &H15 ' مؤقت
sfidCOMMON_STARTMENU = &H16
sfidCOMMON_PROGRAMS = &H17
sfidCOMMON_STARTUP = &H18
sfidCOMMON_DESKTOPDIRECTORY = &H19
sfidAPPDATA = &H1A
sfidPRINTHOOD = &H1B
sfidProgramFiles = &H10000
sfidCommonFiles = &H10001
End Enum

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long

Private Const NOERROR = 0

ثم في حدث زر الأمر أو غيره ضع التالي :
Dim sPath As String
Dim IDL As Long
Dim strPath As String
Dim lngPos As Long

' Fill the item id list with the pointer of each folder item, rtns 0 on success
If SHGetSpecialFolderLocation(0, sfidDESKTOP, IDL) = NOERROR Then
sPath = String$(255, 0)
SHGetPathFromIDListA IDL, sPath

lngPos = InStr(sPath, Chr(0))
If lngPos > 0 Then
strPath = Left$(sPath, lngPos - 1)
MsgBox strPath
End If

End If

[محمد طاهر عرفه]

استكمالا للموضوع هذه بعض الاكواد الاخري

لمعرفة المحركات الموجودة و انواعها

Task: Get Drive Type using GetDriveType API

Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_DOES_NOT_EXIST = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6

--------

Private Sub Form_Load()
Select Case GetDriveType("C:\")
Case DRIVE_UNKNOWN
MsgBox "Unknown drive type", vbExclamation
Case DRIVE_DOES_NOT_EXIST
MsgBox "Drive doesn't exist", vbCritical
Case DRIVE_REMOVABLE
MsgBox "The disk can be removed from the drive", vbInformation
Case DRIVE_FIXED
MsgBox "The disk cannot be removed from the drive", vbInformation
Case DRIVE_REMOTE
MsgBox "The drive is a remote (network) drive", vbInformation
Case DRIVE_CDROM
MsgBox "The drive is a CD-ROM drive", vbInformation
Case DRIVE_RAMDISK
MsgBox "The drive is a RAM disk", vbInformation
End Select
End
End Sub
'Visit my Homepage at
'http://www.geocities.com/marskarthik
'http://marskarthik.virtualave.net
'Email: marskarthik@angelfire.com

و أيضا

'************ Code Start **************
'This code was originally written by Terry Kreft
'and Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Original Code by Terry Kreft
' Modified by Dev Ashish
'
'Drive Types
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_ABSENT = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
' returns errors for UNC Path
Private Const ERROR_BAD_DEVICE = 1200&
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NOT_SUPPORTED = 50&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const NO_ERROR = 0

Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _
        "WNetGetConnectionA" (ByVal lpszLocalName As String, _
        ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
    "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long

Private Function fGetDrives() As String
'Returns all mapped drives
    Dim lngRet As Long
    Dim strDrives As String * 255
    Dim lngTmp As Long
    lngTmp = Len(strDrives)
    lngRet = GetLogicalDriveStrings(lngTmp, strDrives)
    fGetDrives = Left(strDrives, lngRet)
End Function

Private Function fGetUNCPath(strDriveLetter As String) As String
    On Local Error GoTo fGetUNCPath_Err

    Dim Msg As String, lngReturn As Long
    Dim lpszLocalName As String
    Dim lpszRemoteName As String
    Dim cbRemoteName As Long
    lpszLocalName = strDriveLetter
    lpszRemoteName = String$(255, Chr$(32))
    cbRemoteName = Len(lpszRemoteName)
    lngReturn = WNetGetConnection(lpszLocalName, lpszRemoteName, _
                                       cbRemoteName)
    Select Case lngReturn
        Case ERROR_BAD_DEVICE
            Msg = "Error: Bad Device"
        Case ERROR_CONNECTION_UNAVAIL
            Msg = "Error: Connection Un-Available"
        Case ERROR_EXTENDED_ERROR
            Msg = "Error: Extended Error"
        Case ERROR_MORE_DATA
               Msg = "Error: More Data"
        Case ERROR_NOT_SUPPORTED
               Msg = "Error: Feature not Supported"
        Case ERROR_NO_NET_OR_BAD_PATH
               Msg = "Error: No Network Available or Bad Path"

        Case ERROR_NO_NETWORK
               Msg = "Error: No Network Available"
        Case ERROR_NOT_CONNECTED
               Msg = "Error: Not Connected"
        Case NO_ERROR
               ' all is successful...
    End Select
    If Len(Msg) Then
        MsgBox Msg, vbInformation
    Else
        fGetUNCPath = Left$(lpszRemoteName, cbRemoteName)
    End If
fGetUNCPath_End:
    Exit Function
fGetUNCPath_Err:
    MsgBox Err.Description, vbInformation
    Resume fGetUNCPath_End
End Function

Private Function fDriveType(strDriveName As String) As String
    Dim lngRet As Long
    Dim strDrive As String
    lngRet = GetDriveType(strDriveName)
    Select Case lngRet
        Case DRIVE_UNKNOWN 'The drive type cannot be determined.
            strDrive = "Unknown Drive Type"
        Case DRIVE_ABSENT 'The root directory does not exist.
            strDrive = "Drive does not exist"
        Case DRIVE_REMOVABLE 'The drive can be removed from the drive.
            strDrive = "Removable Media"
        Case DRIVE_FIXED 'The disk cannot be removed from the drive.
            strDrive = "Fixed Drive"
        Case DRIVE_REMOTE  'The drive is a remote (network) drive.
            strDrive = "Network Drive"
        Case DRIVE_CDROM 'The drive is a CD-ROM drive.
            strDrive = "CD Rom"
        Case DRIVE_RAMDISK 'The drive is a RAM disk.
            strDrive = "Ram Disk"
    End Select
    fDriveType = strDrive
End Function

Sub sListAllDrives()
    Dim strAllDrives As String
    Dim strTmp As String
    
    strAllDrives = fGetDrives
    If strAllDrives <> "" Then
        Do
            strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1)
            strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1)
            Select Case fDriveType(strTmp)
                Case "Removable Media":
                    Debug.Print "Removable drive :  " & strTmp
                Case "CD ROM":
                    Debug.Print "   CD Rom drive :  " & strTmp
                Case "Fixed Drive":
                    Debug.Print "    Local drive :  " & strTmp
                Case "Network Drive":
                    Debug.Print "  Network drive :  " & strTmp
                    Debug.Print "       UNC Path :  " & _
                                fGetUNCPath(Left$(strTmp, Len(strTmp) - 1))
            End Select
        Loop While strAllDrives <> ""
    End If
End Sub
'**************** Code End ******************

و مصدره http://www.mvps.org/access/api/api0003.htm للتعرف علي المجلد الذي به القاعدة

Function GetPath(Name As String) As String
Dim i As Integer, pathtemp As String
i = 1
Do While i < Len(Name)
   pathtemp = ""
   Do While Mid(Name, i, 1) <> "\" And i <= Len(Name)
       pathtemp = pathtemp & Mid(Name, i, 1)
       i = i + 1
   Loop
   If Mid(Name, i, 1) = "\" Then
       GetPath = GetPath & pathtemp & "\"
       i = i + 1
   End If
Loop
End Function

و لاستدعاؤه فى رسالة مثلا من الكود الخاص بالنقر علي زر :

 
Private Sub Command3_Click()
MsgBox GetPath(CurrentDb.Name)
End Sub

[zakwan]

اخي عصام

معليش خدني بحنانك

اذا كنت تقصد بأن قاعدة البيانات المنشئة لاتفتح الابوجود سيدي الموجود بة القاعدة الاساسية فلأعتقد يتم ذلك اذا كانت القاعدة مرتبطة اي الفورم والتارير توضع على القرص الصلب والجداول على السيدي .

اتمنى ان يكون هذا ماتريدة.

[امير عاطف]

معليش خدني بحنانك

:lol:

[محمد طاهر عرفه]

من الممكن وضع ملف باي اسم علي محرك الاقراص

و البحث عن الملف علي السي دي قبل فتح البرنامج ، و اغلاق البرنامج اذا لم يوجد

و قد يمكن حساب بيان ما عن القرض مثل اسمه ، و سعته و المساحة الخالية

و لكن فى النهاية كل هذا سيمكن التغلب عليه بعمل نسخة للاسطوانة نفسها

و لحماية الاسطوانة من النسخ توجد تقنيات لذلك مثل ال Laser Lock

و لكنها تتم فى تصنيع الاسطوانة نفسها

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