jjafferr

وعليكم السلام أخي نور الدين بالنسبة لي ، فقد حاولت كثيرا ، وبحثت في الانترنت كثيرا ، فلم اتوصل الى شئ ، سوى ما اعطيتك من البداية ، المشكلة برمجيا لا تكمن في الصفحات الفردية والزوجية ، وانما هي بسبب ان البيانات التي عندك تتعدى الصفحة الواحدة افقيا وتصبح صفحتين ، في وجهة نظري هناك حلين لهذه المشكلة: ان تقلص عدد الحقول وعرض الحقول ، بحيث انها تكون في صفحة واحد ، ان تصدر البيانات الى اكسل ، وتستخدم امر الطباعة ، لكي يصغر حجم الحقول ، لكي تستطيع ان تطبعها في صفحة واحدة. جعفر

تفضل والكود اصبح: Option Compare Database Dim rst As DAO.Recordset Private Sub cmd_Open_desktob_Click() 'On Error Resume Next 'Dim x As FileDialog 'Set x = Application.FileDialog(msoFileDialogFilePicker) 'x.AllowMultiSelect = True 'If x.Show = -1 Then 'For i = 1 To x.SelectedItems.Count 'CurrentDb.Execute "insert into [tbl_emp_wared]([emp_id],[file_loc]) values(" & ID & ",'" & x.SelectedItems(i) & "')" 'Next i 'Me.sfrm_emp_wared.Requery 'End If Dim strFileNames As Variant 'check if the Dir exists If Dir(Me.pate, vbDirectory) = "" Then MsgBox "المسار" & vbCrLf & Me.pate & vbCrLf & _ "غير موجود في الكمبيوتر" & vbCrLf & _ "Sorry, this folder does not exist" Exit Sub End If 'call the open dialog API ' set the Filter for the Multi File Dialog, so it only shows these files 'strFilter = "Image Files " & _ "(*.JPG,*.JPEG,*.JPE,*.GIF,*.BMP,*.DIB,*.TIF,*.TIFF,*.PNG,*.PCX,*.PCD,*.ICO,*.WMF,*.EMF,*.EPS,*.fpx)" & vbNullChar & _ "*.JPG;*.JPEG;*.JPE;*.GIF;*.BMP;*.DIB;*.TIF;*.TIFF;*.PNG;*.PCX;*.PCD;*.ICO;*.WMF;*.EMF;*.EPS;*.fpx" & vbNullChar & vbNullChar strFilter = "All Files " & _ "(*.*)" & vbNullChar & _ "*.*" & vbNullChar & vbNullChar sFolder = "C:\" ' call the API for the Multi File Dialog strFileNames = apiBrowseFiles("Select a File, OR Multiple Files", sFolder, , strFilter) ' user didn't select any file, s/he proceed cancel If UBound(strFileNames) = 0 Then Exit Sub End If SelectedFiles = UBound(strFileNames) ' number of selected files ' take the 1st file name and extract the Folder name from it ' Don't Dim sFolder, it has been declared as Global variable ' so that the last folder visited will be opened again sFolder = strFileNames(1) Do While Right(sFolder, 1) <> "\" sFolder = Left(sFolder, Len(sFolder) - 1) Loop sFolder = Replace(sFolder, "\\", "\") Set rst = Me.sfrm_emp_wared.Form.RecordsetClone ' Add the selected items, and seperate them by a ; so that we use it as Row Source for ' list the files selected in the Listbox lstMultipleFiles For i = 1 To UBound(strFileNames) FileExt = Right(strFileNames(i), 3) File_Path_Name = Replace(strFileNames(i), "\\", "\") File_Name = Replace(File_Path_Name, sFolder, "") ' Copy the original file to Folder in the main Form FileCopy File_Path_Name, Me.pate & "\" & File_Name rst.AddNew rst!name_morfke = File_Name rst!tayp = FileExt rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update Next i End Sub Private Sub cmd_Open_Folder_Click() Dim strFolderName As String Dim strMsg As String If Len(Me.pate & "") <> 0 Then Dim Msg, Style, Response Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _ "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _ "Do you want to continue ?" Style = vbYesNo + vbCritical + vbDefaultButton2 Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If Else strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If 'Len 'save this Record, to save the ID, so that the subForm can use it DoCmd.RunCommand acCmdSaveRecord 'now bring the files from the folder Call Make_File_Array End Sub Function Make_File_Array() On Error GoTo err_Make_File_Array 'Folder info Dim File_Count As Integer Dim fdr As Variant Dim Files_Array() As Variant iPath_In = Me.pate iCondition = "*.*" 'No Path, exit If Len(iPath_In & "") = 0 Then Exit Function 'get the file count from the Forlder, and 'place the files in an array fdr = Dir(iPath_In & "\" & iCondition) File_Count = 0 Do While fdr <> "" File_Count = File_Count + 1 ReDim Preserve Files_Array(File_Count) Files_Array(File_Count) = fdr fdr = Dir Loop 'got the folder file count=File_Count, and the files=Files_Array(i) 'SubForm Records 'Dim rst As DAO.Recordset Set rst = Me.sfrm_emp_wared.Form.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount '1. Make all Records, File_Check=1 (No File) For j = 1 To RC rst.Edit rst!File_Check = 1 rst.Update rst.MoveNext Next j '2. Compare For i = 1 To UBound(Files_Array) 'File_Count iname_morfke = Files_Array(i) itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1) rst.FindFirst "name_morfke='" & iname_morfke & "'" If rst.NoMatch Then 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update Else 'Matching 'but is it the same extension If rst!tayp = itayp Then 'Matching rst.Edit rst!File_Check = 0 rst.Update Else 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update End If End If Next i rst.Requery Exit Function err_Make_File_Array: If Err.Number = 3021 Then 'ignor, SubForm is empty Resume Next ElseIf Err.Number = 9 Then 'ignor, SubForm is empty Exit Function Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Private Sub Form_Current() 'now bring the files from the folder Call Make_File_Array End Sub جعفر 207.2.m.salama.accdb.zip

