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
Voucher
'******************************************************************
'******************************************************************
'** Subject : Creating Vouchers Entry Screen
'** Date : Thursday, October, 16, 2003
'** Modified : Tuesday, October, 28, 2003
'******************************************************************
'******************************************************************
Option Explicit
Dim ADDMode As Boolean
Dim EditMode As Boolean
Dim EmptyTable As Boolean
Dim VoucherType As String
Dim FormLoaded As Boolean
Dim vRst As ADODB.Recordset
Dim Bmark
Dim Conn As ADODB.Connection
Const NumFormat As String = "#0.#0"
Dim WithEvents Txt As TextBox
Private Sub AddCmd_Click()
ADDMode = True
Call ClearFields
Call SetControls
Grd.Row = 1
Grd.Col = 1
VoucherDate = Date
Call VoucherDate_Change
VNoTxt = GetVoucherCode
Conn.BeginTrans
End Sub
Private Sub ClearFields()
Call SetGrid
DayLbl = ""
Me.DebitLbl = ""
Me.CreditLbl = ""
End Sub
Private Sub CancelCmd_Click()
Conn.RollbackTrans
ADDMode = False
EditMode = False
Call SetControls
End Sub
Private Sub DelCmd_Click()
Dim SQL As String
If VNoTxt = "" Then
MsgBox "Please, Select Voucher No. from list.", vbCritical, "Missing V.NO."
Exit Sub
End If
If MsgBox("This will delete the selected voucher [" & VNoTxt & "]. Are you sure to delete it ?", vbQuestion + vbYesNo + vbDefaultButton2, "Deletion Confirmation...") = vbNo Then Exit Sub
Dim VoucherRst As New ADODB.Recordset
VoucherRst.CursorLocation = adUseClient
'Update ACTRANS Table and then Delete record
SQL = "SELECT * FROM VOUCHER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VNoTxt & "'"
If VoucherRst.State = adStateOpen Then VoucherRst.Close
VoucherRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
Do Until VoucherRst.EOF
Call BalancePost(EditPosting, IIf(VoucherRst!DrCr = "D", VoucherRst!DrAmt, VoucherRst!CrAmt), VoucherRst!DrCr, VoucherRst!AcCode, Conn)
VoucherRst.Delete
VoucherRst.MoveNext
Loop
Conn.CommitTrans
vRst.Requery
If Not (vRst.RecordCount > 0) Then EmptyTable = True
ADDMode = False
EditMode = False
Call SetControls
Call SetFieldsValues(vRst)
End Sub
Private Sub EditCmd_Click()
EditMode = True
Call ClearFields
Call SetControls
Grd.Row = 1
Grd.Col = 1
VNoTxt.SetFocus
Conn.BeginTrans
End Sub
Private Sub ExitCmd_Click()
Unload Me
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
If ADDMode Or EditMode Then
Call CancelCmd_Click
Else
Unload Me
End If
ElseIf Shift = vbCtrlMask And KeyCode = vbKeyLeft Then
If PrevCmd.Enabled Then PrevCmd.SetFocus
Call PrevCmd_Click
ElseIf Shift = vbCtrlMask And KeyCode = vbKeyRight Then
If NextCmd.Enabled Then NextCmd.SetFocus
Call NextCmd_Click
ElseIf Shift = vbCtrlMask And KeyCode = vbKeyHome Then
If TopCmd.Enabled Then TopCmd.SetFocus
Call TopCmd_Click
ElseIf Shift = vbCtrlMask And KeyCode = vbKeyEnd Then
If LastCmd.Enabled Then LastCmd.SetFocus
Call LastCmd_Click
ElseIf KeyCode = vbKeyF5 Then
Call SetAlignment
End If
End Sub
Private Sub SetGrid()
Dim i As Integer
With Grd
.Clear
.FormatString = " |Dr/Cr|<Account|>Debit|>Credit|Narration"
.ColWidth(0) = TextWidth("A") * 0
.ColWidth(1) = TextWidth("A") * 6
.ColWidth(2) = TextWidth("A") * 40
.ColWidth(3) = TextWidth("A") * 15
.ColWidth(4) = TextWidth("A") * 15
.ColWidth(5) = TextWidth("A") * 35
.RowHeight(0) = TextHeight("A") * 2
For i = 0 To .Cols - 1
.Row = 0
.Col = i
.CellFontBold = True
.CellTextStyle = flexTextRaisedLight
Next i
.Rows = 3
.Row = .FixedRows
.Col = 0
End With
End Sub
Private Sub Form_Load()
Set Txt = LTxt
End Sub
Private Sub Grd_EnterCell()
If Not (ADDMode Or EditMode) Then Exit Sub
Call SetAlignment 'Set Txt=LTxt / RTxt
Call SetMaxLength
If Grd.Col = 2 And Grd.Row > 0 Then
Txt = Grd.Text
ElseIf Grd.Col = 3 And Grd.Row > 0 Then
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "C" Then Grd.Col = 4
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then Grd.Col = 3
ElseIf Grd.Col = 4 And Grd.Row > 0 And UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then
Grd.Col = 5
ElseIf Grd.Col = 5 And Grd.Row > 2 Then
If Grd.TextMatrix(Grd.Row, 5) = "" Then
Grd.TextMatrix(Grd.Row, 5) = Grd.TextMatrix(Grd.Row - 2, 5)
End If
End If
End Sub
Private Sub Grd_KeyDown(KeyCode As Integer, Shift As Integer)
Call Txt_KeyDown(KeyCode, Shift)
End Sub
Private Sub Grd_LeaveCell()
If Not (ADDMode Or EditMode) Then Exit Sub
If Grd.Col = 1 And Grd.Row > 0 Then
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "C" Then
Grd.TextMatrix(Grd.Row, 1) = "Cr"
If Not (Val(Grd.TextMatrix(Grd.Row, 3)) = 0) Then
Grd.TextMatrix(Grd.Row, 4) = Grd.TextMatrix(Grd.Row, 3)
Grd.TextMatrix(Grd.Row, 3) = ""
End If
ElseIf UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then
Grd.TextMatrix(Grd.Row, 1) = "Dr"
If Not (Val(Grd.TextMatrix(Grd.Row, 4)) = 0) Then
Grd.TextMatrix(Grd.Row, 3) = Grd.TextMatrix(Grd.Row, 4)
Grd.TextMatrix(Grd.Row, 4) = ""
End If
End If
SaveCmd.Enabled = Not IsRowTobeAdd 'Display Debit & Credit Sum at the bottom
ElseIf Grd.Col = 2 And Grd.Row > 0 Then
If Grd.TextMatrix(Grd.Row, 1) = "Cr" And Not CrSrch.SelectedCompany = "" Then
If Not InStr(CrSrch.SelectedCompany, "-") = 0 Then
Txt = Mid(CrSrch.SelectedCompany, 1, InStr(CrSrch.SelectedCompany, "-") - 1)
Else
Txt = CrSrch.SelectedCompany
End If
Grd.TextMatrix(Grd.Row, 2) = Txt
Grd.TextMatrix(Grd.Row, 0) = CrSrch.UniqueCode
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Dr" And Not DrSrch.SelectedCompany = "" Then
If Not InStr(DrSrch.SelectedCompany, "-") = 0 Then
Txt = Mid(DrSrch.SelectedCompany, 1, InStr(DrSrch.SelectedCompany, "-") - 1)
Else
Txt = DrSrch.SelectedCompany
End If
Grd.TextMatrix(Grd.Row, 2) = Txt
Grd.TextMatrix(Grd.Row, 0) = DrSrch.UniqueCode
End If
'Display Balance
If Not Grd.TextMatrix(Grd.Row, 0) = "" Then
If (Grd.Row + 1) <= (Grd.Rows - 1) Then Call MergeCells(Grd.Row + 1, Grd.TextMatrix(Grd.Row, 0))
End If
ElseIf (Grd.Col = 3 Or Grd.Col = 4) And Grd.Row > 0 Then
If Not Grd.TextMatrix(Grd.Row, 0) = "" Then
Dim Amt As Double
If Grd.TextMatrix(Grd.Row, 1) = "Cr" Then
Amt = -Val(Grd.TextMatrix(Grd.Row, 4))
Else
Amt = Val(Grd.TextMatrix(Grd.Row, 3))
End If
If (Grd.Row + 1) <= (Grd.Rows - 1) Then Call MergeCells(Grd.Row + 1, Grd.TextMatrix(Grd.Row, 0), Amt)
End If
End If
End Sub
Private Sub Grd_RowColChange()
If Not (ADDMode Or EditMode) Then Exit Sub
Dim i As Integer
Dim Amt As Double
i = Grd.Row Mod 2
Txt.Visible = i
If i = 0 Then
'MergeCells (Grd.TextMatrix(Grd.Row - 1, 0))
SaveCmd.Enabled = (ADDMode Or EditMode) And (DebitLbl.Caption = CreditLbl.Caption) And (Val(DebitLbl.Caption) <> 0 And Val(CreditLbl.Caption) <> 0)
End If
If Txt.Visible And (Grd.Col = 3 Or Grd.Col = 4) Then
If Grd.TextMatrix(Grd.Row, 1) = "Cr" And Grd.Col = 3 Then
Txt.Visible = False
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Cr" And Grd.Col = 4 Then
Txt.Visible = True
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Dr" And Grd.Col = 3 Then
Txt.Visible = True
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Dr" And Grd.Col = 4 Then
Txt.Visible = False
End If
Else
'
End If
If Not Txt.Visible Then Exit Sub
If Not (Grd.CellWidth > 0 And Grd.CellHeight > 0) Then Exit Sub
Txt.Move (Screen.TwipsPerPixelX * 3) + Grd.CellLeft, Grd.Top + Grd.CellTop, Grd.CellWidth, Grd.CellHeight
If Txt.Visible And Txt.Enabled Then
Txt = Grd.Text
SelectText Txt
Txt.SetFocus
End If
End Sub
Private Sub MergeCells(ByVal R As Integer, ByVal vCode As String, Optional vAmount As Double)
Dim i As Integer, BalAmt As Double
Dim vTxt, SQL As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
SQL = "Select * from ACTRANS Where ACCODE = '" & vCode & "'"
rst.Open SQL, Conn, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.RecordCount > 0) Then Exit Sub
BalAmt = IIf(IsNull(rst!CLOSING), 0, rst!CLOSING) + vAmount
vTxt = "Current Balance (Rs. " & Format(Abs(BalAmt), NumFormat) & " ) " & IIf(BalAmt < 0, "Cr", IIf(BalAmt > 0, "Dr", ""))
With Grd
If Not (R > (.FixedRows - 1)) Then Exit Sub
.MergeCells = flexMergeRestrictRows
.MergeRow(R) = True
For i = 2 To .Cols - 1
.TextMatrix(R, i) = Space(10) & vTxt
Next i
End With
End Sub
Private Sub SetAlignment()
If Not (ADDMode Or EditMode) Then Exit Sub
RTxt.Visible = False
Select Case Grd.Col
Case 1 'Dr/Cr
Set Txt = LTxt
Case 2 'Account
Set Txt = LTxt
Case 3 'Debit
RTxt.Visible = True
Set Txt = RTxt
Case 4 'Credit
RTxt.Visible = True
Set Txt = RTxt
Case 5 'Narration
Set Txt = LTxt
Case Else
Set Txt = LTxt
End Select
End Sub
Private Sub SetMaxLength()
Select Case Grd.Col
Case 1 'Dr/Cr
Txt.MaxLength = 2
Case 2 'Account
Txt.MaxLength = 50
Case 3 'Debit
Txt.MaxLength = 8
Case 4 'Credit
Txt.MaxLength = 8
Case 5 'Narration
Txt.MaxLength = 50
End Select
End Sub
Private Sub LTxt_KeyDown(KeyCode As Integer, Shift As Integer)
If Not (ADDMode Or EditMode) Then Exit Sub
If Grd.Col <> 2 Then Exit Sub
If Shift = vbCtrlMask And KeyCode = 40 Then
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "C" Then CrSrch.MoveNext
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then DrSrch.MoveNext
ElseIf Shift = vbCtrlMask And KeyCode = 38 Then
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "C" Then CrSrch.MovePrevious
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then DrSrch.MovePrevious
End If
End Sub
Private Sub PrintCmd_Click()
On Error GoTo ErHand
Dim SQL As String
If VNoTxt = "" Then
MsgBox "There is no current Voucher No. to print.", vbExclamation, "Missing Values"
Exit Sub
End If
If DE.VoucherConn.State = adStateOpen Then DE.VoucherConn.Close
DE.VoucherConn.Open ShapeConnectString
If DE.rsMasterRst.State = adStateOpen Then DE.rsMasterRst.Close
SQL = "SHAPE {SELECT DISTINCT VOUCHER.VNO, VOUCHER.VTYPE, VOUCHER.VDATE, Sum(VOUCHER.DRAMT) AS TotalOfDr, Sum(VOUCHER.CRAMT) AS TotalOfCr From VOUCHER " & _
"WHERE (VOUCHER.VTYPE='" & VoucherType & "' AND VOUCHER.VNO = '" & VNoTxt & "') GROUP BY VOUCHER.VNO, VOUCHER.VTYPE, VOUCHER.VDATE ORDER BY VOUCHER.VNO DESC} AS MasterRst APPEND ({SELECT VOUCHER.SNO, VOUCHER.VTYPE, VOUCHER.VNO, VOUCHER.VDATE, VOUCHER.ACCODE, ACMAST.ACDESC, VOUCHER.ACCONTRA, CASE WHEN VOUCHER.DRCR='D' THEN VOUCHER.DRAMT ELSE Null END AS DebitAmt, CASE WHEN VOUCHER.DRCR='C' THEN VOUCHER.CRAMT ELSE Null END AS CreditAmt, VOUCHER.DRCR, VOUCHER.NARR " & _
"FROM VOUCHER INNER JOIN ACMAST ON VOUCHER.ACCODE = ACMAST.ACCODE ORDER BY VOUCHER.DRCR} AS DetailRst RELATE 'VNO' TO 'VNO','VTYPE' TO 'VTYPE') AS DetailRst"
DE.rsMasterRst.Open SQL, DE.VoucherConn, adOpenForwardOnly, adLockReadOnly, adCmdText
Set VoucherRpt.DataSource = DE
VoucherRpt.Sections("ReportHeader").Controls("lblHeader").Caption = Label1(1).Caption
If PrintChk.Value = vbChecked Then
VoucherRpt.Show
Else
VoucherRpt.PrintReport
End If
ErHand:
ErrHandler "VoucherFrm.CmdPrint"
End Sub
Private Sub RTxt_KeyPress(KeyAscii As Integer)
ValidateNumber KeyAscii
End Sub
Private Sub SaveCmd_Click()
If Not SavedData Then Exit Sub
Conn.CommitTrans
If ADDMode Then EmptyTable = False
vRst.Requery
RecordLbl = "Record " & vRst.AbsolutePosition & " of " & vRst.RecordCount
ADDMode = False
EditMode = False
Call SetControls
End Sub
Private Sub Txt_Change()
If Not (ADDMode Or EditMode) Then Exit Sub
If Grd.Col = 3 Or Grd.Col = 4 Then
Grd.Text = Txt.Text
Else
Grd.Text = Txt.Text
If Grd.Col = 2 And (ADDMode Or EditMode) Then
If Grd.TextMatrix(Grd.Row, 1) = "Cr" Then
'CrSrch.SearchValue Grd.Text
CrSrch.SearchValue Txt.Text
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Dr" Then
'DrSrch.SearchValue Grd.Text
DrSrch.SearchValue Txt.Text
End If
End If
End If
End Sub
Private Sub Txt_KeyDown(KeyCode As Integer, Shift As Integer)
If Not (ADDMode Or EditMode) Then Exit Sub
If Not Shift = 0 Then Exit Sub
With Txt
Select Case KeyCode
Case vbKeyRight
If .SelStart = Len(.Text) Then Call ShiftToRightCell
Case vbKeyLeft
If .SelStart = 0 Then Call ShiftToLeftCell
Case vbKeyUp
Call ShiftToUpperCell
Case vbKeyDown
Call ShiftToLowerCell
Case vbKeyReturn
Call ShiftToRightCell
End Select
End With
End Sub
Private Sub ShiftToRightCell()
If (Grd.Col < Grd.Cols - 1) And (Grd.Col > Grd.FixedCols - 1) Then
Grd.Col = Grd.Col + 1
ElseIf Grd.Col = (Grd.Cols - 1) Then
If (Grd.Row < (Grd.Rows - 1)) Then
If IsRowTobeAdd Then
If Grd.Row = (Grd.Rows - 2) Then
Grd.Col = Grd.FixedCols
Grd.AddItem ""
Grd.AddItem ""
Grd.Row = Grd.Row + 1 'Skip with single rows (To Display Balance)
Grd.Row = Grd.Row + 1
Else
If (Grd.Row + 2) <= (Grd.Rows - 1) Then
Grd.Col = 1
Grd.Row = Grd.Row + 2
End If
End If
Else
Grd.Row = Grd.Row + 1 'Skip with single rows (To Display Balance)
'If Not EditMode Then
If SaveCmd.Enabled Then SaveCmd.SetFocus
'End If
End If
End If
End If
End Sub
Private Function IsRowTobeAdd() As Double
Dim DebitAmt, CreditAmt As Double
DebitAmt = SumOfColumn(3)
DebitLbl = Format(DebitAmt, "0.00")
CreditAmt = SumOfColumn(4)
CreditLbl = Format(CreditAmt, "0.00")
IsRowTobeAdd = Not (DebitAmt = CreditAmt)
End Function
Private Function SumOfColumn(ByVal GridCol As Integer) As Double
Dim i, vSumVal As Double
If Not Grd.Cols > GridCol Then Exit Function
For i = 1 To Grd.Rows - 1
If Not (Grd.TextMatrix(i, 0) = "" Or Grd.TextMatrix(i, 1) = "" Or Grd.TextMatrix(i, 0) = "") Then
vSumVal = vSumVal + Val(Grd.TextMatrix(i, GridCol))
End If
Next i
SumOfColumn = vSumVal
End Function
Private Sub ShiftToLeftCell()
If (Grd.Col > Grd.FixedCols) And (Grd.Col < Grd.Cols) Then
If (Grd.Col - 1) = 3 And Grd.Row > 0 Then
If UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "C" Then Grd.Col = 2
ElseIf ((Grd.Col - 1) = 4 And Grd.Row > 0) And UCase(Left(Grd.TextMatrix(Grd.Row, 1), 1)) = "D" Then
Grd.Col = 3
Else
Grd.Col = Grd.Col - 1
End If
End If
End Sub
Private Sub ShiftToUpperCell()
If (Grd.Row > Grd.FixedRows) Then Grd.Row = Grd.Row - 1
End Sub
Private Sub ShiftToLowerCell()
If (Grd.Row < Grd.Rows - 1) And (Grd.Row > Grd.FixedRows - 1) Then Grd.Row = Grd.Row + 1
End Sub
Private Sub SetControls()
'Set Forms Control's status
Grd.Enabled = (ADDMode Or EditMode)
AddCmd.Enabled = Not (ADDMode Or EditMode)
EditCmd.Enabled = Not (EmptyTable Or ADDMode Or EditMode)
PrintCmd.Enabled = Not (EmptyTable Or ADDMode Or EditMode)
PrintChk.Enabled = Not (EmptyTable Or ADDMode Or EditMode)
If Not (ADDMode Or EditMode) Then SaveCmd.Enabled = False
CancelCmd.Enabled = (ADDMode Or EditMode)
CancelCmd.Cancel = (ADDMode Or EditMode)
DelCmd.Enabled = (Not EmptyTable) And (EditMode)
ExitCmd.Enabled = Not (ADDMode Or EditMode)
ExitCmd.Cancel = Not (ADDMode Or EditMode)
VoucherDate.Enabled = (ADDMode Or EditMode)
VNoTxt.Enabled = EditMode
If Not (ADDMode Or EditMode) Then LTxt.Visible = False
If Not (ADDMode Or EditMode) Then RTxt.Visible = False
If Not (ADDMode Or EditMode) Then DrSrch.HideList
If Not (ADDMode Or EditMode) Then CrSrch.HideList
TopCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (vRst.AbsolutePosition > 1)
PrevCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (vRst.AbsolutePosition > 1)
NextCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (vRst.AbsolutePosition < vRst.RecordCount)
LastCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (vRst.AbsolutePosition < vRst.RecordCount)
Timer1.Enabled = (ADDMode Or EditMode)
End Sub
Private Function GetCaption(ByVal vString As String) As String
Select Case vString
Case Is = "PT"
GetCaption = "Payment Voucher"
Case Is = "RT"
GetCaption = "Receipt Voucher"
Case Is = "CO"
GetCaption = "Contra Voucher"
Case Is = "JV"
GetCaption = "Journal Voucher"
Case Else
GetCaption = "Unknown Voucher Type"
End Select
End Function
Private Sub Form_Paint()
Dim SQL As String
If FormLoaded Then Exit Sub
VoucherType = Me.Tag
If Me.Tag = "" Then
MsgBox "Cannot indentified voucher type.", vbCritical, "Application Terminated"
Exit Sub
End If
Label1(1).Caption = GetCaption(VoucherType)
Me.Caption = Label1(1).Caption
Set Conn = New ADODB.Connection
Conn.mode = adModeReadWrite
Conn.CursorLocation = adUseClient
Conn.Open ShapeConnectString
With DrSrch
.DBConnectString = ConnectString
.SQLString = "SELECT VNO, VNO + Space(5) + ACDESC FROM SALE WHERE VTYPE = '" & VoucherType & "'"
.SQLString = "Select Accode, COALESCE(AcDesc + Space(5) + ' -> ' + ACAlias,AcDesc) From ACMAST Where RECType = 'A'"
.PopulateList
End With
With CrSrch
.DBConnectString = ConnectString
.SQLString = "SELECT VNO, VNO + Space(5) + ACDESC FROM SALE WHERE VTYPE = '" & VoucherType & "'"
.SQLString = "Select Accode,COALESCE(AcDesc + Space(5) + ' -> ' + ACAlias,AcDesc) From ACMAST Where RECType = 'A'"
.PopulateList
End With
Call SetGrid
Set vRst = New ADODB.Recordset
vRst.CursorLocation = adUseClient
SQL = "SHAPE {SELECT DISTINCT VOUCHER.VNO, VOUCHER.VTYPE, VOUCHER.VDATE, Sum(VOUCHER.DRAMT) AS TotalOfDr, Sum(VOUCHER.CRAMT) AS TotalOfCr From VOUCHER " & _
"WHERE (((VOUCHER.VTYPE)='" & VoucherType & "')) GROUP BY VOUCHER.VNO, VOUCHER.VTYPE, VOUCHER.VDATE ORDER BY VOUCHER.VNO DESC} AS MasterRst APPEND ({SELECT VOUCHER.SNO, VOUCHER.VTYPE, VOUCHER.VNO, VOUCHER.VDATE, VOUCHER.ACCODE, ACMAST.ACDESC, VOUCHER.ACCONTRA, VOUCHER.DRAMT, VOUCHER.CRAMT, VOUCHER.DRCR, VOUCHER.NARR " & _
"FROM VOUCHER INNER JOIN ACMAST ON VOUCHER.ACCODE = ACMAST.ACCODE ORDER BY VOUCHER.DRCR} AS DetailRst RELATE 'VNO' TO 'VNO','VTYPE' TO 'VTYPE') AS DetailRst"
vRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If vRst.RecordCount > 0 Then
Call SetFieldsValues(vRst)
Else
EmptyTable = True
End If
Call SetControls
FormLoaded = True
End Sub
Private Sub Txt_KeyPress(KeyAscii As Integer)
If Not (ADDMode Or EditMode) Then Exit Sub
If Grd.Col = 1 Then
If Not (UCase(Chr(KeyAscii)) = "D" Or UCase(Chr(KeyAscii)) = "C") And KeyAscii <> vbKeyBack Then KeyAscii = 0
End If
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
If Not Txt.Visible Then Exit Sub
If Not (ActiveControl.Name = "LTxt") Then
If DrSrch.ListVisible Then DrSrch.HideList
If CrSrch.ListVisible Then CrSrch.HideList
ElseIf (ActiveControl.Name = "LTxt") Then
If (Grd.Col = 2) Then
If Grd.TextMatrix(Grd.Row, 1) = "Dr" Then
CrSrch.HideList
If Not DrSrch.ListVisible Then
DrSrch.ShowList 490, 10
If ActiveControl.Name = "LTxt" Then LTxt.SetFocus
End If
ElseIf Grd.TextMatrix(Grd.Row, 1) = "Cr" Then
DrSrch.HideList
If Not CrSrch.ListVisible Then
CrSrch.ShowList 490, 10
If ActiveControl.Name = "LTxt" Then LTxt.SetFocus
End If
End If
Else
If DrSrch.ListVisible Then DrSrch.HideList
If CrSrch.ListVisible Then CrSrch.HideList
End If
End If
End Sub
Private Function SavedData() As Boolean
On Error GoTo SAM
Dim SQL, VoucherNo As String
Dim R As Integer
Dim VoucherRst As New ADODB.Recordset
VoucherRst.CursorLocation = adUseClient
If EditMode And VNoTxt = "" Then
MsgBox "Please enter a valid Voucher to edit record.", vbCritical, "Missing Value"
Exit Function
End If
VoucherNo = IIf(ADDMode, GetVoucherCode(), VNoTxt)
'Update ACTRANS Table at Editing Time
SQL = "SELECT * FROM VOUCHER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"
If VoucherRst.State = adStateOpen Then VoucherRst.Close
VoucherRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
Do Until VoucherRst.EOF
Call BalancePost(EditPosting, IIf(VoucherRst!DrCr = "D", VoucherRst!DrAmt, VoucherRst!CrAmt), VoucherRst!DrCr, VoucherRst!AcCode, Conn)
VoucherRst.Delete
VoucherRst.MoveNext
Loop
'Saving data to voucher table
If VoucherRst.State = adStateOpen Then VoucherRst.Close
VoucherRst.Open "VOUCHER", Conn, adOpenKeyset, adLockOptimistic, adCmdTable
For R = 1 To Grd.Rows - 1 Step 2
If Not (Grd.TextMatrix(R, 0) = "" Or Grd.TextMatrix(R, 1) = "") Then
VoucherRst.AddNew
VoucherRst!sno = GetVoucherID
VoucherRst!VType = VoucherType
VoucherRst!Vno = VoucherNo
VoucherRst!vDate = VoucherDate.Value
VoucherRst!AcCode = Grd.TextMatrix(R, 0)
VoucherRst!ACContra = AccountraCode(Grd.TextMatrix(R, 1))
VoucherRst!DrAmt = IIf(Grd.TextMatrix(R, 1) = "Cr", 0, Val(Grd.TextMatrix(R, 3)))
VoucherRst!CrAmt = IIf(Grd.TextMatrix(R, 1) = "Cr", Val(Grd.TextMatrix(R, 4)), 0)
VoucherRst!DrCr = IIf(Grd.TextMatrix(R, 1) = "Cr", "C", "D")
VoucherRst!NARR = Grd.TextMatrix(R, 5)
VoucherRst.Update
End If
Next R
'Update ACTRANS Table
SQL = "SELECT * FROM VOUCHER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"
If VoucherRst.State = adStateOpen Then VoucherRst.Close
VoucherRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
Do Until VoucherRst.EOF
Call BalancePost(ADDPosting, IIf(VoucherRst!DrCr = "D", VoucherRst!DrAmt, VoucherRst!CrAmt), VoucherRst!DrCr, VoucherRst!AcCode, Conn)
VoucherRst.MoveNext
Loop
SavedData = True
Exit Function
SAM:
MsgBox "ERROR IN SAVE DATA", vbInformation, App.Title
End Function
Private Function AccountraCode(CrDr As String) As String
Dim R As Integer
For R = 1 To Grd.Rows - 1 Step 2
If Grd.TextMatrix(R, 1) = IIf(CrDr = "Cr", "Dr", "Cr") Then
'MsgBox R & CrDr & vbCrLf & Grd.TextMatrix(R, 1) & vbCrLf & Grd.TextMatrix(R, 0)
AccountraCode = Grd.TextMatrix(R, 0)
Exit For
End If
Next R
End Function
Private Sub SetFieldsValues(ByRef rst As ADODB.Recordset)
Dim ItemString As String
Dim ItemRst As New ADODB.Recordset
ItemRst.CursorLocation = adUseClient
If Not rst.RecordCount > 0 Then
RecordLbl = "(None)"
Call ClearFields
Exit Sub
End If
If rst.BOF Then rst.MoveFirst
If rst.EOF Then rst.MoveLast
RecordLbl = "Record " & rst.AbsolutePosition & " of " & rst.RecordCount
VNoTxt = rst!Vno
VoucherDate = rst!vDate
DayLbl = Format(rst!vDate, "dddd")
DebitLbl = Format(rst!TotalOfDr, NumFormat)
CreditLbl = Format(rst!TotalOfCr, NumFormat)
Set ItemRst = rst("DetailRst").UnderlyingValue
Grd.Rows = 1
If Not (ItemRst.RecordCount > 0) Then
Grd.AddItem "" 'Add a blank row if Item not found
Exit Sub
End If
Do Until ItemRst.EOF
ItemString = ItemRst!AcCode & vbTab & IIf(ItemRst!DrCr = "C", "Cr", "Dr") & vbTab & ItemRst!AcDESC
ItemString = ItemString & vbTab & ItemRst!DrAmt & vbTab & ItemRst!CrAmt & vbTab & ItemRst!NARR
Grd.AddItem ItemString
Grd.AddItem ""
Grd.Row = Grd.Rows - 1
Call MergeCells(Grd.Row, ItemRst!AcCode)
ItemRst.MoveNext
Loop
End Sub
Private Function GetVoucherCode() As String
Dim RS As New ADODB.Recordset
RS.Open "Select Max(VNO) From VOUCHER WHERE VTYPE = '" & VoucherType & "'", Conn, adOpenDynamic, adLockOptimistic
GetVoucherCode = GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 6)
End Function
Private Sub VNoTxt_GotFocus()
If Not EditMode Then Exit Sub
SelectText VNoTxt
End Sub
Private Sub VNoTxt_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then SendKeys "{TAB}"
End Sub
Private Sub VNoTxt_Validate(Cancel As Boolean)
If Not EditMode Then Exit Sub
Dim SQL As String
Dim BeforeSearchBmark
If VNoTxt.Text = "" Then Exit Sub
If vRst.AbsolutePosition > 0 Then BeforeSearchBmark = vRst.Bookmark
VNoTxt = GetProperCode(VNoTxt, 6)
vRst.MoveFirst
vRst.Find "VNO='" & VNoTxt & "'"
If vRst.EOF Then
MsgBox "Voucher No. not found.", vbCritical, "Invalid Voucher No."
If Not IsEmpty(BeforeSearchBmark) Then vRst.Bookmark = BeforeSearchBmark
Else
Bmark = vRst.Bookmark
Call SetFieldsValues(vRst)
Grd.Row = 1
Grd.Col = 1
End If
End Sub
Private Sub VoucherDate_Change()
DayLbl = Format(VoucherDate, "dddd")
End Sub
Private Sub NextCmd_Click()
NextMove vRst
Call SetFieldsValues(vRst)
Call SetControls
End Sub
Private Sub PrevCmd_Click()
PreviousMove vRst
Call SetFieldsValues(vRst)
Call SetControls
End Sub
Private Sub TopCmd_Click()
TopMove vRst
Call SetFieldsValues(vRst)
Call SetControls
End Sub
Private Sub LastCmd_Click()
LastMove vRst
Call SetFieldsValues(vRst)
Call SetControls
End Sub
Private Sub VoucherDate_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
End Sub
Private Function GetVoucherID() As String
Dim RS As New ADODB.Recordset
RS.Open "Select Max(SNO) From Voucher", Conn, adOpenDynamic, adLockOptimistic
If Not RS.EOF Then GetVoucherID = GetProperCode(IIf(IsNull(RS(0)), "1", Mid(RS(0), 2) + 1), 6) Else GetVoucherID = GetProperCode("1", 6)
End Function