اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

سامي الحداد

الخبراء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    294

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    1

 نوع المحتوي 

مشاركات المكتوبه بواسطه سامي الحداد

    مساعدة في عدم تكرار الرقم

    في قسم الأكسيس Access

    قام بنشر

    7 ساعات مضت, blue sea said:

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

    مشاركة مع الاستاذ @SAROOK جزاه الله خيرا 

    Private Sub document_name_AfterUpdate()

    Dim Msg, Style, Title, Response
    Dim XX As Variant
    XX = [document name]
    If (Eval("dlookup(""[document name]"",""[input]"",""[nomber] =form![document name]"") Is Not Null")) Then
              
        Msg = "الكتاب رقم" & " " & XX & " " & vbCrLf & _
               "قد تم ادخاله سابقا " & vbCrLf & vbCrLf & _
               "Yes : نعم اذهب الى ذلك السجل" & vbCrLf & _
               "No  : فقط الغي هذا السجل"
        Style = vbYesNo + vbCritical + vbDefaultButton2 + vbMsgBoxRight
        Title = "تحذير الرقم مكرر !! "
                
        Response = MsgBox(Msg, Style, Title)
        If Response = vbYes Then
'        DoCmd.GoToControl "document name"
        DoCmd.FindRecord XX, , , , , acAll, True
        End If
    Me.Undo
End If
End Sub

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

    بالتوقيق

    abcd.rar

    • Thanks 1

    تصفية البحث على فرع معين

    في قسم الأكسيس Access

    قام بنشر

    السلام عليكم

    مشاركة مع معلمنا القدير ابو خليل

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

    Private Sub Text1_J_Change()

    Dim strFilter As String, strSearch As String

    If Nz(Me.Text1_J.Text) = "" Then
    Me.DataSearch_J.Form.Filter = ""
    Me.DataSearch_J.Form.FilterOn = False

Else
    strSearch = Replace(Me.Text1_J.Text, "'", "''")
    strFilter = strFilter & "Branch LIKE '*" & strSearch & "*' OR "
    strFilter = strFilter & "SubStatement LIKE '*" & strSearch & "*' OR "
    strFilter = strFilter & "BondNo LIKE '*" & strSearch & "*' OR "
    strFilter = strFilter & "BondSerial LIKE '*" & strSearch & "*'"

End If

    If strFilter <> "" Then
    Me.DataSearch_J.Form.Filter = strFilter
    Me.DataSearch_J.Form.FilterOn = True
Else
    Me.DataSearch_J.Form.Filter = ""
    Me.DataSearch_J.Form.FilterOn = False
End If

    Me.Text1_J.SetFocus
    Me.Text1_J.SelStart = Len(Me.Text1_J.Text)

End Sub

    عملت لك  البحث في اربعة حقول Branch و SubStatement و BondNo و BondSerial بالامكان إضافة حقول اخرى للتصفية

    عسى ان يكون هو المطلوب

    بالتوفيق

    البحث في النموذج.rar

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

    في قسم الأكسيس Access

    قام بنشر

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

    جرب هذا التعديل  اخي الكريم 

    Private Sub نص15_AfterUpdate()
    If Me.NewRecord = False Then
        If Not IsNull(DLookup("end_date", "HOL", "end_date = #" & Me.end_date & "# AND ID <> " & Me.id)) Then
            MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال "
            Me.Undo
        End If
    End If
    
    If [نص15] < [نص21] Then
        MsgBox "تاريخ نهاية الاجازة أصغر من تاريخ البداية ", , "مع تحياتي"
        Me.Undo
    End If
End Sub

Private Sub نص21_AfterUpdate()
    If Me.NewRecord = False Then
        If Not IsNull(DLookup("start_date", "HOL", "start_date = #" & Me.start_date & "# AND ID <> " & Me.id)) Then
            MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال "
            Me.Undo
        End If
    End If
