سامي الحداد

جرب هذا الملف الان

bdd2003.mdb

ما هي نسخة الاوفيس لديك هل هي 2016 او اقدم؟

السلام عليكم

تفضل أخي الكريم حسب ما فهمت من طلبك

لقد غيرت اسماء الحقول من العربي الى الانكيزي وذلك لصعوبة عمل الاكواد باللغة العربية.

Option Compare Database
Option Explicit
Private Sub cboName_AfterUpdate()
    Dim rs As Object
    Set rs = Me.Recordset.Clone
    rs.FindFirst "[Name_Surname] = '" & Me![cboName] & "'"
    If Not rs.EOF Then Me.Bookmark = rs.Bookmark
    cboLevel = ""
    cboSubject = ""
    cboRegiment = ""
End Sub

Private Sub cboLevel_AfterUpdate()
    Dim rs As Object
    Set rs = Me.Recordset.Clone
    rs.FindFirst "[Level] = '" & Me![cboLevel] & "'"
    If Not rs.EOF Then Me.Bookmark = rs.Bookmark
    cboName = ""
    cboSubject = ""
    cboRegiment = ""
End Sub

Private Sub cboRegiment_AfterUpdate()
 Dim rs As Object
    Set rs = Me.Recordset.Clone
    rs.FindFirst "[Regiment] = '" & Me![cboRegiment] & "'"
    If Not rs.EOF Then Me.Bookmark = rs.Bookmark
    cboName = ""
    cboSubject = ""
    cboLevel = ""
End Sub

Private Sub cboSubject_AfterUpdate()
   Dim rs As Object
    Set rs = Me.Recordset.Clone
    rs.FindFirst "[Subject] = '" & Me![cboSubject] & "'"
    If Not rs.EOF Then Me.Bookmark = rs.Bookmark
    cboName = ""
    cboRegiment = ""
    cboLevel = ""
End Sub

وهذا الملف بعد التعديل

بالتوفيق

bdd2.accdb

السلام عليكم

اليك التعديل هل هو المطلوب ؟

S&M_22.rar

اخي الكريم  طلبك الاول كان هذا

19 ساعات مضت, moho58 said:

نعم اريد  اظهار جميع اسماء المؤطرين الموجودين في الجدول tbl_Teachers

ثم طلبت

16 ساعات مضت, moho58 said:

أنا أريد أن  أختار الوحدة فقط   تم أختار المؤطر

ثم  غيرت طلبك الى هذا

16 ساعات مضت, moho58 said:

أخي عند اختيار  grade  من النموذج  يجب أت تكون subject  موافقة لها مثل ما هو موجود  في جدول  tbl_Teachers

كما هو موضح  في الجدول

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

لقد عملت لك مربعين تحرير وسرد الاول Grade والثانني Subject  انظر للطريقة المتبعة وحاول ان تكمل . 

إذا كان هذا طلبك كما قلت لك عليك  بتغير اشياء كثيره .

بالتوفيق

t-times.accdb

حياك الله اخوي

تفضل التعديل

t-times.accdb

الشكر لله عز وجل

تفضل اخي العزيز

فقط عدل على باقي الخانات بنفس الطريقة

بالتوفيق

t-times.accdb

هل هذا هو المطلوب؟

انطر الى اول خانه فقط .

t-times.accdb

في 3‏/7‏/2023 at 08:13, moho58 said:

* أما في المؤطر فتظهر قائمة بأسماء جميع    TeacherName   الموجودة في الجدول TeacherName   وأنا أختار المؤطر  

اخي الكريم

هل  تقصد إظهار اسم المؤطر فقط بدون اسم المادة ؟  لانني بصراحة لم افهم المطلوب بالضبط .

وعليكم السلام 

تفضل اخي الكريم 

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

بالتوفيق

Private Sub Form_AfterUpdate()

    Dim rs As DAO.Recordset
    Dim strSQL As String
    Dim Field1, Field2, Field3 As Variant
    
        strSQL = "SELECT * FROM aaa"
        Set rs = CurrentDb.OpenRecordset(strSQL)
                      rs.MoveFirst
                      Do Until rs.EOF
         Field1 = rs.Fields("Nam").Value
         Field2 = rs.Fields("Home").Value
         Field3 = rs.Fields("dats").Value

        If IsNull(Field1) Or Field1 = "" Or IsNull(Field2) Or Field2 = "" Or IsNull(Field3) Or Field3 = "" Then
        
                      MsgBox "توجد حقول غير مكتملة ...  سوف يتم حذف السجل كليا", vbExclamation, "تنبيه"
                      rs.Delete
                      If Not rs.EOF Then
                      rs.MoveNext
        End If
                      Else
                      rs.MoveNext
        End If
        
        Loop
                      rs.Close
                      Set rs = Nothing
                      DoCmd.Requery
    
                      MsgBox " . تمت عملية حذف الحقول الفارغة ", vbInformation, "تمت العملية بنجاح"
