Next Chapter 28 Balance Sheet

Balance Sheet

'******************************************************************

'******************************************************************

'** Author : Samee Ullah Siddiqui

'** Subject : Creating Balance Sheet

'** Date : Saturday, December, 13, 2003

'** Modified : Monday, December, 15, 2003

'******************************************************************

'******************************************************************

Dim TerminateLoop As Boolean

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

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.BSheetConn.State = adStateOpen Then DE.BSheetConn.Close

DE.BSheetConn.Open ConnectString

If BSheetChk.Value = vbChecked Then

If Not PrepairBSheet(Dt.Value, DE.BSheetConn) Then

OKCmd.Caption = "&OK"

CancelCmd.Enabled = True

Screen.MousePointer = vbDefault

PB.Visible = False

StcLbl.Caption = ""

TerminateLoop = False

Exit Sub

End If

End If

DE.BSheetConn.BeginTrans

Dim CrRSt As New ADODB.Recordset

CrRSt.CursorLocation = adUseClient

Dim DrRSt As New ADODB.Recordset

DrRSt.CursorLocation = adUseClient

SQL = "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"

CrRSt.Open SQL, DE.BSheetConn, adOpenForwardOnly, adLockReadOnly, adCmdText

SQL = "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"

DrRSt.Open SQL, DE.BSheetConn, adOpenForwardOnly, adLockReadOnly, adCmdText

Dim TmpRst As New ADODB.Recordset

TmpRst.CursorLocation = adUseClient

DE.BSheetConn.Execute "DELETE FROM BSHEET_TEMP"

TmpRst.Open "BSHEET_TEMP", DE.BSheetConn, adOpenKeyset, adLockOptimistic, adCmdTable

Dim i As Long

i = CrRSt.RecordCount

If DrRSt.RecordCount > i Then i = DrRSt.RecordCount

OKCmd.Caption = "&Abort"

CancelCmd.Enabled = False

TerminateLoop = False

Screen.MousePointer = vbHourglass

PB.Visible = True

StcLbl.Caption = "Prepairing Balance Sheet..."

PB.Max = i

i = 0

Dim vCrDesc, vDrDesc As String

vCrDesc = IIf(CrRSt.AbsolutePosition > 0, CrRSt!GROUPDESC, "")

vDrDesc = IIf(DrRSt.AbsolutePosition > 0, DrRSt!GROUPDESC, "")

TmpRst.AddNew

If CrRSt.AbsolutePosition > 0 Then

TmpRst!CRGroupCode = CrRSt!GrCode

TmpRst!CRGroupDESC = CrRSt!GROUPDESC

TmpRst!CRDESC = CrRSt!GROUPDESC

End If

If DrRSt.AbsolutePosition > 0 Then

TmpRst!DRGroupCode = DrRSt!GrCode

TmpRst!DRGroupDESC = DrRSt!GROUPDESC

TmpRst!DRDESC = DrRSt!GROUPDESC

End If

TmpRst.Update

Do Until CrRSt.EOF

TmpRst.AddNew

TmpRst!sno = TmpRst.RecordCount

If Not CrRSt.EOF Then

If vCrDesc = CrRSt!GROUPDESC Then

TmpRst!CRGroupCode = CrRSt!GrCode

TmpRst!CRGroupDESC = CrRSt!GROUPDESC

TmpRst!CRCode = CrRSt!AcCode

TmpRst!CRDESC = VBA.String(5, " ") & CrRSt!AcDESC

TmpRst!CrAmt = Abs(CrRSt!BALANCE)

Else

TmpRst!CRGroupCode = CrRSt!GrCode

TmpRst!CRGroupDESC = CrRSt!GROUPDESC

TmpRst!CRDESC = CrRSt!GROUPDESC

vCrDesc = CrRSt!GROUPDESC

TmpRst.AddNew

TmpRst!CRGroupCode = CrRSt!GrCode

TmpRst!CRGroupDESC = CrRSt!GROUPDESC

TmpRst!CRCode = CrRSt!AcCode

TmpRst!CRDESC = VBA.String(5, " ") & CrRSt!AcDESC

TmpRst!CrAmt = Abs(CrRSt!BALANCE)

End If

End If

TmpRst.Update

PB.Value = i

i = i + 1

If TerminateLoop Then

OKCmd.Caption = "&OK"

CancelCmd.Enabled = True

Screen.MousePointer = vbDefault

PB.Visible = False

StcLbl.Caption = ""

DE.BSheetConn.RollbackTrans

Exit Sub

End If

If Not CrRSt.EOF Then CrRSt.MoveNext

Loop

i = 0

If TmpRst.RecordCount > 0 Then TmpRst.MoveFirst

Do Until DrRSt.EOF

If Not DrRSt.EOF Then

If TmpRst.EOF Then

TmpRst.AddNew

TmpRst!sno = DrRSt.AbsolutePosition

End If

If Not IsNull(TmpRst!DRDESC) Then TmpRst.MoveNext

If IsNull(TmpRst!sno) Then TmpRst!sno = DrRSt.AbsolutePosition

