Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
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