End Sub

وهذا الملف بعد التعديل

program.accdb

الشكر لله عز وجل اخي العزيز.

بالتوفيق 

وعليكم السلام

تفضل اخي الكريم

Private Sub cmdSearch_Click()
Dim strSearch As String
Static XC
Dim rs As Object
Set rs = Me.RecordsetClone
Me.أمر26.Visible = False
Me.أمر27.Visible = False
Me.أمر29.Visible = False
Me.أمر30.Visible = False
Me.أمر32.Visible = False
Me.أمر35.Visible = False

   If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then
          MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث"
          Me![txtSearch].SetFocus
   Exit Sub
   End If
   strSearch = Me![txtSearch]
  
   With rs
  .FindNext "[emp_nam] like '*" & strSearch & "*'"
   
   If Not .emp_nam Like "*" & strSearch & "*" Then
          MsgBox "لا يوجد سجل بهذا الإسم :  " & strSearch, vbCritical, "غير موجود"
          Me.txtSearch = ""
          Me![txtSearch].SetFocus

   ElseIf .NoMatch Then
          MsgBox "آخر سجل في البحث عن :  " & strSearch, vbExclamation, "آخر سجل"
          Me.cmdSearch.Caption = "بحث"
          Me.txtSearch = ""
          Me![txtSearch].SetFocus
          Me.cmdSearch.ForeColor = RGB(0, 0, 255)
Me.أمر26.Visible = True
Me.أمر27.Visible = True
Me.أمر29.Visible = True
Me.أمر30.Visible = True
Me.أمر32.Visible = True
Me.أمر35.Visible = True

  DoCmd.GoToRecord , , acFirst
  rs.MoveFirst
  XC = 0
   Else
XC = XC + 1
   Me.Bookmark = .Bookmark
          If XC = 1 Then MsgBox "تم ايجاد اسم :  " & strSearch, vbInformation, "مبروك"
          Me.cmdSearch.Caption = "اكمال البحث"
          Me.cmdSearch.ForeColor = RGB(255, 0, 0)
   End If
   End With

rs.Close
Set rs = Nothing


End Sub

وهذا الملف بعد التعديل للعلم انا استخدم الاوفيس 2021 اذا لم يفتح معك الملف فقط انسخ الكود اعلاه وضعه تحت زر البحث ويجب عليك تغير مسميات الزر ونص البحث كما هو في الكود.

تحياتي 

Database2023.accdb

وعليكم السلام 

الخطاء هنا

Exit_cmd_Select_Click:

    Call cmd_close_Click
    Exit Sub
    
err_cmd_Select_Click:

    If Err.Number = 1 Then
            
    Else

        MsgBox Err.Number & vbCrLf & Err.Description
        Resume Exit_cmd_Select_Click


وهذا الصحيح

Exit_cmd_Select2_Click:

    Call cmd_close_Click
    Exit Sub
    
err_cmd_Select2_Click:

    If Err.Number = 1 Then
            
    Else

        MsgBox Err.Number & vbCrLf & Err.Description
        Resume Exit_cmd_Select2_Click

وهذا ملفك بعد التعديل

shady master garage test1 24052023.rar

جرب التالي

Me.المبلغ_الاجمالي.DefaultValue = Nz(Form_الطالب.LenaT) - Nz(DSum("[دفع]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف) - Nz(DSum("[mortaghday]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف), 0))

واليك الملف ان شاءالله يكون هو المطلوب

11.accdb

7 دقائق مضت, Eng.Qassim said:

وعليكم السلام..

دوال المجال لاتعمل هكذا..

11.rar 141.53 kB · 0 downloads

المعذرة استاذ قاسم لم انتبه لردك كنت اكتب  الرد وانشغلت بالرد على الهاتف 

السلام عليكم 

بالاضافة لما تقدم به جميع الاساتذة اليك الحل التالي على حسب فهمي لطلبك.

يرجى موافاتنا بالنتيجة.

