Elsayed Bn Gemy

بحب انا موضوع الصور دا  ههههههههههههه

بص هو Dlookup مع حالتك دى مش هتنفع متحاولش بس احنا ممكن نتحايل عليها

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

وفى خصائص النموذج  تبويب بيانات  هتلاقى اوبشن اسمه ربط الحقول الرئيسية زاوبشن تانى اسمه ربط الحقول التابع

حط فى الاتنين Id

واحتياطى فى حدث بعد التحديث للكموبوبوكس  حط الكود دا

me.subform.requery

طبعا هتغير subform  باسم النموذج الفرعى

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

الله معك دى فكرتى لو عجبتك خد بيها معجبتكش  ميضرش

وجزاك الله خيرااااااا

5 ساعات مضت, ابو حمزة سكر said:

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

اعتقد ان المرفق لا يتعارض مع ما تقول 

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

3 ساعات مضت, عبدالله مروش said:

السلام عليكم استاذ @Elsayed Bn Gemy

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

وعمل نسخة احتياطية باعدادات معينة ولك جزيل الشكر والتقدير 

 

PIC.rar

السلام عليكم اخى الكريم

تم ادراج بعض التحديثات على مرفقك وهى كالاتى

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

58 دقائق مضت, عبدالله مروش said:

السلام عليكم 

اخي @Elsayed Bn Gemy ممكن تجيني على الخاص 

 

اخى الكريم ارفق موضوع جديد لمشكلتك 

او ادرج هنا رابط المشاركة

الخاصة بك 

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

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

الية العمل الجديدة للبرنامج ستكون كالتالى

اولا يجب تحديد مسار  مجلد الصور الموجود على جوجل درايف لكل مستخدم للبرنامج

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

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

اى انه يتم تسمية الصورة برقم الصنف 

الاكواد المستخدمة

دالة جلب نوع الصورة عند اختيارها

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

2 دقائق مضت, عبدالله مروش said:

السلام عليكم 

لدي نفس الموضوع واريد مساعدة 

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

 

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

اساعدك ان شاء الله  ولكن اود ان الفت انتباهك الى هذا

اذا انت بحاجة الى شيئين الاول

عدم وضع مسار الصورة فى الجدول
الثانى نقل الصور تلقائيا عند اختيارها الى مجلد الصور
 

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

في ١٠‏/١‏/٢٠١٩ at 12:04, ebnjabalapp said:

وملاحظة اخي Elsayed Bn Gemy الخبير

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

 

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

6 دقائق مضت, عبد الله قدور said:

السلام عليكم

كيف حالك استاذي الكريم

والله معلومة مهمة جدا لكن اذا كان الكود يقوم بنقل عدة سجلات باستخدام do  او for  هل يقوم بالغاء كل السجلات المنقولة ام السجل الذي ظهر في الخطأ فقط

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

انا متاسف اصحح المعلومة

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

في ٢‏/١‏/٢٠١٩ at 10:53, kay1982 said:

السلام عليكم،

بداية أشكركم على هذا البرنامج، غير أن البرنامج لا يشتغل معي ويبقى كما في الصورة،

لذا أرجوا منكم توضيحات أكثر أو إرفاق نسخة أخرى

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

او استميحك عزرا قم بتنزيل اوفيس 2013 وسيعمل معك عادى جدا  وانا من واجبى ان افعل ذلك وساقوم بانشاء برنامجى على قواعد بيانات اقدم فى الاصدار من اوفيس 2013  

منذ ساعه, حسين العربى said:

عمل ممتاذ استاذي الفاضل بس للاسف لايعمل عندي يعطيني هذه الرسالة مع العلم اني اعمل علي اوفيس 2007

 

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

اخوانى الكرام اشكركم جميعا على تفاعلكم وابداء ملاحظتكم التى هى فى غاية الاهمية
 

لى تعقيب بسيط

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

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

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

نعم  فى قواعد بيانات من نوع ACCDE  او Mde  لا تسطيع تغيير الاكواد سواء فى النماذج او الوحدات النمطية  او حتى لا تسطيع حذف النماذج والوحدات النمطية

ولكن دائما هناك ثغرة 

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

وحذف القديمة

السؤال ماذا لو كان التحديث فى الجداول

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

ذلك الامر متاح اماماكم  حتى لوكان الجدول الجديد غير مطابق فى عدد الحقول  كما فى الجدول القديم 

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

ثم استيرادها الى القاعدة المحدثة

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

واعجبنى كثيرا  تعليق اخونا  فارس كثيرا

في ٢‏/١‏/٢٠١٩ at 01:04, فارس بني هلال said:

جاري تنزيل المرفق والعمل عليه وان شاء الله سنوافيكم بانتائج

 

هذا ما ابحث عنه  تنزيل المرفق ثم العمل عليه    هو يريد ان يجرب بنفسه ويحاول الى ان يصل المرفق الى افضل وافضل ويفيد الناس كثيرا هذا

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

يجب اضافة مربع نص فى النموذج بنفس الاسم المظلل هذا

انا ضفته ولكن قمت بتصغير طوله وعرضه الى صفر

14 ساعات مضت, rasamoo said:

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

الروابط تعمل كويس 

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

منذ ساعه, djou said:

بارك الله فيك

4 ساعات مضت, sofiane05552 said:

مشاء الله عمل ممتاز

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

تفضل يا اخى الكريم مرفقك وهذه صورة من الحل

فيديو للحل

تسجيل العميل 1.rar

4 ساعات مضت, sa12345 said:

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

تسجيل العميل 1.zip

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

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

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

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

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

هناك حل بسيط جدا لتفادى تلك المشكلة 

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

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

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

اتمنى ان تكونو جمبعا بخير حال

الموضوع اليوم قد وضحه العنوان

كنت قد وعدت الاخوة فى هذا الموضوع  ببعض التحديثات

فوجدت ان كل هذه التحديثات يقدمها تطبيق واتساب اتجهت بفضل الله وكرمه الى محاكات نظام واتساب بالاكسس

هذا الموضوع هدية لككم واتمنى ذكر الحقوق ان امكن ذلك

والان مع الشرح

اعتذر لرفعه على موقع خارجى لانتهاء المساحه هنا حجمة 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

ضع هذا الكود فى زر الذى تصدر به البيانات

يجب تغيير اسم  الجدول واسم الحقل على حسب مرفقك

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