الحقل الوحيد الذي موجود في الجدول هو حقل1 ، وهو مضمن في النموذج :)

هلا والله

السلام عليكم للعلم والاستفادة من التجارب طُلب مني التعديل على برنامج مخازن ، و عندما انتهينا من عمل تغييرات وتحديثات كبيرة ، عملنا على شئ اسمه حركة المادة (طبعا لا ينطبق على جميع أنواع المواد): - في مادة الطاولات مثلا ، عند صرف طاولة ، عملت نموذج فرعي يفرز سجلات بعدد الطاولات ، وعند الصرف / استرجاع / اعادة صرف / .... فنعطي المعلومة بمكان وجود هذه المادة / القطعة. بهذه الطريقة ، بإمكان المؤسسة معرفة مكان تواجد جميع المواد ، و معرفة جميع المواد الموجودة في أي قسم. جعفر

جرب هذا الكود Private Sub Form_Close() On Error GoTo err_Form_Close 'make a backup of BE BE_or_FE = "D:\prog" Backup_Folder = "D:\back_folder" 'Do a copy from a PC name jj ONLY ' If VBA.Environ("Computername") <> "wael" Then Exit Sub 'Delete the old saved accdb Kill Backup_Folder & "\AA_BE_*.accdb" 'Now lets work on saving the new accdb''Is this PC name = jj' ' BE_Address = BE_or_FE & "\AA_BE.accdb" BK_Address = Backup_Folder & "\AA_BE_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & ".accdb*" 'Debug.Print "xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34) Call Shell("xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34), vbHide) Exit Sub err_Form_Close: If Err.Number = 2450 Or Err.Number = 53 Then 'ignor Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub انا انتظر جوابك بسرعة لوسمحت ، حتى نحصل على نتيجة قبل ان انام ان شاء الله جعفر عفوا شئ آخر مهم: الكود يشتغل اذا اغلقت النموذج ، ولا يشتغل اذا اغلقت البرنامج. جعفر

حياك الله أخوي عبدالرحمن

تسمحون لي في ادلاء دلوي جرب النموذج frm2 ، انا استعرت كود اخونا عبدالرحمن ، وعدلت عليه ، فاصبح: Private Sub txt_KeyUp(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case Is = vbKeySpace Exit Sub Case Else Call counting End Select End Sub Function counting() a = Me.txt.Text Me.txt_len = Len(a) Me.txt_letters = Len(Replace(a, " ", "")) Me.txt_words = Len(a) - Len(Replace(a, " ", "")) + 1 End Function . وممكن تجرب frm1 كذلك جعفر 209.عدد الحروف والكلمات مهم--edit.accdb.zip

ولا يهمك :-) لوسمحت تكتب لي مسار BE جعفر

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

عين العقل أختي جعفر

