تفضل سيفيد هذا الملف في عملك...
عمل الملف بالتالي:
أولاً: يتم ادخال الاسم
ثانياً: الضغط على زر أضافة يتم أنشاء مجلد لأول مرة باسم image في نفس مسار ملف الاكسس وبعد أختيار الصورة يتم نسخ الصورة بالمجلد image بنفس الاسم التي تم أضافته ويتم تخزين المسار الجديد للصورة بالجدول
وهذ الكود المضاف في زر اضافة
On Error Resume Next
Dim fs, cf, strFolder
strFolder = CurrentProject.Path & "\" & "Image"
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(strFolder) = False Then
Set cf = fs.CreateFolder(strFolder)
If fs.FolderExists(strFolder) = True Then
MsgBox "'" & strFolder & "' تم انشاء المجلد في المسار التالي "
Else
MsgBox "'" & strFolder & "'لم يتم انشاء المجلد"
End If
End If
' Requires reference to Microsoft Office 14.0 Object Library.
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim destpath As Variant
' Clear listbox contents.
Me.picfile = ""
' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "رجاءً قم بتحديد مكان الصورة"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.add "png image", "*.png"
.Filters.add "jpg image", "*.jpg"
.Filters.add "jpeg image", "*.jpeg"
.Filters.add "All Files", "*.*"
If .Show = True Then
For Each varFile In .SelectedItems
destpath = Application.CurrentProject.Path & "\" & "Image" & "\" & Me.NameS & "f." & Right$(varFile, Len(varFile) - InStrRev(varFile, "."))
FileCopy varFile, destpath
Me.picfile = destpath
Me.Refresh
Next
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
Exit Sub
err:
MsgBox err.Description & " " & err.Number
=============
أن أفادك .. فدعوة لي ولوالدي
مرفق الملف:
PName.rar