Elsayed Bn Gemy

بحب انا موضوع الصور دا ههههههههههههه بص هو Dlookup مع حالتك دى مش هتنفع متحاولش بس احنا ممكن نتحايل عليها هنعمل نموذج فرعى صغنتوت خالص على قد الصورة ونربطه بالكمبوبكس وتحط فيه الحقل المرفق وحقل id وفى خصائص النموذج تبويب بيانات هتلاقى اوبشن اسمه ربط الحقول الرئيسية زاوبشن تانى اسمه ربط الحقول التابع حط فى الاتنين Id واحتياطى فى حدث بعد التحديث للكموبوبوكس حط الكود دا me.subform.requery طبعا هتغير subform باسم النموذج الفرعى وطبعا النموذج الفرعى هتظبط تنسيقه يعنى متعملوش حدود وتظبط خلفيته يعنى شغل نقاشة يعنى ههههههههههههه الله معك دى فكرتى لو عجبتك خد بيها معجبتكش ميضرش وجزاك الله خيرااااااا

اعتقد ان المرفق لا يتعارض مع ما تقول فى الواقع انت تقوم فعليا باعطاء رقم لكل منتج انا اقوم باخذ هذا الرقم وتسمية الصورة به ليتسنى لنا عرض الصورة لكل سجل اى كان الرقم الذى ستكتبه سيتم تسمية الصورة به تلقائيا

السلام عليكم اخى الكريم تم ادراج بعض التحديثات على مرفقك وهى كالاتى 1 - تم ادراج وحدة نمطية لنقل الصور الى مجلد الصور 2 - تم ادراج وحدة نمطية لجلب مسارات الصور من كل فولدر يتم اختيارة ----------------------- يتم انشاء المجلدات الاتية تلقائيا فى نفس مسار قاعدة البيانات 1 - open backup --- وذلك لوضع اخر نسخة احتياطة عند الفتح 2 - close backup --- وذلك اخر نسخة احتياطية عند الاغلاق 3 - ادراج مجلد باسم الناريخ مع تغيير علامة / الى - وذلك لاستحالة انشاء مجلد يحمل تلك العلامة ------------------------------------- تم ادراج كائن واحد داخل النموذج وهى ( Listbox ) وذلك لاحضار مسارات الصور بها واصبح شكل مرفقك كالتالى ------------------------ تم ادراج دالة لجلب الاسم والنوع للصورة عند اختيارها وهى كالتالى Function GetFilenameFromPath1(ByVal strPath As String) As String If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then GetFilenameFromPath1 = GetFilenameFromPath1(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) End If End Function الية العمل كما طلبت اخى الكريم 1 - يتم انشاء نسخة احتياطية عند الفتح وعند الاغلاق فى مجلدين منفصلين فى نفس مسار قاعدة البيانات وهذا هو الكود الخاص بهما مع تغيير اسم الملف فقط فى الحالتين Dim OldFile, DBwithEXT, DBwithoutEXT, NewFile, CopyMyDB OldFile = CurrentDb.Name DBwithEXT = Dir(OldFile) DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4) NewFile = CurrentProject.Path & "\" & "open backup" & "\" & DBwithoutEXT & Right(DBwithEXT, 4) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MyErr: If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description وحدة نمطية لجلب الملفات من مجلد محدد الى Listbox Public Function ListFiles(strPath As String, Optional strFileSpec As String, _ Optional bIncludeSubfolders As Boolean, Optional lst As ListBox) On Error GoTo Err_Handler 'Purpose: List the files in the path. 'Arguments: strPath = the path to search. ' strFileSpec = "*.*" unless you specify differently. ' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well. ' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window. ' The list box must have its Row Source Type property set to Value List. 'Method: FilDir() adds items to a collection, calling itself recursively for subfolders. Dim colDirList As New Collection Dim varItem As Variant Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders) 'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window. If lst Is Nothing Then For Each varItem In colDirList Debug.Print varItem Next Else For Each varItem In colDirList lst.AddItem varItem Next End If Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & err.Number & ": " & err.Description Resume Exit_Handler End Function Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _ bIncludeSubfolders As Boolean) 'Build up a list of files, and then add add to this list, any additional folders Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant 'Add the files to the folder. strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colDirList.add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 'Build collection of additional subfolders. strTemp = Dir(strFolder, vbDirectory) Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then colFolders.add strTemp End If End If strTemp = Dir Loop 'Call function recursively for each subfolder. For Each vFolderName In colFolders Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True) Next vFolderName End If End Function Public Function TrailingSlash(varIn As Variant) As String If Len(varIn) > 0& Then If Right(varIn, 1&) = "\" Then TrailingSlash = varIn Else TrailingSlash = varIn & "\" End If End If End Function بعد كتابة التاريخ وعند اختيار صورة يتم نقلها الى مجلد التاريخ بنفس اسمها وعند التنقل بين السجلات بواسطة الازرار يتم عمل قائمة باسماء الملفات الموجودة داخل كل مجلد الذى يحمل التاريخ يمكنك اضافة اكثر من صورة للتاريخ الواحد ولكن كل منهما على حدا وهذا فيديو يشرح العمل وهذا هو المرفق PIC.rar

