ظهور رسالة الإقتطاع الشهري بشرط

[كريمو2]

السلام عليكم احبتي مشرفي واعضاء المنتدى

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

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

 

Private Sub cmd_Pay_installments_Click()
On Error GoTo err_cmd_Pay_installments_Click

    Dim rst As DAO.Recordset
    
    'Cridi and Elec Payments
    Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.TxtMonth & "')")
    rst.MoveLast: rst.MoveFirst
    RC = rst.RecordCount
    a1 = 0  'just a flag
    a2 = 0  'jusf a flag
    If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) Then
    Select Case MsgBox(" هل تريد ان يتم توزيع الإقتطاعات لشهر" & Me.TxtMonth, vbYesNo + vbQuestion + vbDefaultButton1)
    Case vbYes
    For i = 1 To RC
      
        rst.Edit
            
            'check, maybe a manual payment is done, so don't over write it
            'If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) Then
                rst!Payment_Made_Cridi = rst!Loan_Cridi
                rst!sadad = rst!Loan_Cridi
                If rst!sadad.Value = True Then
                rst!wada3 = "تم التسديد"
                Else
                rst!wada3 = "لم يتم التسديد"
                End If
               TheSum = TheSum + Nz(rst!Payment_Made_Cridi, 0) + Nz(rst!Payment_Made_Elec, 0) + Nz(rst!Loan_Other, 0)

                'a1 = 1
            'End If
            
            'If Len(rst!Payment_Made_Elec & "") = 0 And Not IsNull(rst!Loan_Elec) Then
                'rst!Payment_Made_Elec = rst!Loan_Elec
                'a1 = 1
            'End If
            
        rst.Update
        
        rst.MoveNext
    Next i
    TheSum = Format(TheSum, "#,##0.00")
MsgBox "            " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات =  " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date)
Case vbNo
MsgBox "لم يتم توزيع الإقتطاعات "
End Select
'GoTo I_am_Done

    'Other loans for, March (3) and July (7)
    If Month(Now()) = 3 Or Month(Now()) = 7 Then
    
        Dim rstE As DAO.Recordset
        
        Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans")

        myCriteria = "[detach]='موظف'"
        'myCriteria = myCriteria & " Or [detach]='منتدب'"
        myCriteria = myCriteria & " Or [detach]='متعاقد كامل'"
        myCriteria = myCriteria & " Or [detach]='متعاقد جزئي'"
        myCriteria = myCriteria & " Or [detach]='عون نظافة'"
        
        Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria)
        rstE.MoveLast: rstE.MoveFirst
        RC = rstE.RecordCount
        
        For i = 1 To RC
        
            'check if payment is already entered, if it is, then skip this Record
            rst.FindFirst "[Loan_Type]='Other' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.TxtMonth & "#"
            
            If rst.NoMatch Then

            
              rst.AddNew
    
                a2 = 1
                rst!EmployeeID = rstE!EmployeeID
                rst!Loan_ID = 0
                'rst!Loan_AwardMonth = Me.AwardMonth
                rst!Payment_Month = DateSerial(Year(Me.TxtMonth), Month(Me.TxtMonth), 1)
                'rst!Loan_Cridi = Me.txtDiscountPerMonth
                'rst!Loan_Elec=         'to be used in Elec loan Form
                rst!Loan_Other = 1100      'to be used in Other loan Form
                'rst!Payment_Made =     'to be used each time a pyment is made
                rst!Loan_Type = "Other"
                rst!Remarks = "إقتطاع من الراتب لإشتراك شهر " & Year(Me.TxtMonth) & "/" & Month(Me.TxtMonth)
        
              rst.Update
            
            End If
            
            rstE.MoveNext
            
        Next i
        rstE.Close: Set rstE = Nothing
End If
    
I_am_Done:
    
    'clean up
    rst.Close: Set rst = Nothing

End If
    
Exit Sub
err_cmd_Pay_installments_Click:

    If Err.Number = 3021 Then
        'No Records, ignore
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
End Sub

 

تم تعديل أبريل 27, 2019 بواسطه كريمو2

[كريمو2]

ارفقت الملف للتوضيح أكثر

والتعديل عليه 

Ftransfer.mdb

 

[كريمو2]

تم الحل

 

