Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
PROJECT SOURCE CODE
SPONSORED LINKS
Profit And Loss Form
'******************************************************************
'******************************************************************
'** Author : Samee Ullah Siddiqui
'** E-Mail : sanjaykrsxena@hotmail.com
'** Subject : Creating Profit & Loss
'** Date : Saturday, December, 20, 2003
'** Modified : Tuesday, December, 23, 2003
'******************************************************************
'******************************************************************
Dim TerminateLoop As Boolean
Dim Bmark As Variant
Private Sub CancelCmd_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dt.Value = Date
End Sub
Private Sub OKCmd_Click()
On Error GoTo ErHand
Dim i As Long
If OKCmd.Caption = "&OK" Then
If Dt.Value = "" Or (Not IsDate(Dt.Value)) Then
Unload Me
Exit Sub
End If
Dim SQL As String
If DE.PLConn.State = adStateOpen Then DE.PLConn.Close
DE.PLConn.Open ConnectString
If PLChk.Value = vbChecked Then
If Not PrepairPL(Dt.Value, DE.PLConn) Then
OKCmd.Caption = "&OK"
CancelCmd.Enabled = True
Screen.MousePointer = vbDefault
PB.Visible = False
StcLbl.Caption = ""
TerminateLoop = False
Exit Sub
End If
End If
StcLbl.Caption = "Preparing Trading Account..."
DE.PLConn.BeginTrans
'Delete Old Records from Credit Table
DE.PLConn.Execute "DELETE FROM CrPL_TEMP", , adCmdText
'Insert New Records
SQL = "INSERT INTO CrPL_TEMP SELECT ACCOUNTS.ACCODE, ACCOUNTS.ACDESC, ACCOUNTS.GRCODE, ACCOUNTS.GROUPDESC, ACCOUNTS.RECTYPE, ACCOUNTS.CASH, ACCOUNTS.ACTYPE, AcTrans.BALANCE " & _
"FROM AcTrans INNER JOIN ACCOUNTS ON AcTrans.Accode = ACCOUNTS.ACCODE WHERE RECTYPE = 'A' AND (ACTYPE ='P') AND (BALANCE < 0) ORDER BY ACCOUNTS.GRCODE, ACCOUNTS.ACDESC"
DE.PLConn.Execute SQL, i, adCmdText
Call FetchRecords("CrPL_TEMP", DE.PLConn, True)
'Delete Old Records from Debit Table
DE.PLConn.Execute "DELETE FROM DrPL_TEMP", , adCmdText
SQL = "INSERT INTO DrPL_TEMP SELECT ACCOUNTS.ACCODE, ACCOUNTS.ACDESC, ACCOUNTS.GRCODE, ACCOUNTS.GROUPDESC, ACCOUNTS.RECTYPE, ACCOUNTS.CASH, ACCOUNTS.ACTYPE, AcTrans.BALANCE " & _
"FROM AcTrans INNER JOIN ACCOUNTS ON AcTrans.Accode = ACCOUNTS.ACCODE WHERE RECTYPE = 'A' AND (ACTYPE ='P') AND (BALANCE > 0) ORDER BY ACCOUNTS.GRCODE, ACCOUNTS.ACDESC"
DE.PLConn.Execute SQL, i, adCmdText
Call FetchRecords("DrPL_TEMP", DE.PLConn, True)
'Open Temporary Table
Dim TmpRst As New ADODB.Recordset
TmpRst.CursorLocation = adUseClient
DE.PLConn.Execute "DELETE FROM PL_TEMP"
TmpRst.Open "PL_TEMP", DE.PLConn, adOpenKeyset, adLockOptimistic, adCmdTable
Dim DrRSt As New ADODB.Recordset
DrRSt.CursorLocation = adUseClient
DrRSt.Open "DrPL_TEMP", DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdTable
Do Until DrRSt.EOF Or TerminateLoop
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!RTYPE = "T" 'Trading Records
TmpRst!DRGroupCode = DrRSt!GrCode
TmpRst!DRGroupDESC = DrRSt!GROUPDESC
TmpRst!DRCode = DrRSt!AcCode
TmpRst!DRDESC = DrRSt!AcDESC
TmpRst!DrAmt = Abs(DrRSt!BALANCE)
TmpRst.Update
DrRSt.MoveNext
Loop
Dim CrRSt As New ADODB.Recordset
CrRSt.CursorLocation = adUseClient
CrRSt.Open "CrPL_TEMP", DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdTable
If TmpRst.RecordCount > 0 Then TmpRst.MoveFirst
Do Until CrRSt.EOF Or TerminateLoop
RedoDr:
If TmpRst.EOF Then
TmpRst.AddNew
TmpRst!sno = TmpRst.AbsolutePosition
TmpRst!RTYPE = "T" 'Trading Records
ElseIf Not IsNull(TmpRst!CRDESC) Then
TmpRst.MoveNext
GoTo RedoDr
End If
TmpRst!CRGroupCode = CrRSt!GrCode
TmpRst!CRGroupDESC = CrRSt!GROUPDESC
TmpRst!CRCode = CrRSt!AcCode
TmpRst!CRDESC = CrRSt!AcDESC
TmpRst!CrAmt = Abs(CrRSt!BALANCE)
TmpRst.Update
If Not TmpRst.EOF Then TmpRst.MoveNext
CrRSt.MoveNext
Loop
Dim TotalRst As New ADODB.Recordset
TotalRst.CursorLocation = adUseClient
Dim Diff, CrTotal, DrTotal, GTotal As Double
SQL = "SELECT SUM(CrAmt) AS CRAmount, SUM(DrAmt) AS DRAmount FROM PL_TEMP WHERE RTYPE = 'T'"
TotalRst.Open SQL, DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdText
CrTotal = IIf(IsNull(TotalRst!CRAmount), 0, TotalRst!CRAmount)
DrTotal = IIf(IsNull(TotalRst!DRAmount), 0, TotalRst!DRAmount)
Diff = Abs(CrTotal - DrTotal)
If Diff <> 0 Then
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
If CrTotal < DrTotal Then
TmpRst!CRDESC = "Gross Loss"
TmpRst!CrAmt = Diff
GTotal = DrTotal
ElseIf DrTotal < CrTotal Then
TmpRst!DRDESC = "Gross Profit"
TmpRst!DrAmt = Diff
GTotal = CrTotal
End If
TmpRst.Update
Else
GTotal = CrTotal 'Becoz CrTotal=DrTotal
End If
'Add Line
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CRLINE = VBA.String(20, "=")
TmpRst!DRLINE = VBA.String(20, "=")
TmpRst.Update
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CrAmt = GTotal
TmpRst!DrAmt = GTotal
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CRLINE = VBA.String(20, "=")
TmpRst!DRLINE = VBA.String(20, "=")
'Add a blank row after Trading Account
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst.Update
'Preparing Profit & Loss
'=========================
'Delete Old Records from Credit Table
DE.PLConn.Execute "DELETE FROM CrPL_TEMP", , adCmdText
'Insert New Records
SQL = "INSERT INTO CrPL_TEMP SELECT ACCOUNTS.ACCODE, ACCOUNTS.ACDESC, ACCOUNTS.GRCODE, ACCOUNTS.GROUPDESC, ACCOUNTS.RECTYPE, ACCOUNTS.CASH, ACCOUNTS.ACTYPE, AcTrans.BALANCE " & _
"FROM AcTrans INNER JOIN ACCOUNTS ON AcTrans.Accode = ACCOUNTS.ACCODE WHERE RECTYPE = 'A' AND (ACTYPE ='P') AND (BALANCE < 0) ORDER BY ACCOUNTS.GRCODE, ACCOUNTS.ACDESC"
DE.PLConn.Execute SQL, i, adCmdText
Call FetchRecords("CrPL_TEMP", DE.PLConn, False)
'Delete Old Records from Debit Table
DE.PLConn.Execute "DELETE FROM DrPL_TEMP", , adCmdText
SQL = "INSERT INTO DrPL_TEMP SELECT ACCOUNTS.ACCODE, ACCOUNTS.ACDESC, ACCOUNTS.GRCODE, ACCOUNTS.GROUPDESC, ACCOUNTS.RECTYPE, ACCOUNTS.CASH, ACCOUNTS.ACTYPE, AcTrans.BALANCE " & _
"FROM AcTrans INNER JOIN ACCOUNTS ON AcTrans.Accode = ACCOUNTS.ACCODE WHERE RECTYPE = 'A' AND (ACTYPE ='P') AND (BALANCE > 0) ORDER BY ACCOUNTS.GRCODE, ACCOUNTS.ACDESC"
DE.PLConn.Execute SQL, i, adCmdText
Call FetchRecords("DrPL_TEMP", DE.PLConn, False)
'Open Temporary Table
If DrRSt.State = adStateOpen Then DrRSt.Close
DrRSt.Open "DrPL_TEMP", DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdTable
'Insert one entry of difference
If Diff <> 0 Then
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!RTYPE = "P"
If CrTotal < DrTotal Then
TmpRst!DRDESC = "Gross Loss"
TmpRst!DrAmt = Diff
ElseIf DrTotal < CrTotal Then
TmpRst!CRDESC = "Gross Profit"
TmpRst!CrAmt = Diff
End If
TmpRst.Update
'Save then position of first record of Profit and Loss
Bmark = TmpRst.Bookmark
End If
Do Until DrRSt.EOF Or TerminateLoop
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!RTYPE = "P" 'Profit & Loss
TmpRst!DRGroupCode = DrRSt!GrCode
TmpRst!DRGroupDESC = DrRSt!GROUPDESC
TmpRst!DRCode = DrRSt!AcCode
TmpRst!DRDESC = DrRSt!AcDESC
TmpRst!DrAmt = Abs(DrRSt!BALANCE)
TmpRst.Update
If DrRSt.AbsolutePosition = 1 Then 'Save then position of first record of Profit and Loss
If IsEmpty(Bmark) Then Bmark = TmpRst.Bookmark
End If
DrRSt.MoveNext
Loop
If CrRSt.State = adStateOpen Then CrRSt.Close
CrRSt.Open "CrPL_TEMP", DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdTable
If Not IsEmpty(Bmark) Then TmpRst.Bookmark = Bmark 'Set position of first record of Profit and Loss
Do Until CrRSt.EOF Or TerminateLoop
RedoCr:
If TmpRst.EOF Then
TmpRst.AddNew
TmpRst!sno = TmpRst.AbsolutePosition
TmpRst!RTYPE = "P" 'Trading Records
ElseIf Not IsNull(TmpRst!CRDESC) Then
TmpRst.MoveNext
GoTo RedoCr
End If
TmpRst!CRGroupCode = CrRSt!GrCode
TmpRst!CRGroupDESC = CrRSt!GROUPDESC
TmpRst!CRCode = CrRSt!AcCode
TmpRst!CRDESC = CrRSt!AcDESC
TmpRst!CrAmt = Abs(CrRSt!BALANCE)
TmpRst.Update
If Not TmpRst.EOF Then TmpRst.MoveNext
CrRSt.MoveNext
Loop
'Get Total of Profit and Loss Records
SQL = "SELECT SUM(CrAmt) AS CRAmount, SUM(DrAmt) AS DRAmount FROM PL_TEMP WHERE RTYPE = 'P'"
If TotalRst.State = adStateOpen Then TotalRst.Close
TotalRst.Open SQL, DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdText
CrTotal = IIf(IsNull(TotalRst!CRAmount), 0, TotalRst!CRAmount)
DrTotal = IIf(IsNull(TotalRst!DRAmount), 0, TotalRst!DRAmount)
Diff = Abs(CrTotal - DrTotal)
If Diff <> 0 Then
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
If CrTotal < DrTotal Then
TmpRst!CRDESC = "Net Loss C/F to Balance Sheet"
TmpRst!CrAmt = Diff
GTotal = DrTotal
ElseIf DrTotal < CrTotal Then
TmpRst!DRDESC = "Net Profit C/F to Balance Sheet"
TmpRst!DrAmt = Diff
GTotal = CrTotal
End If
TmpRst.Update
Else
GTotal = CrTotal 'Becoz CrTotal=DrTotal
End If
'Add Line
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CRLINE = VBA.String(20, "=")
TmpRst!DRLINE = VBA.String(20, "=")
TmpRst.Update
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CrAmt = GTotal
TmpRst!DrAmt = GTotal
TmpRst!CRDESC = "TOTAL"
TmpRst!DRDESC = "TOTAL"
TmpRst.AddNew
TmpRst!sno = TmpRst.RecordCount
TmpRst!CRLINE = VBA.String(20, "=")
TmpRst!DRLINE = VBA.String(20, "=")
TmpRst.Update
OKCmd.Caption = "&OK"
CancelCmd.Enabled = True
Screen.MousePointer = vbDefault
PB.Visible = False
StcLbl.Caption = ""
DE.PLConn.CommitTrans
If DE.rsPLCmd.State = adStateOpen Then DE.rsPLCmd.Close
DE.rsPLCmd.Open "PL_TEMP", DE.PLConn, adOpenForwardOnly, adLockReadOnly, adCmdTable
Set PLRpt.DataSource = DE
PLRpt.Title = "PROFIT & LOSS as on " & Format(Dt.Value, "dd/mm/yyyy")
If Option1(0).Value Then
PLRpt.Show
Else
PLRpt.PrintReport
End If
Else
TerminateLoop = True
End If
ErHand:
ErrHandler "PLFrm.OKCmd_Click"
End Sub
Private Function PrepairPL(ByVal PLDate As Date, ByVal Conn As ADODB.Connection) As Boolean
Dim SQL, mAccode As String
Dim i As Integer
Dim ACRst As New ADODB.Recordset
ACRst.CursorLocation = adUseClient
SQL = "Select * From ACMAST ORDER BY ACCODE"
ACRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If Not (ACRst.RecordCount > 0) Then
MsgBox "ACMAST Table having no records.", vbCritical, "Table blank"
Exit Function
End If
Dim vRst As New ADODB.Recordset
vRst.CursorLocation = adUseClient
SQL = "Select * From VOUCHER WHERE VDATE <= '" & PLDate & "'"
vRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If Not (vRst.RecordCount > 0) Then
MsgBox "There is no transaction up to specified date.", vbCritical, "No Transaction"
Dt.SetFocus
Exit Function
End If
Dim AcTransRst As New ADODB.Recordset
' AcTransRst.CursorLocation = adUseServer
SQL = "Select * From AcTrans ORDER BY ACCODE"
AcTransRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If AcTransRst.EOF Then
MsgBox "AcTrans Table having no records.", vbCritical, "Table blank"
Dt.SetFocus
Exit Function
End If
SQL = "UPDATE ACTRANS SET BALANCE = 0"
Conn.Execute SQL, i, adCmdText
Screen.MousePointer = vbHourglass
OKCmd.Caption = "&Abort"
CancelCmd.Enabled = False
PB.Visible = True
PB.Max = vRst.RecordCount
StcLbl.Caption = "Processing Data..."
Do Until vRst.EOF
mAccode = vRst!AcCode
Do
AcTransRst.MoveFirst
AcTransRst.Find "ACCODE = '" & mAccode & "'"
If AcTransRst.EOF Then
MsgBox "Account Code [" & mAccode & "] is not found in ACTrans Table.", vbCritical, "Record not found"
Exit Function
Else
SQL = "UPDATE ACTRANS SET BALANCE = (BALANCE + " & IIf(vRst!DrCr = "D", vRst!DrAmt, -vRst!CrAmt) & ") Where ACCODE = '" & mAccode & "'"
SQL = VBA.Replace(SQL, "--", "+")
Conn.Execute SQL, i, adCmdText
If i = 0 Then MsgBox "Posting Amount for Accound Code [" & mAccode & "] could not update in ACTRANS Table", vbCritical, "Unsuccessfull Updatation"
i = 0
End If
ACRst.MoveFirst
ACRst.Find "ACCODE = '" & mAccode & "'"
If ACRst.EOF Then
MsgBox "Account Code [" & mAccode & "] is not found in ACMAST Table.", vbCritical, "Record not found"
Exit Function
Else
If IsNull(ACRst!GrCode) Or ACRst!GrCode = "" Then
Exit Do
Else
mAccode = ACRst!GrCode
End If
End If
DoEvents
If TerminateLoop Then Exit Function
Loop
PB.Value = vRst.AbsolutePosition
vRst.MoveNext
Loop
PB.Visible = False
Screen.MousePointer = vbDefault
StcLbl.Caption = ""
PrepairPL = True
End Function
Private Function FetchRecords(ByVal tbl As String, Conn As ADODB.Connection, ByVal TradingAccount As Boolean)
Dim SQL, mAccode As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
Dim ACRst As New ADODB.Recordset
ACRst.CursorLocation = adUseClient
ACRst.Open "ACMAST", Conn, adOpenKeyset, adLockReadOnly, adCmdTable
SQL = "SELECT * FROM " & tbl
rst.Open SQL, Conn, adOpenForwardOnly, adLockOptimistic, adCmdText
Do Until rst.EOF
If TradingAccount Then
If (rst!GrCode = "000022" Or rst!GrCode = "000024") Then
rst.MoveNext
ElseIf IsNull(rst!GrCode) Or rst!GrCode = "" Then
rst.Delete 'Delete TopMost Parent
rst.MoveNext
Else
mAccode = rst!GrCode
Do
ACRst.MoveFirst
ACRst.Find "ACCODE = '" & mAccode & "'"
If ACRst.EOF Then
MsgBox "Account Code [" & mAccode & "] is not found in ACMAST Table.", vbCritical, "Record not found"
Exit Function
Else
If (ACRst!GrCode = "000022" Or ACRst!GrCode = "000024") Then
rst.MoveNext
Exit Do
ElseIf IsNull(ACRst!GrCode) Or ACRst!GrCode = "" Then
rst.Delete 'Delete TopMost Parent
rst.MoveNext
Exit Do
Else
mAccode = ACRst!GrCode
End If
End If
Loop
End If
Else 'Profit & Loss
If (rst!GrCode = "000022" Or rst!GrCode = "000024") Then
rst.Delete 'Delete Trading Accounts
rst.MoveNext
ElseIf Not (rst!GrCode = "000022" Or rst!GrCode = "000024") Then
rst.MoveNext
ElseIf IsNull(rst!GrCode) Or rst!GrCode = "" Then
rst.Delete 'Delete TopMost Parent
rst.MoveNext
Else
mAccode = rst!GrCode
Do
ACRst.MoveFirst
ACRst.Find "ACCODE = '" & mAccode & "'"
If ACRst.EOF Then
MsgBox "Account Code [" & mAccode & "] is not found in ACMAST Table.", vbCritical, "Record not found"
Exit Function
Else
If Not (ACRst!GrCode = "000022" Or ACRst!GrCode = "000024") Then
rst.MoveNext
Exit Do
ElseIf IsNull(ACRst!GrCode) Or ACRst!GrCode = "" Then
rst.Delete 'Delete TopMost Parent
rst.MoveNext
Exit Do
Else
mAccode = ACRst!GrCode
End If
End If
Loop
End If
End If
Loop
End Function
Next Chapter 50 Purchase Register
Sponsored Links