End Sub

    واليك الملف

    بالتوفيق

    الاجازات.accdb

    تعديل كود اضافة صورة من pc

    في قسم الأكسيس Access

    قام بنشر

    السلام عليكم 

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

    Private Sub cmd_add_pic_Click()
    On Error GoTo ErrHandler

    If IsNull(Emp_Code) Or Emp_Code = "" Then
        DoCmd.OpenForm "frmMassage"
        Forms!frmMassage!lblMassage.Caption = "فضلاً يجب أن تقوم بإدخال كود الموظف حتى تتمكن من إضافة صورة الموظف"
        Me.Emp_Code.SetFocus
    Else
        Dim employees_Photo_Path As String
        employees_Photo_Path = GetOpenFile_CLT("c:\windows\desktop\", ".حدد مكان الصورة")

        If employees_Photo_Path <> "" Then
            Me![Import_pictures_path] = employees_Photo_Path
            Me![Import_pictures_path] = LCase(Me![Import_pictures_path])
            Me![Image].Picture = Me![Import_pictures_path]

            Dim Project_path As String
            Project_path = Application.CodeProject.Path

            Dim EmployeeFolder As String
            EmployeeFolder = Project_path & "\Images_Company\Employees_Photo\" & Me.Emp_Name

            If Dir(EmployeeFolder, vbDirectory) = "" Then
                MkDir EmployeeFolder
            End If

            Dim Dir_employees_Photo As String
            Dir_employees_Photo = EmployeeFolder & "\" & Me.Emp_Code & ".jpg"

            FileCopy employees_Photo_Path, Dir_employees_Photo
            Me.TxtImagePath = Dir_employees_Photo
            Me.Image_d.Visible = False
        End If
    End If

ErrHandler:
    If Err.Number = 94 Then
        Resume Next
    End If
End Sub

    واليك الملف 

    بالتوفيق

    test scan4-للمسح من سكانر نوع اوتوماتيك فيدر وبدن تحديد عدد الصور.mdb

    مشكلة اختفاء ورقة الخصائص

    في قسم الأكسيس Access

    قام بنشر

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

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

    ثانيا  من الممكن أن يكون ملف تعريف المستخدم تالفًا. حاول إنشاء ملف تعريف مستخدم جديد على جهاز الكمبيوتر  ومعرفة ما إذا كانت المشكلة مستمرة عند استخدام الاكسس مع ملف التعريف الجديد.

    ثالثا  تحقق من خيارات الوصول للتأكد من تعيين ورقة الخصائص للعرض.  انقر فوق علامة التبويب "ملف"، وحدد "خيارات"، وانتقل إلى قسم "قاعدة البيانات الحالية" أو قسم "مصممي الكائنات"، تأكد من ضبط خيار "ورقة الخصائص" على "المستندات المبوبة" أو "النوافذ المتداخلة".

    تحقق من هذه الاشياء قبل ان تعيد تسطيب الويندوز.  

    بالتوفيق

    • Thanks 1

    طلب مساعده في البحث

    في قسم الأكسيس Access

    قام بنشر

    جرب التعديل  

    Private Sub FindDates_Click()
    Dim startDateFrom As Date
    Dim startDateTo As Date
    Dim endDateFrom As Date
    Dim endDateTo As Date
    Dim filterCondition As String

    If Not IsNull(Me.txtStartFrom) And Not IsNull(Me.txtStartTo) Then
        startDateFrom = DateValue(Me.txtStartFrom.Value)
        startDateTo = DateValue(Me.txtStartTo.Value)

        filterCondition = "(Date1 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#) OR " & _
                          "(Date2 >= #" & Format(startDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(startDateTo, "yyyy-mm-dd") & "#)"
    End If

    If Not IsNull(Me.txtEndFrom) And Not IsNull(Me.txtEndTo) Then
        endDateFrom = DateValue(Me.txtEndFrom.Value)
        endDateTo = DateValue(Me.txtEndTo.Value)

        If filterCondition = "" Then
            filterCondition = "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _
                              "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)"
        Else
            filterCondition = filterCondition & " OR " & _
                              "(Date1 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date1 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#) OR " & _
                              "(Date2 >= #" & Format(endDateFrom, "yyyy-mm-dd") & "# AND Date2 <= #" & Format(endDateTo, "yyyy-mm-dd") & "#)"
        End If
    End If

    
    If filterCondition <> "" Then
        Me.Filter = filterCondition
        Me.FilterOn = True
    Else
        Me.FilterOn = False
    End If
End Sub

     

    بحث.accdb

    مشكلة اختفاء ورقة الخصائص

    في قسم الأكسيس Access

    قام بنشر

    السلام عليكم

    جرب الكود التالي 

    Option Compare Database
Option Explicit

Private Sub EnablePropertySheet()
    Dim obj As Object
    For Each obj In CommandBars
        If obj.Index < 10 Then
            obj.Enabled = True
        End If
    Next obj
End Sub

Private Sub DisablePropertySheet()
    Dim obj As Object
    For Each obj In CommandBars
        If obj.Index < 10 Then
            obj.Enabled = False
        End If
    Next obj
End Sub

Private Sub BtnOn_Click()
    On Error GoTo ErrHandler
    CommandBars("Property Sheet").Enabled = True
ErrHandler:
    If Err Then Call EnablePropertySheet
End Sub

Private Sub BtnOff_Click()
    On Error GoTo ErrHandler
    CommandBars("Property Sheet").Enabled = False
ErrHandler:
    If Err Then Call DisablePropertySheet
End Sub

    مجرد تعديل بسيط على  كود الاستاذ ابو جودي.

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

    واليك المرفق

    بالتوفيق

    property sheet visible or not _ UP V2.mdb

    • Like 1

    طلب مساعده في البحث

    في قسم الأكسيس Access

    قام بنشر

     السلام  عليكم 

    مشاركة مع الاساتذة حسب ما فهمت .

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

    Private Sub FindDates_Click()
    Dim startDate As Date
    Dim endDate As Date

    If Not IsNull(Me.CboStartDate.Value) And Not IsNull(Me.CboEndDate.Value) Then
        startDate = DateValue(Me.CboStartDate.Value)
        endDate = DateValue(Me.CboEndDate.Value)

        If endDate >= startDate Then
            Me.Filter = "(Date1 = #" & Format(startDate, "yyyy-mm-dd") & "# AND Date2 = #" & Format(endDate, "yyyy-mm-dd") & "#) OR " & _
                        "(Date1 = #" & Format(endDate, "yyyy-mm-dd") & "# AND Date2 = #" & Format(startDate, "yyyy-mm-dd") & "#)"
            Me.FilterOn = True
        Else
            MsgBox ".يجب أن يكون تاريخ الانتهاء أكبر من أو يساوي تاريخ البدء", vbExclamation, "خطاء في نطاق التاريخ"
        End If
    Else
        Me.FilterOn = False
    End If
End Sub

    عسى ان يكون هدا طلبك 

    بالتوفيق

    بحث.accdb

    بحث فى اى جزء من كومبو بوكس

    في قسم الأكسيس Access

    قام بنشر

    السلام عليكم

    مشاركة مع الاستاذ @kkhalifa1960 جزاه الله خيرا لما يقدمه وجعله في ميزان حسناته.                   

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

    اليك  المرفق 

    بالتوفيق 

    Database2.accdb

    طلب مساعده في تحديث جميع السجلات في النموذج والتقرير عند فتحه

    في قسم الأكسيس Access

    قام بنشر

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

    نعم معك حق .. الدالة لم تكن تعمل بشكل صحيح اليك التعديل

    وبالنسبة الى إرجاع الدالة شهرين و-1 يوم بدلاً من 59 يومًا هو أنها تستخدم الدالة DateDiff مع الفاصل الزمني "m"، الذي يحسب عدد أشهر التقويم بين تاريخين وهذا يعني أنه يتجاهل العدد الفعلي للأيام في كل شهر وينظر فقط إلى الفرق بين أجزاء الشهر من التواريخ. على سبيل المثال، الفرق بين 01/07/2024 و01/08/2024 هو شهر واحد، على الرغم من وجود 31 يومًا بينهما. 

    Function CalculateRemainingPeriod(StartDate As Date, EndDate As Date) As String
    Dim Years As Long
    Dim Months As Long
    Dim Days As Long
    Dim Result As String
    Dim TodayDate As Date
    TodayDate = Date
    Years = DateDiff("yyyy", TodayDate, [نهاية عقد العمل])
    TodayDate = DateAdd("yyyy", Years, TodayDate)
    Months = DateDiff("m", TodayDate, [نهاية عقد العمل])
    TodayDate = DateAdd("m", Months, TodayDate)
    Days = DateDiff("d", TodayDate, [نهاية عقد العمل])

    Result = Years & " years, " & Months & " months, " & Days & " days"
    CalculateRemainingPeriod = Result

End Function

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

    التاريخ.accdb

    طلب مساعده في تحديث جميع السجلات في النموذج والتقرير عند فتحه

    في قسم الأكسيس Access

    قام بنشر

    أخي الكريم @imad2024

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

    اذا كان تاريخ اليوم

    2024/1/7 وكان تاريخ نهاية العقد ليس في نفس السنه واقل من تاريخ اليوم 2025/1/6 سوف يعطني باقي الايام خطأ ( 365 )

     

    يمكنك التأكد من حساب الايام  يوجد العديد من المواقع يهذا الخصوص وعلى سبيل المثال هذا الموقع  Date Calculator - Calculate Duration Between Two Dates (indiatimes.com) بامكانك التأكد ضع اي تاريخ وقارن النتيجة مع البرنامج.

    التعديل الاخير صحيح اخي الكريم  لقد اجريت الكثير من التجارب على التعديل الاخير وتاكدت من عدة مواقع بخصوص حساب التاريخ .

    تحياتي

    طلب مساعده في تحديث جميع السجلات في النموذج والتقرير عند فتحه

    في قسم الأكسيس Access

    قام بنشر

    اخي الكريم وكما ذكر الاستاذ @kkhalifa1960جزاه الله خيرا

    في 29‏/12‏/2023 at 00:31, kkhalifa1960 said:

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

    اليك التعديل ووافني بالنتيجة.

    التاريخ.accdb

    كيف نُصدر المرفقات الموجودة في حقل معين في أكسس إلى مجلد خارجي

    في قسم الأكسيس Access

    قام بنشر

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

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

    Public Sub ExportAttachments()
    Dim rs As DAO.Recordset
    Dim attachmentField As DAO.Field2
    Dim attachmentRS As DAO.Recordset2
    Dim attachmentCount As Long
    Dim attachmentPath As String

    attachmentPath = CurrentProject.Path & "\Saving\"
    Set rs = CurrentDb.OpenRecordset("Table1")
    If Not (rs.EOF And rs.BOF) Then
        rs.MoveFirst
        Do Until rs.EOF
            Set attachmentField = rs.Fields("Attachments")
            If Not attachmentField.Value Is Nothing Then
                Set attachmentRS = attachmentField.Value
                For attachmentCount = 1 To attachmentRS.RecordCount
                    If Not FileExists(attachmentPath & attachmentRS.Fields("FileName")) Then
                        attachmentRS.Fields("FileData").SaveToFile attachmentPath & attachmentRS.Fields("FileName")
                        MsgBox "تم تصدير الملفات التالية: " & attachmentPath & attachmentRS.Fields("FileName"), vbInformation, "تمت عملية التصدير بنجاح "

                    Else
                        MsgBox "الملف موجود مسبقا تم إلغاء عملية التصدير: " & attachmentPath & attachmentRS.Fields("FileName"), vbCritical, "تم إلغاء عملية التصدير "
                    End If
                    attachmentRS.MoveNext
                Next attachmentCount
            End If
            rs.MoveNext
        Loop
    End If
    rs.Close
    Set rs = Nothing
    Set attachmentRS = Nothing
End Sub

Function FileExists(filePath As String) As Boolean
    FileExists = Dir(filePath) <> ""
End Function

 'والاستدعاء
Private Sub Command3_Click()
    ExportAttachments
End Sub

    وهذا ملف من  عندي

    بالتوفيق

    تصدير المرفقات الى ملف خارجي.rar

    اظهار الوقت الحالى للكمبيوتر تلقائيا بجانب ادخال التاريخ باليد

    في قسم الأكسيس Access

    قام بنشر

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

    إدا كان لديك حقلين الاول للتاريخ والثاني  للوقت اليك هذا الكود .  استبدل YourDateField و YourTimeField بالأسماء الفعلية لحقول التاريخ والوقت في برنامجك. 

    Private Sub YourDateField_AfterUpdate()
        If Not IsNull(Me.YourDateField) Then
           Me.YourTimeField = Now
    End If
End Sub

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

    Private Sub YourDateTimeField_AfterUpdate()
    If Not IsNull(Me.YourDateTimeField) Then
        Dim currentDate As Date
        currentDate = DateValue(Me.YourDateTimeField)
        Me.YourDateTimeField = currentDate + TimeValue(Now)
    End If
End Sub

    بالتوفيق

    طلب مساعده في تحديث جميع السجلات في النموذج والتقرير عند فتحه

    في قسم الأكسيس Access

    قام بنشر

     السلام عليكم

    بالاضافة لما تفضل به الاستاذ @kkhalifa1960 جزاه الله خيرا

    اليك التعديل 

    في 29‏/12‏/2023 at 15:57, imad2024 said:

    يوجد مشكله وهي المده المتبقيه يوجد بها خطا

    يوجد خطاء في هذا الفانكشن 

    
remainingDays = Day(DateSerial(Year(currentDate), Month(currentDate) + 1, 0)) + remainingDays

    التعديل هنا  

    Function CalculateRemainingPeriod(startDate As Date, endDate As Date) As String
    Dim remainingYears As Integer
    Dim remainingMonths As Integer
    Dim remainingDays As Integer
    Dim currentDate As Date

    currentDate = Date

    remainingYears = Year(endDate) - Year(currentDate)
    remainingMonths = Month(endDate) - Month(currentDate)
    remainingDays = Day(endDate) - Day(currentDate)

    If remainingDays < 0 Then
        remainingMonths = remainingMonths - 1
        remainingDays = DateDiff("d", DateSerial(Year(currentDate), Month(currentDate) + 1, 0), endDate)
    End If

    If remainingMonths < 0 Then
        remainingYears = remainingYears - 1
        remainingMonths = remainingMonths + 12
    End If

    CalculateRemainingPeriod = remainingYears & " years, " & remainingMonths & " months, " & remainingDays & " days"
End Function

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

    الرسالة تختفي بعد ثانيتين لكل موظف. وهذا الكود هنا. 

    
Opt = MesgBox(rs![الاسم] & ": " & remainingDays & " يوم/ أيام ", 1, vbInformation, "الأيام المتبقية لإنتهاء عقد السيد")

    وهذا الكود للعقود التي قاربت على الانتهاء بامكانك التعديل عليها بما يناسبك . 

    Private Sub Form_Current()
    UpdateFields
    Dim rs As DAO.Recordset
    Set rs = Me.RecordsetClone
    
    If Not rs.EOF Then
        rs.MoveFirst
        Do Until rs.EOF
            If rs![نهاية عقد العمل] <= (Date + 1) Then

                If rs![نهاية عقد العمل] = (Date + 1) Then
                    MsgBox "سينتهي عقد العمل يوم غد للسيد / " & rs!الاسم, 0 + 48, " !!! تنبيــــــــــــــــــــــــــــــــــه"
                ElseIf rs![نهاية عقد العمل] = Date Then
                    MsgBox "اليوم هو أخر يوم لعقد العمل للسيد / " & rs!الاسم, 0 + 64, " !!! تنبيــــــــــــــــــــــــــــــــــه"
                ElseIf rs![نهاية عقد العمل] < Date Then
                    MsgBox " إنتهى عقد العمل قبل (" & Str(Date - rs![نهاية عقد العمل]) & ") يوم / أيام للسيد / " & rs!الاسم, 48, "!!! إنتهى التاريخ المحدد لعقد العمل "
                End If
            End If
            
            rs.MoveNext
        Loop
    End If
    
    rs.Close
    Set rs = Nothing
End Sub

    واخيرا اليك الملف عسى ان يكون هو المطلوب.

    بالتوفيق

    التاريخ.accdb

×
×
  • اضف...

Important Information

  I accept