Private Sub cmd_Pay_installments_Click()
On Error GoTo err_cmd_Pay_installments_Click

    Dim rst As DAO.Recordset
    
    'Cridi and Elec Payments
    Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans Where [Payment_Month]=CDATE('" & Me.TxtMonth & "')")
    rst.MoveLast: rst.MoveFirst
    Rc = rst.RecordCount
    a1 = 0  'just a flag
    a2 = 0  'jusf a flag
    If Rc = 0 Then: MsgBox " لا توجد إقتطاعات لشهر " & Format(Me.TxtMonth, "mmmm") & " " & Year(Me.TxtMonth), vbInformation: Exit Sub
    If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) _
    Or Len(rst!Payment_Made_Elec & "") = 0 And Not IsNull(rst!Loan_Elec) Then
    Select Case MsgBox(" هل تريد أن يتم توزيع الإقتطاعات لشهر  " & Me.TxtMonth, vbYesNo + vbQuestion + vbDefaultButton1)
    Case vbYes
    For i = 1 To Rc
      
        rst.Edit
            
            'check, maybe a manual payment is done, so don't over write it
            'If Len(rst!Payment_Made_Cridi & "") = 0 And Not IsNull(rst!Loan_Cridi) Then
                
                If rst!Loan_Type = "Cridi" Then rst!Payment_Made_Cridi = rst!Loan_Cridi: rst!sadad = rst!Loan_Cridi
                If rst!Loan_Type = "Elec" Then rst!Payment_Made_Elec = rst!Loan_Elec: rst!sadad = rst!Loan_Elec
                If rst!sadad.Value = True Then
                rst!wada3 = "تم التسديد"
                Else
                rst!wada3 = "لم يتم التسديد"
                End If
               TheSum = TheSum + Nz(rst!Payment_Made_Cridi, 0) + Nz(rst!Payment_Made_Elec, 0) + Nz(rst!Loan_Other, 0)

                 
        rst.Update
        
        rst.MoveNext
    Next i
    TheSum = Format(TheSum, "#,##0.00")
MsgBox "            " & "تم توزيع الإقتطاعات" & vbLf & vbLf & "مجموع الإقتطاعات =  " & TheSum, , "إقتطاعات شهر" & FrenchMonth(Month(Date)) & Year(Date)
Case vbNo
MsgBox "لم يتم توزيع الإقتطاعات"
End Select
'GoTo I_am_Done

    'Other loans for, March (3) and July (7)
    If Month(Now()) = 3 Or Month(Now()) = 7 Then
    
        Dim rstE As DAO.Recordset
        
        Set rst = CurrentDb.OpenRecordset("Select * From tbl_Loans")

        myCriteria = "[detach]='موظف'"
        'myCriteria = myCriteria & " Or [detach]='منتدب'"
        myCriteria = myCriteria & " Or [detach]='متعاقد كامل'"
        myCriteria = myCriteria & " Or [detach]='متعاقد جزئي'"
        myCriteria = myCriteria & " Or [detach]='عون نظافة'"
        
        Set rstE = CurrentDb.OpenRecordset("Select * From Employee Where " & myCriteria)
        rstE.MoveLast: rstE.MoveFirst
        Rc = rstE.RecordCount
        
        For i = 1 To Rc
        
            'check if payment is already entered, if it is, then skip this Record
            rst.FindFirst "[Loan_Type]='Other' And [EmployeeID]=" & rstE!EmployeeID & " And [Payment_Month]=#" & Me.TxtMonth & "#"
            
            If rst.NoMatch Then

            
              rst.AddNew
    
                a2 = 1
                rst!EmployeeID = rstE!EmployeeID
                rst!Loan_ID = 0
                'rst!Loan_AwardMonth = Me.AwardMonth
                rst!Payment_Month = DateSerial(Year(Me.TxtMonth), Month(Me.TxtMonth), 1)
                'rst!Loan_Cridi = Me.txtDiscountPerMonth
                'rst!Loan_Elec=         'to be used in Elec loan Form
                rst!Loan_Other = 1100      'to be used in Other loan Form
                'rst!Payment_Made =     'to be used each time a pyment is made
                rst!Loan_Type = "Other"
                rst!Remarks = "إقتطاع من الراتب لإشتراك شهر " & Year(Me.TxtMonth) & "/" & Month(Me.TxtMonth)
        
              rst.Update
            
            End If
            
            rstE.MoveNext
            
        Next i
        rstE.Close: Set rstE = Nothing
End If
    
I_am_Done:
    
    'clean up
    rst.Close: Set rst = Nothing

End If
    
Exit Sub
err_cmd_Pay_installments_Click:

    If Err.Number = 3021 Then
        'No Records, ignore
        Resume Next
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
End Sub

 

تم تعديل مايو 2, 2019 بواسطه كريمو2