kanory

تفضل ......
 
EL-DATA- T.rar

تفضل .................
 
EL-DATA.accdb

جرب المرفق التالي ............
 
LAb (1).accdb

تفضل ....................
 

مثال.accdb

هل البيانات المنقولة باللغة الانجليزية ام العربية 
وهل ممكن مرفق كمثال للتطبيق عليه

دالة DoCmd.OpenDataAccessPage تُستخدم لفتح صفحات الوصول إلى البيانات (Data Access Pages) وليس لفتح قاعدة بيانات خارجية.
لفتح قاعدة بيانات أخرى، يمكنك استخدام دالة Application.OpenCurrentDatabase أو دالة Shell
Application.OpenCurrentDatabase "E:\Auto\dbbee.accdb"  
إذا كنت تريد تشغيل قاعدة البيانات كملف منفصل باستخدام Shell
Dim path As String path = "E:\Auto\dbbee.accdb" ' مسار قاعدة البيانات Shell "MSACCESS.EXE " & path, vbNormalFocus  

اصنع زر في النموذج لديك ثم ادرج هذا الكود فيه ...............
Dim db As DAO.Database Dim rs As DAO.Recordset Dim oldPicPath As String Dim newPicPath As String Dim FirstName As String Dim keyVal As String Dim desktopPath As String Dim sourceFolder As String Dim destFolder As String Dim fileSystem As Object desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") sourceFolder = desktopPath & "\555\Pic1\" ' المجلد المصدر destFolder = desktopPath & "\555\Pictures\" ' المجلد الوجهة Set fileSystem = CreateObject("Scripting.FileSystemObject") If Not fileSystem.FolderExists(destFolder) Then fileSystem.CreateFolder destFolder End If Set db = CurrentDb Set rs = db.OpenRecordset("Table1", dbOpenDynaset) Do While Not rs.EOF If IsNull(rs!Pic2) Or rs!Pic2 = "" Then FirstName = rs!FirstName keyVal = rs!Key If Not IsNull(FirstName) And Not IsNull(keyVal) Then oldPicPath = sourceFolder & FirstName & ".jpg" newPicPath = destFolder & keyVal & ".jpg" If fileSystem.FileExists(oldPicPath) Then fileSystem.MoveFile oldPicPath, newPicPath rs.Edit rs!Pic2 = newPicPath rs.Update End If End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set fileSystem = Nothing MsgBox "تم نقل الصور وتحديث الحقل Pic2 بنجاح", vbInformation  