اخى الكريم ارفق موضوع جديد لمشكلتك او ادرج هنا رابط المشاركة الخاصة بك

السلام عليكم ورحمة الله تعالى وبركاته اخى الكريم قمت ببعض التعديلات على جدول الاصناف فقط قمت بالغاء حقل مسار الصورة وغيرته الى امتداد الصورة الية العمل الجديدة للبرنامج ستكون كالتالى اولا يجب تحديد مسار مجلد الصور الموجود على جوجل درايف لكل مستخدم للبرنامج قمت بتسهيل الموضوع عليك فقط مرة واحدة اختر المسار عن طريق هذا الزر وعند اختيارك المجلد يقوم البرنامج باخذ المسار واسم الكمبيوتر الخاص بك وادراجهم داخل جدول قمت بانشائه عند اختيارك صورة يقوم البرنامج جلب نوع الصورة وادراجها فى جدول الاصناف ثم نقلها الى مجلد الصور برقم الصنف اى انه يتم تسمية الصورة برقم الصنف الاكواد المستخدمة دالة جلب نوع الصورة عند اختيارها Function GetFileTypeFromPath(ByVal strPath As String) As String If Right$(strPath, 1) <> "." And Len(strPath) > 0 Then GetFileTypeFromPath = GetFileTypeFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) End If End Function داالة جلب اسم الكمبيوتر الحالى للمستخدم Declare Function apiGetUserName Lib "advapi32" Alias "GetUserNameA" (ByVal buffer As String, BufferSize As Long) As Long Declare Function apiGetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal buffer As String, BufferSize As Long) As Long Function GetUserName() As String Dim strName As String Dim lngSize As Long Dim lngRetVal As Long strName = Space(15) lngSize = 15 lngRetVal = apiGetUserName(strName, lngSize) GetUserName = Left$(strName, lngSize - 1) End Function Function GetComputerName() As String Dim strName As String Dim lngSize As Long strName = Space(16) lngSize = 16 If apiGetComputerName(strName, lngSize) Then GetComputerName = Left$(strName, lngSize) Else GetComputerName = vbNullString End If End Function دالة نقل الملفات 'Network Security - Network does not allow reference to the Scripting runtime library (COM Object) ' Using Window 32 API (Kernel 132) to Move file Private Declare Function CopyFileA Lib "kernel32" (ByVal ExistingFileName As String, _ ByVal NewFileName As String, ByVal FailIfExists As Long) As Long Public Function Copy(FileSrc As String, FileDst As String, Optional NoOverWrite As Boolean = True) As Boolean Dim Flag As Long Dim Name As String Name = Right(FileSrc, Len(FileSrc) - InStrRev(FileSrc, "\")) If CopyFileA(FileSrc, FileDst & Name, NoOverWrite) Then Copy = True Else Copy = False End If End Function ويتم تنفيذها بهذا الشكل Dim sedo As Object Dim des, fileto As String Set sedo = CreateObject("Scripting.FileSystemObject") sedo.CopyFile fileto, des, True حيث ان fileto هو الملف المراد نقله يتم تحديد المسار كاملا بما فى ذلك نوع الملف حيث ان des هو المسار المراد نقل الملف اليه ويتم تحديد المسار كاملا ايضا بما فى ذلك نوع الملف هكذا "des = "C:\Users\xmen5\Desktop\New Microsoft Word Document (2).docx و "fileto = "C:\Users\xmen5\Desktop\New Microsoft Word Document (2).docx ويمكن تغير اسم الملف فقط فى متغير des ليتم نقل الملف باسم جديد تم تغيير مصدر بيانات عنصر تحكم الصورة ليتمكن من قراءة مسار الصورة هكذا وهذا كود انشاء مجلد جديد فى مسار محدد لاخونا السائل If Len(Dir(des, vbDirectory)) = 0 Then MkDir Path:=des end if حيث ان des هى مسار المجلد تذكر يا اخى يجب تحديد مسار مجلد الصور اولا ولمرة واحدة لكل مستخدم للبرنامج والان مع المرفق http://www.mediafire.com/file/t6pv4pg7iz9feg6/ACC.rar/file

اذا تابع الموضوع هنا سادرج الاكواد ان شاء الله لاحقا مع شرحها

اساعدك ان شاء الله ولكن اود ان الفت انتباهك الى هذا اذا انت بحاجة الى شيئين الاول عدم وضع مسار الصورة فى الجدول الثانى نقل الصور تلقائيا عند اختيارها الى مجلد الصور وقبل كل هذا اود ان اسالك ما المانع من اضافة حقل ترقيم تلقائى لترقيم كل سجل وهذا الرقم سيكون اسم الصورة

السلام عليكم اخى الكريم هل لى ان اسالك ما هى المشكلة التى واجهتك فى مرفقى حتى يتسنى لنا حلها سويا

انا اسف يبدو ان لدى معلومات مغلوطة بالنسبة لوضع الامان هناك عملية تسمى المناقلات هذه العملية تتالف من سلسلة متتابعة من العمليات المنفصلة هذه العمليات تنفذ دفعة واحدة اما ان تنجح كلها او تفشل كلها دفعة واحدة الية عملها ( الحفظ ثم التثبيت ) بمعنى يتم حفظ جميع التغيرات التى تمت من بداية المناقلة فا اذا نجحت يتم تثبيت التغييرات واذا فشلت فيتم اعادة النظام الى ما قبل المناقلة للاسف اكسس لا تعتمد عملية المناقلة فقط سيكول (SQL ) و اوريكال (Oracle ) تعتمد ذلك انا متاسف اصحح المعلومة

فى اعتقادى الكود اسرع وامن فى حالة حدوث عطل مفاجئ الكود يلغى العملية برمتها عكس الاستعلام

اخى الكريم قم بانشاء نسخة فارغة بواسطة اكسس 2007واستورد جميع كائنات نسختى بما فيى ذلك جدول مخفى اسمه MSysResourcess فقط لاحظ الاتى هنا جدولين يحملان نفس الاسم باختلاف حرف واحد S زيادة فى اسم جدولى اترك الجدول الثانى واستورد جدولى لان به المرفقات المخزنة داخل قاعدة البيانات او استميحك عزرا قم بتنزيل اوفيس 2013 وسيعمل معك عادى جدا وانا من واجبى ان افعل ذلك وساقوم بانشاء برنامجى على قواعد بيانات اقدم فى الاصدار من اوفيس 2013

شكرا لك اخى الكريم هو شغال بس بيحب يخضنا بس هههههههههه فقط افتح النموذج Messanger وانظر الى مصدر البيانات الخاص به اجعل مصدر بياناتها الجول Msgtbl فقط واعلمنى بالنتائج

اخوانى الكرام اشكركم جميعا على تفاعلكم وابداء ملاحظتكم التى هى فى غاية الاهمية لى تعقيب بسيط نحن نتعامل مع قواعد بيانات اكسس التى لن تجد بها سبل الراحة الكثيرة التى تجدها فى برامج اخرى نحن هنا نطوعها ونروضها لكى تتجاوب مع متطلباتنا انا قرات ملاحظتكم جميعا واصدقكم القول فكررت بها جميعا ليست هناك مشكلة على الاطلاق فى التحديث سواء كانت جداول - استعلامات - نماذج - تقارير - ماكرو - وحدات نمطية نحن نتعامل مع قواعد بيانات درجة حمايتها صفررررررررررر لذلك كل شئ مباح بالنسبة لك كمصمم نعم فى قواعد بيانات من نوع ACCDE او Mde لا تسطيع تغيير الاكواد سواء فى النماذج او الوحدات النمطية او حتى لا تسطيع حذف النماذج والوحدات النمطية ولكن دائما هناك ثغرة كل ما احتاجه هو الجداول التى بيها البيانات ما عدا ذلك استطيع انشائه فى قاعدة اخرى واستيراد الجداول الى القاعدة الجديدة المحدثة ثم العمل عليها وحذف القديمة السؤال ماذا لو كان التحديث فى الجداول انت كمصمم لهذه القاعدة اعلم بما فيها بمعنى الا تسطيع تنفيذ كود برمجى يمكنك من جلب البيانات من الجداول فى القاعدة القديمة الى القاعدة الجديدة ذلك الامر متاح اماماكم حتى لوكان الجدول الجديد غير مطابق فى عدد الحقول كما فى الجدول القديم وهناك امر اخر وهو تنفيذ كود برمجى لاضافة تحديث للجدول القديمة كمثلا اضافة حقل جديد وماذا عساه سيكون التحديث فى الجداول غير هذا ؟ ثم استيرادها الى القاعدة المحدثة اخوانى جل ما فى الامر ان هذا الموضوع فكرة واستطعت بفضل الله تنفيذها واعجبنى كثيرا تعليق اخونا فارس كثيرا هذا ما ابحث عنه تنزيل المرفق ثم العمل عليه هو يريد ان يجرب بنفسه ويحاول الى ان يصل المرفق الى افضل وافضل ويفيد الناس كثيرا هذا انا اشكركم جميعا على ملاحظتكم المرفق مجانى للجميع فقط اجعله ينفذ متطلباتك شعلة البداية كانت من عندنا فقط لا تخمدو نيرانها

يجب اضافة مربع نص فى النموذج بنفس الاسم المظلل هذا انا ضفته ولكن قمت بتصغير طوله وعرضه الى صفر

الروابط تعمل كويس هل كل الاخوة قابلتهم نفس المشكلة ؟؟ شكرا لكم وبارك فيكم

تفضل يا اخى الكريم مرفقك وهذه صورة من الحل فيديو للحل تسجيل العميل 1.rar

اخى الفاضل تم تعديل مرفقك فى هذا الموضوع نظرا لعدم وجود امكانية رفع ملفات اخرى هنا وهذا فيديو يشرح كيف يعمل

شكرا لكم جميعا هل هناك اى ملاحظات ؟؟

بارك الله لكم جميعا وشكرا لكم

بارك الله لكم جميعا وشكرا لكم

بارك الله فيكم وشكر الله لكم

هناك حل بسيط جدا لتفادى تلك المشكلة وهى حفظ الايقونة داخل قاعدة البيانات واستخرجها فى حالة مسحها وهذا ما فعلته هنا فى اول نموذج ستجد كود لاستخراج الايقونة فى نفس مسار قاعدة البيانات

السلام عليكم ورحمة الله تعالى وبركاته اتمنى ان تكونو جمبعا بخير حال الموضوع اليوم قد وضحه العنوان كنت قد وعدت الاخوة فى هذا الموضوع ببعض التحديثات فوجدت ان كل هذه التحديثات يقدمها تطبيق واتساب اتجهت بفضل الله وكرمه الى محاكات نظام واتساب بالاكسس هذا الموضوع هدية لككم واتمنى ذكر الحقوق ان امكن ذلك والان مع الشرح اعتذر لرفعه على موقع خارجى لانتهاء المساحه هنا حجمة 2 ميجا فقط https://www.mediafire.com/file/ir1l91d6g18d8iy/AccessWatsapp.rar/file اتمنى التجربة واعلامى بالنتائج شكرا لكم

Dim records As Object Dim db As Object Dim strText As String Set db = CurrentDb() Set records = db.OpenRecordset("Tbl1") strText = "" While Not records.EOF strText = strText & records!fild1 & "," records.MoveNext Wend 'مرحلة التصدير Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim oFile As Object Set oFile = fso.CreateTextFile(CurrentProject.Path & "\" & "C" & ".txt") oFile.WriteLine strText oFile.Close Set fso = Nothing Set oFile = Nothing records.Close Set records = Nothing Set db = Nothing ضع هذا الكود فى زر الذى تصدر به البيانات يجب تغيير اسم الجدول واسم الحقل على حسب مرفقك

هههههههههههههههههه سبقتنى يا ابو خليل عموما دقيقة وسادرج الكود لاخوننا الفاضل