وعليكم السلام أخي وائل انت كتبت اسم BE بالخطأ ، وعدلت انا الشئ البسيط على البرنامج كذلك ، فاليك الكود المعدل: Private Sub Form_Close() On Error GoTo err_Form_Close 'make a backup of BE BE_or_FE = "C:\My Documents\Downloads\Officena.net\208.A" Backup_Folder = "C:\back_folder" 'Do a copy from a PC name jj ONLY If VBA.Environ("Computername") <> "wael" Then Exit Sub 'Delete the old saved accdb Kill Backup_Folder & "\AA_BE_*.accdb" 'Now lets work on saving the new accdb''Is this PC name = jj' ' BE_Address = BE_or_FE & "\AA_BE.accdb" BK_Address = Backup_Folder & "\AA_BE_" & Format(Now(), "yyyy-mm-dd_-hh-mm-ss") & ".accdb*" 'Debug.Print "xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34) Call Shell("xcopy " & Chr(34) & BE_Address & Chr(34) & " " & Chr(34) & BK_Address & Chr(34), vbHide) Exit Sub err_Form_Close: If Err.Number = 2450 Or Err.Number = 53 Then 'ignor Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub رجاء عدم تغيير الكود ، الإ السطرين التاليين فقط ، وهما لتحديد مسار BE ، وتحديد مسار back_folder جعفر 208.AA.mdb.zip

حيا الله أخوي رمهان مقارنة ملفات المجلد ، باسماء الملفات في السجلات ، هو الذي اخذ الكثير من الوقت ، ليس المقارنة نفسها ، وانما ماذا افعل اذا كان هناك ملف بدون سجل ، او سجل بدون ملف بالاضافة الى كيفية جعل البرنامج يشتغل بأقل تدخل من المستخدم وهنا (وبعد الغداء ) ساشرح البرنامج بطريقة مفصلة اكثر: عندما تختار المجلد ، فتلقائيا البرنامج سيأخذ اسم المجلد ومساره ، واسم الملفات الموجودة فيه ، ويضعها في النموذج الفرعي ، اذا كان هناك اسم في حقل مسار المجلد ، وضغطت على زر اختيار المجلد ، فسيطلب منك البرنامج تأكيد هذه العملية ، الكود يعمل على الحدث الحالي للنموذج الرئيسي ، فلا يحتاج الى تدخل من المستخدم ، في كل مرة تذهب الى سجل ، يعمل الكود على مقارنة معلومات المجلد بالمعلومات الموجودة في سجلات هذا الوارد ، السجل باللون الابيض معناه ان السجل والملف هما بنفس الاسم ، السجل باللون الازرق معناه ان هناك ملفات ولا توجد سجلات لهم ، لهذا السبب ، فالبرنامج استورد الاسماء ووضعها في السجل ، ولا تهتم باللون ، لأنك عندما تذهب الى سجل آخر ، ثم ترجع الى هذا السجل ، سترى ان الاسماء اصبحت بيضاء السجل باللون الاخر معناه انه لا يوجد ملف بهذا الاسم في المجلد ، وعليه تستطيع ان تحذفه ان شئت ، وعندما تضغط على طرف السجل وتضغط على زر الحذف ، فسيطلب منك البرنامج تأكيد الحذف ، البرنامج لا يحذف اي سجل تلقائيا. جعفر