Private Sub Supplier_NotInList(NewData As String, Response As Integer)

    Dim Db As DAO.Database
    Dim Rs As DAO.Recordset
    Dim Msg As String

    Msg = " " & NewData & "  المورد  " & Supplier & vbCr & vbCr & " غير موجود في القائمة " & vbCr & vbCr
    Msg = Msg & "هل تود إضافة هذا المورد ؟"
    If MsgBox(Msg, vbQuestion + vbYesNo) = vbNo Then
        Response = acDataErrContinue
        MsgBox "تم إلغاء عملية الإضافة", vbInformation, "تنبية"
        Supplier = ""
        Exit Sub
    End If

    On Error GoTo CancelAddNew
    Set Db = CurrentDb
    Set Rs = Db.OpenRecordset("Table1", dbOpenDynaset)

    Rs.AddNew
    Rs![Supplier] = NewData
    Rs.Update
    Response = acDataErrAdded

    Rs.Close
    Set Rs = Nothing
    Set Db = Nothing
    Exit Sub

CancelAddNew:
    
    Response = acDataErrContinue
    Set Rs = Nothing
    Set Db = Nothing
    Exit Sub
    

End Sub

الملف بعد التعديل 

تحياتي

رسائل تنبية.accdb

7 ساعات مضت, Radwan0 said:

وهو المطلوب

باركك الرحمن تعالى

 

الله ييارك فيك اخي الكريم.

قد لا يحتوي متغير addPath على مسار ملف صالح. يجب عليك التحقق من أن قيمة addPath هي مسار ملف صالح وأن الملف موجود في هذا الموقع.

قد لا يتم تعيين المتغير المحتوي على المجلد بشكل صحيح. يجب عليك التحقق من أن قيمة containsFolder هو مسار المجلد الصحيح الذي يحتوي على الملف المراد إضافته.

قد لا يتم تعيين متغير itemToZip بشكل صحيح. يجب عليك التحقق من أن قيمة itemToZip هو اسم الملف الصحيح لإضافته إلى أرشيف zip.

قد تكون هناك مشكلة في fSource.items.Item ((i)) مقارنة الاسم في حلقة For. يجب عليك التحقق من صحة المقارنة ومن أنه تم العثور على الملف الصحيح المراد إضافته.

هل البرنامج موجود في فولدر واحد ام يندرج تحت عدة فولدرات ؟ 

جرب هذه الاضافة ووافنا بالنتيجة.

Private Sub Form_Load()
    Me.Image1.SizeMode = fmPictureSizeClip
End Sub

من بعد إذن الاستاذ @kkhalifa1960 جزاه الله خيرا

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

تحياتي للجميع

