Next Chapter 64 Voucher

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

.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 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

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 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 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.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

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

Else

If DrSrch.ListVisible Then DrSrch.HideList

If CrSrch.ListVisible Then CrSrch.HideList

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