وعليكم السلام أخي محمد أخي رمهان ، رحم الله والديك على السؤال عني السؤال ظاهرا سهل ، ولكنه ليس كذلك اللي عملته هو: 1. تغيير اسم النموذج الى frm_wared ، والنموذج الفرعي الى sfrm_emp_wared ، 2. في النموذج الرئيسي ، اضغط على زر المجلد ، وتستطيع اختيار المجلد الذي به الملفات: . 3. اضفت حقل جديد في الجدول للنموذج الفرعي ، اسمه File_Check ، ونستفيد منه في تلوين وتعريف السجل ، وعملناه مخفي: . 4. عملنا تنسيق شرطي لأحد الحقول (تستطيع ان تعمله لبقة الحقول ان احببت): . وهذان هما الشرطان فيه: . والالوان معناها: اللون الابيض: هناك ملف في المجلد بنفس الاسم ، اللون الاخضر: هذا السجل لا يوجد ملف بنفس اسمه ، اللون الازرق: هذا الملف موجود في المجلد وغير موجود في السجلات، . 5. وهذه نتيجة احد السجلات: . 6. وعندما تريد حذف السجل: . العمل على البرنامج اسهل من شرحه وهذا هو الكود كاملا: Option Compare Database Private Sub cmd_Open_Folder_Click() Dim strFolderName As String Dim strMsg As String If Len(Me.pate & "") <> 0 Then Dim Msg, Style, Response Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _ "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _ "Do you want to continue ?" Style = vbYesNo + vbCritical + vbDefaultButton2 Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If Else strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If 'Len 'now bring the files from the folder Call Make_File_Array End Sub Function Make_File_Array() On Error GoTo err_Make_File_Array 'Folder info Dim File_Count As Integer Dim fdr As Variant Dim Files_Array() As Variant iPath_In = Me.pate iCondition = "*.*" 'No Path, exit If Len(iPath_In & "") = 0 Then Exit Function 'get the file count from the Forlder, and 'place the files in an array fdr = Dir(iPath_In & "\" & iCondition) File_Count = 0 Do While fdr <> "" File_Count = File_Count + 1 ReDim Preserve Files_Array(File_Count) Files_Array(File_Count) = fdr fdr = Dir Loop 'got the folder file count=File_Count, and the files=Files_Array(i) 'SubForm Records Dim rst As DAO.Recordset Set rst = Me.sfrm_emp_wared.Form.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount '1. Make all Records, File_Check=1 (No File) For j = 1 To RC rst.Edit rst!File_Check = 1 rst.Update rst.MoveNext Next j '2. Compare For i = 1 To UBound(Files_Array) 'File_Count iname_morfke = Files_Array(i) itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1) rst.FindFirst "name_morfke='" & iname_morfke & "'" If rst.NoMatch Then 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update Else 'Matching 'but is it the same extension If rst!tayp = itayp Then 'Matching rst.Edit rst!File_Check = 0 rst.Update Else 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update End If End If Next i rst.Requery Exit Function err_Make_File_Array: If Err.Number = 3021 Then 'ignor, SubForm is empty Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Private Sub Form_Current() 'now bring the files from the folder Call Make_File_Array End Sub جعفر 207.1.m.salama.accdb.zip

وعليكم السلام أختي الخطأ هذا ليس بسبب ان نظام الكمبيوتر x64 ، وانما بسبب نظام الاوفيس 64bits. واذا اردتي ان تأخذي نصيحة مايكروسوفت ، فالنصيحة تقول بأن تنصبي اوفيس 32bits على جهازك ، بغض النظر اذا كان نظام الوندوز x64 اوx86 . ولأني لا املك نسخة الاوفيس 64bits ، فبعد البحث في الانترنت ، وجدت هذا الكود: #If VBA7 Then Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _ ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias _ "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, _ ByVal dwThreadId As Long) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long #Else Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias _ "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _ ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _ (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long #End If '~~> Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 #If VBA7 Then Private hHook As LongPtr #Else Private hHook As Long #End If رجاء تجربته ، وافادتنا جعفر

وعليكم السلام أخوي الكريمين محمد ورمهان :-) فهمي للموضوع هو: - لديك مجلدات لكل كتاب أو وارد ، والكتاب الصادر أو الوارد قد يحتوي على مجموعة ملفات. س: ما إسم هذه المجلدات؟ أين توجد في الكمبيوتر؟ هل إسم المجلد له علاقة باي من حقول السجل؟ - تريد ان تفرز اسم وصيغة كل ملف موجود في المجلد الخاص للكتاب ، وهذه المعلومة تريدها في النموذج الفرعي. س: مثل ما قال الاخ رمهان ، مافي داعي لحفظ هذه الأسماء في الجدول. وفي احد مشاريعي ، طبقت طريقة قراءة محتوي المجلد في Listbox ، و عندما تريد فتح الملف ، تنقر مرتين على إسم الملف ، فيفتحه مباشرة من المجلد. هل ممكن استعمال هذه الطريقة ، أو أنك تريد الأسماء في الجدول لأنك تريد إضافة ملاحظات لكل ملف؟ س: شرحت لك أعلاه طريقة فتح الملف ، سواء بطريقتي أو بطريقتك في النموذج الفرعي. فلماذا تريد أن تحفظ الملف داخل قاعدة البيانات؟ حفظ الملفات داخل قاعدة البيانات غلط ، إلا في حدود جدا ضيقة ، وإلا فسيكبر حجم قاعدة بياناتك بطريقة مهولة ، وقد تصل إلى مرحلة العطب أو عدم إمكانية إضافة سجلات بها ، انا رأيت مثل هذه البرنامج :-( جعفر

وعليكم السلام أخي محمد :-) يا ريت توضح أكثر!! جعفر شو قصدك إحضارة لقاعدة البيانات؟ هل قصدك حفظه في قاعدة البيانات؟ و اذا جوابك كان نعم ، فالسؤال لماذا؟ جعفر

شكرا جزيلا على هذه المعلومة أخي الأستاذ محمد :-) جعفر