If vDrDesc = DrRSt!GROUPDESC Then

TmpRst!DRGroupCode = DrRSt!GrCode

TmpRst!DRGroupDESC = DrRSt!GROUPDESC

TmpRst!DRCode = DrRSt!AcCode

TmpRst!DRDESC = VBA.String(5, " ") & DrRSt!AcDESC

TmpRst!DrAmt = Abs(DrRSt!BALANCE)

Else

TmpRst!DRGroupCode = DrRSt!GrCode

TmpRst!DRGroupDESC = DrRSt!GROUPDESC

TmpRst!DRDESC = DrRSt!GROUPDESC

vDrDesc = DrRSt!GROUPDESC

If Not TmpRst.EOF Then TmpRst.MoveNext

If TmpRst.EOF Then

TmpRst.AddNew

TmpRst!sno = DrRSt.AbsolutePosition

ElseIf Not IsNull(TmpRst!DRDESC) Then

TmpRst.AddNew

TmpRst!sno = DrRSt.AbsolutePosition

End If

TmpRst!DRGroupCode = DrRSt!GrCode

TmpRst!DRGroupDESC = DrRSt!GROUPDESC

TmpRst!DRCode = DrRSt!AcCode

TmpRst!DRDESC = VBA.String(5, " ") & DrRSt!AcDESC

TmpRst!DrAmt = Abs(DrRSt!BALANCE)

End If

End If

TmpRst.Update

If Not TmpRst.EOF Then TmpRst.MoveNext

If TerminateLoop Then

OKCmd.Caption = "&OK"

CancelCmd.Enabled = True

Screen.MousePointer = vbDefault

PB.Visible = False

StcLbl.Caption = ""

DE.BSheetConn.RollbackTrans

Exit Sub

End If

If Not DrRSt.EOF Then DrRSt.MoveNext

Loop

Screen.MousePointer = vbDefault

PB.Visible = False

StcLbl.Caption = ""

OKCmd.Caption = "&OK"

CancelCmd.Enabled = True

DE.BSheetConn.CommitTrans

Dim TotalRst As New ADODB.Recordset

TotalRst.CursorLocation = adUseClient

Dim Diff, CrTotal, DrTotal As Double

SQL = "SELECT SUM(CrAmt) AS CRAmount, SUM(DrAmt) AS DRAmount FROM BSHEET_TEMP"

TotalRst.Open SQL, DE.BSheetConn, adOpenForwardOnly, adLockReadOnly, adCmdText

CrTotal = IIf(IsNull(TotalRst!CRAmount), 0, TotalRst!CRAmount)

DrTotal = IIf(IsNull(TotalRst!DRAmount), 0, TotalRst!DRAmount)

Diff = Abs(CrTotal - DrTotal)

Set BSheetRpt.DataSource = DE

With BSheetRpt

.Title = "BALANCE SHEET as on " & Format(Dt.Value, "dd/mm/yyyy")

If CrTotal < DrTotal Then

.Sections("ReportFooter").Controls("DiffCrLbl").Caption = Format(Diff, "0.00")

.Sections("ReportFooter").Controls("LiblLbl").Visible = True

ElseIf DrTotal < CrTotal Then

.Sections("ReportFooter").Controls("DiffDrLbl").Caption = Format(Diff, "0.00")

.Sections("ReportFooter").Controls("AssetLBL").Visible = True

Else

.Sections("ReportFooter").Controls("DiffDrLbl").Caption = ""

.Sections("ReportFooter").Controls("DiffCrLbl").Caption = ""

.Sections("ReportFooter").Controls("LiblLbl").Visible = False

.Sections("ReportFooter").Controls("AssetLBL").Visible = False

End If

.Sections("ReportFooter").Controls("CrLbl").Caption = Format(Val(.Sections("ReportFooter").Controls("DiffCrLbl").Caption) + CrTotal, "0.00")

.Sections("ReportFooter").Controls("DrLbl").Caption = Format(Val(.Sections("ReportFooter").Controls("DiffDrLbl").Caption) + DrTotal, "0.00")

End With

If DE.rsBSheetCmd.State = adStateOpen Then DE.rsBSheetCmd.Close

DE.rsBSheetCmd.Open "BSHEET_TEMP", DE.BSheetConn, adOpenForwardOnly, adLockReadOnly, adCmdTable

If Option1(0).Value Then

BSheetRpt.Show

Else

BSheetRpt.PrintReport

End If

Else

TerminateLoop = True

End If

Exit Sub

ErHand:

If Not err.Number = 8555 Then DE.BSheetConn.RollbackTrans

ErrHandler "DayBook.OkCmd_Click()"

OKCmd.Caption = "&OK"

CancelCmd.Enabled = True

Screen.MousePointer = vbDefault

PB.Visible = False

StcLbl.Caption = ""

End Sub

Private Function PrepairBSheet(ByVal TrialDt 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 <= '" & TrialDt & "'"

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 = ""

PrepairBSheet = True

End Function

Sponsored Links