السلا م عليكم الرجاء المساعدة فى معرفه الخطا فى الكود

[Mohamed 188]

Option Compare Database

Public Room                 As Long
Public State                As FormState 'Variable used to determine on how the form used
Public PK                   As Long 'Variable used to get what record is going to edit
Public PopupPK              As String
Public AmountPaid           As Currency 'Amount paid from frmPayment
Public OtherCharges         As Currency
Public blnChangeRoom        As Boolean

Dim HaveAction              As Boolean 'Variable used to detect if the user perform some action
Dim RS                      As New ADODB.Recordset
Private Sub DisplayForEditing()
On Error GoTo err
    
    With RS
        txtFolioNumber.Value = .Fields("FolioNumber")
        txtRCardNo.Value = .Fields("RCardNo")
        txtLastName.Value = getValueAt("SELECT LastName FROM Customers WHERE CustomerID = " & RS.Fields("CustomerID"), "LastName")
        txtFirstName.Value = getValueAt("SELECT FirstName FROM Customers WHERE CustomerID = " & RS.Fields("CustomerID"), "FirstName")
        txtAddress.Value = .Fields("Address")
        dcCountry.Value = .Fields("CountryID")
        If RS.Fields("CompanyID") <> "" Then _
            txtCompany.Value = getValueAt("SELECT Company FROM Company WHERE CompanyID = " & RS.Fields("CompanyID"), "Company")
        dcIDType.Value = .Fields("IDTypeID")
        txtIDNumber.Value = .Fields("IDNumber")
        txtRoomNumber.Value = .Fields("RoomNumber")
        dtpDateIn.Value = .Fields("DateIn")
        If State = adStateAddMode Or State = adStateEditMode Then
            If .Fields("DateOut") >= Date Then
                dtpDateOut.Value = .Fields("DateOut")
            ElseIf .Fields("DateIn") = Date Then
                dtpDateOut.Value = dtpDateIn.Value + 1
            Else
                dtpDateOut.Value = Date
            End If
        Else
            dtpDateOut.Value = .Fields("DateOut")
        End If
        dcRateType.Value = .Fields("RateType")
        txtRate.Value = toMoney(.Fields("Rate"))
        txtOtherCharges.Value = toMoney(.Fields("OtherCharges"))
        txtDiscount.Value = .Fields("Discount")
        txtAmountPaid.Value = toMoney(.Fields("AmountPaid"))
        txtDays.Value = dtpDateOut.Value - dtpDateIn.Value '.Fields("Days")
        txtAdults.Value = .Fields("Adults")
        txtChildrens.Value = .Fields("Childrens")
        dcBusSource.Value = .Fields("BusinessSourceID")
        dcVehicle.Value = .Fields("VehicleID")
        txtVehicleModel.Value = .Fields("VehicleModel")
        txtPlateNo.Value = .Fields("PlateNo")
        txtNotes.Value = .Fields("Notes")
    End With
    
    hsDays.Value = txtDays.Text
    hsAdults.Value = txtAdults.Text
    hsChildrens.Value = txtChildrens.Text
    
    StatusBar1.Panels(2).Value = "Check In By: " & getValueAt("SELECT UserID FROM Users WHERE PK = " & RS.Fields("CheckInBy"), "UserID")
    StatusBar1.Panels(4).Value = "Business Source: " & dcBusSource.Text
    Exit Sub
err:
    If err.Number = 94 Then Resume Next
    
    prompt_err err, Name, "DisplayForEditing"
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdCancel_Click()
On Error GoTo err

    CurrentProject.Connection.BeginTrans
    
     CurrentProject.Connection.Execute "DELETE FolioNumber " & _
                "From [Rate Per Period] " & _
                "WHERE FolioNumber='" & txtFolioNumber.Text & "'"
                
     CurrentProject.Connection.Execute "INSERT INTO [Rate Per Period] " & _
                "SELECT [Rate Per Period Temp].* " & _
                "FROM [Rate Per Period Temp] " & _
                "Where ((([Rate Per Period Temp].FolioNumber) = '" & txtFolioNumber.Text & "')) " & _
                "ORDER BY [Rate Per Period Temp].Date;"

     CurrentProject.Connection.CommitTrans
    
   DoCmd.Close acForm, Me.Name
    
    Exit Sub
    