أخي عبدالله مشاكل Active x لها علاقة: بنسخة وتحديثات الويندوز ، نسخة وتحديث عنصر الـ Active x ، ولا علاقة لها بلغة الويندوز ، ولا لغة الاكسس. و عندما تريد أن تعمل برنامج لاستعماله على أي كمبيوتر ، فاستخدم نسخة الاكسس الانجليزية ، ولا تستخدم أي حروف unicode في عناصر الاكسس ولا في الكود. جعفر

أما انا ، فكنت اشتغل على مشروع قراءة ملف البصمة ، والمرتبط بحوالي 42 جهاز ، وكانت صيغة الجهاز هو dbf ، ولما لم يستطع الاكسس التفاهم معاه واخذ البيانات منه ، اشتريت dbf viewer من الرابط http://dbfviewer2000.com وعن طريق كود الاكسس ، وباستخدام هذا البرنامج ، يتم تحويل ملف dbf إلى csv وبالتالي اربطه بجداول الاكسس :-) والبرامج به طريقة تحويل عدة ملفات دفعة واحدة على ما اعتقد :-) جعفر

للاسف ، اكسس 2013 لا يتعامل مع dbf

تسلم أخوي محمد نتيجة عمل برامج مختلفة ، لفئات مختلفة ، على فترات مختلفة ، بلغات مختلفة ، لسنوات عدة ، يسمونها خبرة ولولا اسئلة الشباب ، لما طلعت هذه الخبرة للملأ فالشكر موصول لكم ، لأسئلتكم ومداخلاتكم جعفر

السلام عليكم وهذه النسخة الكاملة للموضوع (البارحة بعد ان كتبت كل شئ ، اتضح ان المنتدى اُغلق للصيانة ، وراح كل الشغل ) 2. عندما تستخدم البرنامج في شبكة بين مجموعة مستخدمين ، لا تريد البرنامج ان يعمل نسخة كلما خرج احد المستخدمين من البرنامج ، ولكن تريد ان يتم عمل النسخة عندما يخرج المستخدم الذي يعمل على الكمبيوتر jj فقط (طبعا يمكن استخدام اسم المستخدم بدلا من اسم الكمبيوتر): if vba.Environ ("Computername")<> "jj" then Exit Sub 3. السطر التالي يحذف جميع الملفات القديمة لهذا الملف: Kill Backup_Folder & "\Program\Haj_BE_*.accdb" Private Sub Form_Close() On Error GoTo err_Form_Close 'make a backup of BE BE_or_FE = "C:" Backup_Folder = "D:" 'Do a copy from a PC name jj ONLY if vba.Environ ("Computername")<> "jj" then Exit Sub 'Delete the old saved accdb Kill Backup_Folder & "\Program\Haj_BE_*.accdb" 'Now lets work on saving the new accdb''Is this PC name = jj' ' BE_Address = BE_or_FE & "\Haj_BE.accdb" BK_Address = Backup_Folder & "\Program\Haj_BE_" & Format(Now(), "yyyy-mm-dd_-hh-mm-ss") & ".accdb*" Call Shell("xcopy " & BE_Address & " " & BK_Address, vbHide) Exit Sub err_Form_Close: If Err.Number = 2450 or err.number=53 Then 'ignor Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub جعفر

وعليكم السلام أخي وائل اخذت لك هذا الكود من احد برامجي Private Sub Form_Close() On Error GoTo err_Form_Close 'make a backup of BE BE_or_FE = "C:" Backup_Folder = "D:" BE_Address = BE_or_FE & "\Haj_BE.accdb" BK_Address = Backup_Folder & "\Program\Haj_BE_" & Format(Now(), "yyyy-mm-dd_-hh-mm-ss") & ".accdb*" Call Shell("xcopy " & BE_Address & " " & BK_Address, vbHide) Exit Sub err_Form_Close: If Err.Number = 2450 Then 'ignor Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub وهذا الكود لنسخ الملف وليس لحذف القديم ، وفي هذا الرابط ستجد طريقة مشابهة لما تريد (اعذرني ، فوقتي لا يسمح لي بعمل المطلوب الان :( ) http://www.officena.net/ib/topic/61847-تعديل-على-كود-حفظ-مكان-الصورة/?do=findComment&comment=399928 جعفر

وعليكم السلام لا يوجد مشكلة الصيغة الجديدة للأكسس هي accdb ، وهي منذ الاصدار 2007 وفي اعتقادي اذا صار للأكسس صيغة جديدة ، فستحمل تاريخ الاصدار الجديد جعفر