وعليكم السلام ورحمة الله وبركاته 
لاحظ الشرح ثم استخدم هذا ................
Private Sub NEM_SH_NotInList(NewData As String, Response As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Dim MsgBoxResult As VbMsgBoxResult MsgBoxResult = MsgBox("العنصر '" & NewData & "' غير موجود. هل ترغب في إضافته؟", vbYesNo + vbQuestion, "إضافة عنصر جديد") If MsgBoxResult = vbYes Then Set db = CurrentDb Set rs = db.OpenRecordset("SH", dbOpenDynaset) NewID = Nz(DMax("ID_SH", "SH"), 0) + 1 rs.AddNew rs!ID_SH = NewID rs!ASASE = NewData rs.Update rs.Close Set rs = Nothing Set rs1 = Nothing Set db = Nothing Response = acDataErrAdded Else Response = acDataErrContinue End If End Sub  

تفضل اضغط دبل كليك على الحقل وعلمنا .....
 
1 (11).accdb

تفضل .....
Private Sub Command_Click() Call DeleteImageFiles DoCmd.Quit End Sub Sub DeleteImageFiles() Dim fso As Object Dim folderPath As String Dim file As Object ' تحديد مسار المجلد المطلوب folderPath = CurrentProject.Path & "\Data\QR_images\" ' التأكد من وجود المجلد If Dir(folderPath, vbDirectory) = "" Then MsgBox "المجلد غير موجود: " & folderPath, vbExclamation, "خطأ" Exit Sub End If ' إنشاء كائن FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' التحقق من الملفات داخل المجلد For Each file In fso.GetFolder(folderPath).Files ' التحقق إذا كان الملف صورة (حسب الامتداد) If LCase(file.Name) Like "*.jpg" Or _ LCase(file.Name) Like "*.jpeg" Or _ LCase(file.Name) Like "*.png" Or _ LCase(file.Name) Like "*.bmp" Or _ LCase(file.Name) Like "*.gif" Then ' حذف الملف file.Delete True End If Next file MsgBox "تم حذف جميع ملفات الصور بنجاح!", vbInformation, "عملية ناجحة" ' تحرير الكائنات Set fso = Nothing End Sub  

جرب واعلمنا بالنتيجة ..............
 
mu.accdb

لا لا ...اسم الحقل receiveddate ليس فيه مشكلة بل اسم مربع النص الموجود قي النموذج .... انظر ...
 

ادخل الرمز المطلوب ثم اضغط على مفتاح انتر ....
 
111 (KAN).accdb

بداية يجب تفعيل هذه المكتبات لديك .....
 

KAN-picutre.rar

اذن تفضل ملفك .......
 
ديمو للتجربة.accdb

تفضل 
 
البيانات المكرره.mdb

جرب هذا واعلمنا بالنتيجة .............
Private Sub genu_AfterUpdate() Dim fieldValue As String fieldValue = Me.genu.Value ' Check if the field value starts with "17" If Left(fieldValue, 2) = "17" Then MsgBox "ادخال خاطئ! يجب ألا يبدأ الحقل بالرقم 17." Me.genu.Undo ' Undo the input End If End Sub  

مثال جمع الاعداد.mdb

استبدل الشيفرة في الزر بهذا ....
Dim currentText As Variant Dim newText As String newText = BuildNewText(infoa.Value, anfo2.Value, info3.Value) currentText = allinfo.Value If currentText <> "" Then allinfo.Value = currentText & ", " & newText Else allinfo.Value = newText End If infoa.Value = "" anfo2.Value = "" info3.Value = "" ثم الصق هذا الفانك في النموذج ....
Private Function BuildNewText(ParamArray TextValues() As Variant) As String Dim i As Integer Dim textPart As Variant Dim result As String For i = LBound(TextValues) To UBound(TextValues) textPart = Trim(TextValues(i)) If textPart <> "" Then If result <> "" Then result = result & ", " End If result = result & textPart End If Next i BuildNewText = result End Function  

تفضل <><><><><><><><><>
If DCount("[ID]", "[tb_tashkeel]", "[lgna_1] =" & [Forms]![tashkeel]![lgna_1] & " And [gender] =" & [Forms]![tashkeel]![gender] & " And [gender] =2 ") = 1 Then MsgBox "هناك تكرار في الجنس" Me.lgna_1 = "" ElseIf DCount("[ID]", "[tb_tashkeel]", "[lgna_1] =" & [Forms]![tashkeel]![lgna_1] & " And [religion] =" & [Forms]![tashkeel]![religion] & " ") = 1 Then MsgBox "هناك تكرار في الديانة" Me.lgna_1 = "" End If  

المرفق شغال بدون اخطاء ... جرب 
 
ظهور خطاء بعد تغير مسمى حقلين.accdb

وهذه طريفة اخرى اقل اكواد <><><><><><><>
Dim db As DAO.Database Set db = CurrentDb() db.Execute "DELETE template.UsrID, * FROM template WHERE (((template.UsrID) In (SELECT No_Common FROM QRFingerDelete)))", dbFailOnError Set db = Nothing  

طيب تفضل <<<<<<<<>>>>>>>>
 
تقرير اجازات.accdb

جرب المرفق .....................
 
New Microsoft Access Database (9).accdb

تفضل ...................
 

tah.accdb