err:
     CurrentProject.Connection.RollbackTrans
    prompt_err err, Name, "CmdCancel_Click"
    Screen.MousePointer = vbDefault

End Sub

Private Sub cmdChangeRoom_Click()
On Error GoTo err

    Dim OldRoomNumber As Integer
    
    CN.BeginTrans
    
    With frmChangeRoom
        OldRoomNumber = txtRoomNumber.Text
        .txtFrom = OldRoomNumber
        
        .Show vbModal
    End With
    
    If blnChangeRoom = False Then Exit Sub
    
    ChangeValue CN, "Rooms", "RoomStatusID", 2, True, "WHERE RoomNumber = " & txtRoomNumber.Text
    ChangeValue CN, "Rooms", "RoomStatusID", 3, True, "WHERE RoomNumber = " & OldRoomNumber
    
    CN.Execute "UPDATE [Inventory] SET [Inventory].RoomNumber = " & txtRoomNumber.Text & " " & _
                "WHERE RoomNumber=" & OldRoomNumber & " AND ID='" & txtFolioNumber.Text & "' AND Status='Check In'"

    CN.CommitTrans

    Exit Sub
    
err:
    CN.RollbackTrans
    prompt_err err, Name, "CmdChangeRoom_Click"
    Screen.MousePointer = vbDefault
End Sub

Private Sub CmdCheckIn_Click()
Dim strCaption As String
    Dim RoomNumber As Integer
    
    strCaption = cmdCheckInOut.Caption
    RoomNumber = txtRoomNumber.Text
    
    Call SaveAdd

    If HaveAction = False Then
        Exit Sub
    End If
    
    If State = adStateAddMode Then
        MsgBox "New record has been successfully saved.", vbInformation

        Unload frmCheckIn
    Else
        MsgBox "Changes in  record has been successfully saved.", vbInformation
        
        Unload frmCheckIn
    End If

    If strCaption = "Check Out" Then
        With frmCheckOut
            .RoomNumber = RoomNumber
            .AutoCheckOut = False
            
            .Show vbModal
        End With
    End If
End Sub

Private Sub CmdPrint_Click()
If State = adStatePopupMode Then
        GoSub JumpHere
    End If
    
    If MsgBox("This will save the record before printing a folio. " & vbCrLf & vbCrLf & "Are you sure you want to continue?", vbYesNo + vbInformation) = vbYes Then
        Call SaveAdd
    Else
        Exit Sub
    End If

JumpHere:
    With frmReports
        .strReport = "Folio"
        
        If State = adStatePopupMode Then
            .strWhere = "{qry_RPT_Customers.FolioNumber} = '" & txtFolioNumber.Text & "' AND {qry_RPT_Customers.Status} = 'Check Out'"
        Else
            .strWhere = "{qry_RPT_Customers.FolioNumber} = '" & txtFolioNumber.Text & "' AND {qry_RPT_Customers.Status} = 'Check In'"
        End If

        frmReports.Show vbModal
    End With
End Sub

Private Sub cmdUpdateDelete_Click()
 If cmdUpdateDelete.Caption = "Update" Then
        Call SaveAdd
    
        If State = adStateAddMode Then
            MsgBox "New record has been successfully saved.", vbInformation
    
'            Unload frmCheckIn
        Else
            MsgBox "Changes in  record has been successfully saved.", vbInformation
            
'            Unload frmCheckIn
        End If
    End If
End Sub

Private Sub Command84_Click()
 If txtDays.Value = 1 Then
        Exit Sub
    Else
         txtDays.Value = txtDays.Value - 1
    End If
End Sub

Private Sub Command85_Click()
txtDays.Value = txtDays.Value + 1
End Sub

