Next Chapter 49 Profit And Loss Form

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