Sub AddToZip(ByVal zipArchivePath As String, ByVal addPath As String)
    Dim sh As Object
    Dim fSource As Object
    Dim fTarget As Object
    Dim iSource As Object
    Dim sourceItem As Object
    Dim i As Long
    Set sh = CreateObject("Shell.Application")
    Set fTarget = sh.Namespace((zipArchivePath))
    If fTarget Is Nothing Then
        createZipFile zipArchivePath
        Set fTarget = sh.Namespace((zipArchivePath))
        If fTarget Is Nothing Then
            MsgBox "فشل إنشاء ملف مضغوط", vbCritical
            Exit Sub
        End If
    End If
    Dim containingFolder As String
    Dim itemToZip As String
    containingFolder = Left(addPath, InStrRev(addPath, "\"))
    itemToZip = Mid(addPath, InStrRev(addPath, "\") + 1)
    Set fSource = sh.Namespace((containingFolder))
    For i = 0 To fSource.items.Count - 1
        If fSource.items.Item((i)).Name = itemToZip Then
            Set sourceItem = fSource.items.Item((i))
            Exit For
        End If
    Next i
    If sourceItem Is Nothing Then
        MsgBox "فشل العثور على ملف لإضافة ملف مضغوط  ", vbCritical
        Exit Sub
    End If
    On Error Resume Next
    fTarget.CopyHere sourceItem
    If Err.Number <> 0 Then
        MsgBox "فشل في إضافة ملف لضغطه", vbCritical
        Err.Clear
    End If
    On Error GoTo 0
End Sub

جرب هذا التعديل و وافنا بالنتيجة

Private Sub mail_DblClick(Cancel As Integer)
    Dim Msg As String
    
    If IsNull(Mail) Or Len(Mail) = 0 Then
        MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني "
        Exit Sub
    End If
    
    Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _
          " hey " & namecus & "<br>" & _
          "</div>"
    
    Dim O As Outlook.Application
    Dim M As Outlook.MailItem
  
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
  
    With M
        .BodyFormat = olFormatHTML
        .HTMLBody = Msg
        '.Body = txt - if you see olformatplain
        .To = Mail
        '.CC="khate9191@gmail.com;khateb91@outlook.com"
        '.BCC="hateeb991@gmail.com"
        .Subject = " new mail " & Now()
        .Display
       '.send
    End With
    
    Set M = Nothing
    Set O = Nothing
End Sub

تحياتي

1 ساعه مضت, kkhalifa1960 said:

الأخوة همتكم معي لاكتشاف الخطأ أو ترتيب الكود لأني مقدر أكتشفه  لأنه يعمل عندي !!!!!!!!!!!!!

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

أحسنت وبارك الله فيك اخي @kkhalifa1960

وعليكم السلام 

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

Private Sub mail_DblClick(Cancel As Integer)
 Dim Msg As String
    
    If Len(Mail) = 0 Then
        MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني "
        Exit Sub
    End If
    
    Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _
          " hey " & namecus & "<br>" & _
          "</div>"
    
    Dim O As Outlook.Application
    Dim M As Outlook.MailItem
  
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
  
    With M
        .BodyFormat = olFormatHTML
        .HTMLBody = Msg
        '.Body = txt - if you see olformatplain
        .To = Mail
        '.CC="khate9191@gmail.com;khateb91@outlook.com"
        '.BCC="hateeb991@gmail.com"
        .Subject = " new mail " & Now()
        .Display
       '.send
    End With
    
    Set M = Nothing
    Set O = Nothing
End Sub

تحياتي

السلام عليكم  

بالاضافة لما تفضل بة اساتذتي الكرام جرب تغير هذه الاسطر . و وافنا بالنتيجة

Dim strInvoiceID As String

Set rsFatora = db.OpenRecordset("SELECT * FROM tblFatora WHERE FatoraId <> '" & strInvoiceID & "'")
Set rsHaraka = db.OpenRecordset("SELECT * FROM tblHaraka WHERE Fatora_id <> '" & strInvoiceID & "'")

بالتوفيق

نعم اخي @محمد احمد لطفى

تحتاج الى مكتبة  Microsoft Excel XX.X Object Library

xx.x = رقم نسحة الاوفيس لديك  12.0 او 14.0 او 15.0 الخ..

تحياتي

اخي العزيز @العبيدي رعد

2 ساعات مضت, العبيدي رعد said:

العفو  الخلط بالكيبورد   اقصد  جدول  user&pass  ايضا  ...  هل  احذفهما  من  البرنامج ؟  
وسؤالي  كيف  أحدد  الصلاحيات  ابتداءا  ؟  وعند  دخولي  للبرنامج  عن  طريق  الفورم   كيف  سيتعرف  عن  صاحب  الصلاحيات لنموذج  الادمن ؟

الجدول user&pass كان في ملفك من الاساس

تحديد الصلاحيات يتم عن طريق دخول الادمن من نموذج تسجيل الدخول او الجدول ثم اعطاء كل الصلاحيات للنماذج وتفعيل كل الخانات  ما عدا  Button Disable. ضروري ان يكون الزر غير مفعل

وبعدها تستطيع ان تكمل مع باقي المستخدمين واعطاء كل مستخدم الصلاحية المطلوبة. وإغلاق الازرار 

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

@سامي الحداد  السلام عليكم

أخي  العزيز  .. عرفت الادمن  من جدول  الصلاحيات  ولكن يظهر لي خطأ في الكود  عندما  اريد  الدخول الى الصفحة الرئيسية  main

وأرفق صور توضيحية للجدول  والخطأ  الذي  يحث  في  حدث    onopen  للنموذج 

بالنسبة لهذا الخطاء هو انه  زر الامر Command0  غير موجود في هذا  القورم . 

وهناك ايضا خطاء انه تم تفعيل زر Button Disable لان الشخص ابو ايمان له كل الصلاحيات إذن يجب إلغاء هذا الزر وعدم تفعيله اذا كان الادمن.

سارفق لك نفس ملفك الاول والذي عملت عليه واعطيت سامي صلاحية الادمن وكلمة المرور 555  انظرا جيدا كيف تم العمل واكمل .

واي استفسار بخدمتكم . ربما أتاخر في الاجابة بسببت فرق التوقيت 

تحياتي

صلاحيات.accdb