Private Sub Command86_Click()
 If txtDays.Value = 1 Then
        Exit Sub
    Else
         txtDays.Value = txtDays.Value - 1
    End If
End Sub

Private Sub Command87_Click()
txtDays.Value = txtDays.Value + 1
End Sub

Private Sub Command82_Click()
On Error GoTo Err_Command82_Click

    If txtDays.Value = 1 Then
        Exit Sub
    Else
         txtDays.Value = txtDays.Value - 1
    End If

Exit_Command82_Click:
    Exit Sub

Err_Command82_Click:
    MsgBox err.Description
    Resume Exit_Command82_Click
    
End Sub
Private Sub Command83_Click()
On Error GoTo Err_Command83_Click

    txtDays.Value = txtDays.Value + 1
    
Exit_Command83_Click:
    Exit Sub

Err_Command83_Click:
    MsgBox err.Description
    Resume Exit_Command83_Click
    
End Sub

Private Sub Form_Load()

End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    lblAmountPaid.FontUnderline = False
    lblRatePerPeriod.FontUnderline = False
    lblOtherCharges.FontUnderline = False
End Sub
Private Sub SaveAdd()
On Error GoTo err
    
    Dim rsCustomers As New Recordset
    Dim CustomerID As Integer
    Dim CompanyID As Integer
    
    If Trim(txtLastName.Text) = "" Or Trim(txtFirstName.Text) = "" Then
        MsgBox "Please complete the name of a guest.", vbInformation
        
        Exit Sub
    End If
    
    CN.BeginTrans

    'Save customer's record
    With rsCustomers
        .Open "SELECT * FROM Customers WHERE LastName = '" & txtLastName.Text & "' AND FirstName = '" & txtFirstName.Text & "'", CN, adOpenStatic, adLockOptimistic
    
        If .RecordCount > 0 Then
            txtLastName.Tag = .Fields("CustomerID")
        Else
            .AddNew
            
            CustomerID = getIndex("Customers")
            txtLastName.Tag = CustomerID
            
            .Fields("CustomerID") = CustomerID
            .Fields("LastName") = txtLastName.Text
            .Fields("FirstName") = txtFirstName.Text
            
            .Update
        End If
        
        .Close
        
        If txtCompany.Text = "" Then GoSub ContinueSave
        
        'Save company's record
        .Open "SELECT * FROM Company WHERE Company = '" & txtCompany.Text & "'", CN, adOpenStatic, adLockOptimistic
        
        If .RecordCount > 0 Then
            txtCompany.Tag = .Fields("CompanyID")
        Else
            .AddNew

            CompanyID = getIndex("Company")
            txtCompany.Tag = CompanyID
            
            .Fields("CompanyID") = CompanyID
            .Fields("Company") = txtCompany.Text
            
            .Update
        End If
        
        .Close
    End With
    
ContinueSave:

    If State = adStateAddMode Then
        RS.AddNew
        
        RS.Fields("FolioNumber") = txtFolioNumber.Text
        RS.Fields("CheckInBy") = CurrUser.USER_PK
        RS.Fields("AddedByFK") = CurrUser.USER_PK
    Else
        RS.Fields("DateModified") = Now
        RS.Fields("LastUserFK") = CurrUser.USER_PK
    End If
    
    With RS
        .Fields("RCardNo") = txtRCardNo.Text
        .Fields("CustomerID") = txtLastName.Tag
        .Fields("Address") = txtAddress.Text
        .Fields("CountryID") = dcCountry.BoundText
        .Fields("CompanyID") = IIf(txtCompany.Tag = "", Null, txtCompany.Tag)
        .Fields("IDTypeID") = dcIDType.BoundText
        .Fields("IDNumber") = txtIDNumber.Text
        .Fields("RoomNumber") = txtRoomNumber.Text
        .Fields("DateIn") = dtpDateIn.Value
        .Fields("DateOut") = dtpDateOut.Value
        .Fields("RateType") = dcRateType.BoundText
        .Fields("Rate") = txtRate.Text
        .Fields("OtherCharges") = txtOtherCharges.Text
        .Fields("Discount") = txtDiscount.Text
        .Fields("AmountPaid") = txtAmountPaid.Text
        .Fields("Days") = txtDays.Text
        .Fields("Adults") = txtAdults.Text
        .Fields("Childrens") = txtChildrens.Text
        .Fields("Total") = txtTotal.Text
        .Fields("BusinessSourceID") = dcBusSource.BoundText
        .Fields("VehicleID") = IIf(dcVehicle.BoundText = "", Null, dcVehicle.BoundText)
        .Fields("VehicleModel") = txtVehicleModel.Text
        .Fields("PlateNo") = txtPlateNo.Text
        .Fields("Notes") = txtNotes.Text

        .Update
    End With
    
    '----------------------------
    'Delete record from Inventory and add a new check in/out date
    CN.Execute "DELETE ID, Status " & _
                "From [Inventory] " & _
                "WHERE ID='" & txtFolioNumber.Text & "' AND Status='Check In'"
                
    Dim dtpStartDate As Date
    
    dtpStartDate = dtpDateIn.Value
    
    Do Until dtpStartDate = dtpDateOut.Value
        CN.Execute "INSERT INTO [Inventory] ( ID, RoomNumber, [Date], CustomerID, Status ) " & _
                "VALUES ('" & txtFolioNumber.Text & "', " & txtRoomNumber.Text & ", #" & dtpStartDate & "#, " & txtLastName.Tag & ", 'Check In')"

        dtpStartDate = dtpStartDate + 1
    Loop
    '----------------------------
    
    ChangeValue CN, "Rooms", "RoomStatusID", 2, True, "WHERE RoomNumber = " & txtRoomNumber.Text
    
    Call frmPayment.cmdSave_Click
    Call frmOtherCharges.cmdSave_Click
    
    If txtCompany.Text <> "" Then
        Dim rsAccRec As New Recordset
        
        With rsAccRec
            .Open "SELECT * FROM [Accounts Receivable] WHERE CompanyID = " & txtCompany.Tag & " AND FolioNumber = '" & txtFolioNumber & "'", CN, adOpenStatic, adLockOptimistic
            
            If .RecordCount > 0 Then
                .Fields("Debit") = txtBalance.Text
            Else
                .AddNew
                
                .Fields("CompanyID") = txtCompany.Tag
                .Fields("FolioNumber") = txtFolioNumber.Text
                .Fields("Credit") = txtBalance.Text
            End If
            
            .Update
        End With
    ElseIf State = adStateEditMode Then
        'delete record from accounts receivable table since the company field becomes blank.
        
        CN.Execute "DELETE [Accounts Receivable].FolioNumber " & _
                    "From [Accounts Receivable] " & _
                    "WHERE FolioNumber= '" & txtFolioNumber.Text & "'"
    End If
    
    CN.CommitTrans

    HaveAction = True
    
    Exit Sub

err:
    CN.RollbackTrans
    prompt_err err, Name, "cmdSave_Click"
    Screen.MousePointer = vbDefault
End Sub

Private Sub cmdLookupComp_Click()
    With frmCompanyLookup
        Set .RefForm = Me
        
        .Show vbModal
    End With
End Sub

Private Sub cmdLookupCust_Click()
    With frmCustomerLookup
        Set .RefForm = Me
        
        .Show vbModal
    End With
End Sub

 

[محمد أبوعبدالله]

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

اقتباس

 

الرجاء المساعدة فى معرفه الخطا فى الكود

 

ارفق مثال بارك الله فيك

فلن تجد من يصمم قاعدة البيانات باسماء الجداول والحقول ليمتشف في النهاية اين الخطأ ؟

تحياتي

[Mohamed 188]

السلام عليكم أ / محمد 

شكرا لحضرتك 

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

ورينا يجعلوا فى ميزان حسناتك 

 

 

 

•  
•  

New Microsoft Access Database.rar