Next Chapter 52 Purchase

Purchase

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

'** Author : Samee Ullah Siddiqui

'** Subject : Manipulate Purchase/Purchase Return Details

'** Date : Thursday, August, 21, 2003

'** Modified : Monday, August, 25, 2003

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

Dim ADDMode As Boolean

Dim EditMode As Boolean

Dim EmptyTable As Boolean

Dim VoucherType As String

Dim FormLoaded As Boolean

Dim PurchaseRst As ADODB.Recordset

Dim Bmark

Dim Conn As ADODB.Connection

Dim WithEvents vMenu As Menu

Private Sub AddCmd_Click()

ADDMode = True

Call SetControls

Call ClearFields

Call CashCB_Click

Conn.BeginTrans

End Sub

Private Sub CancelCmd_Click()

Conn.RollbackTrans

ADDMode = False

EditMode = False

Call SetControls

End Sub

Private Sub CartTxt_Change()

Call NetPayableAmount

End Sub

Private Sub CartTxt_GotFocus()

SelectText CartTxt

End Sub

Private Sub CartTxt_KeyPress(KeyAscii As Integer)

ValidateNumber KeyAscii

End Sub

Private Sub CartTxt_Validate(Cancel As Boolean)

ValidateDesimal CartTxt, Cancel, 2

CartTxt = Format(CartTxt, "#0.#0")

End Sub

Private Sub CashCB_Click()

Set AccSrch.BoundTextBox = IIf(CashCB.ListIndex <= 0, Nothing, SuplTxt)

MrnTxt = GetVoucherCode

End Sub

Private Sub DelCmd_Click()

If MrnTxt = "" Then MsgBox "Please select voucher no. to delete", vbCritical, "Invalid voucher no.": Exit Sub

If MsgBox("This will delete selected voucher. Are you sure to delete it.", vbQuestion + vbYesNo + vbDefaultButton2, "Deletion Confirmation") = vbNo Then Exit Sub

Call DeleteVoucher

Conn.CommitTrans

PurchaseRst.Requery

VnoSrch.PopulateList

If Not (PurchaseRst.RecordCount > 0) Then EmptyTable = True

ADDMode = False

EditMode = False

Call SetControls

Call SetFieldsValues(PurchaseRst)

End Sub

Private Sub EditCmd_Click()

EditMode = True

Call SetControls

Call ClearFields

ItemGrid.RefreshEditor

Conn.BeginTrans

End Sub

Private Sub ExitCmd_Click()

Unload Me

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeyReturn Then

If (Me.ActiveControl.Name = "SuplTxt" And CashCB.ListIndex = 1) Then Exit Sub

If (Me.ActiveControl.Name = "ItemGrid") Then Exit Sub

If (EditMode And Me.ActiveControl.Name = "MrnTxt") Then Exit Sub

SendKeys "{TAB}"

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

End If

End Sub

Private Sub SetGridProps(Optional Rows As Integer)

With ItemGrid

.Clear

.Rows = IIf(Rows <= 1, 2, Rows)

.ColWidth(1) = TextWidth("A") * 55 'PARTICULARS

.ColWidth(2) = TextWidth("A") * 8 'Packing

.ColWidth(3) = TextWidth("A") * 8 'Stock

.ColWidth(4) = TextWidth("A") * 8 'QUANTITY

.ColWidth(5) = TextWidth("A") * 8 'RATE

.ColWidth(6) = TextWidth("A") * 15 'AMOUNT

.ColWidth(7) = TextWidth("A") * 0 'Item Code

.ColWidth(8) = TextWidth("A") * 0 'Stock

.ColWidth(9) = TextWidth("A") * 0 'Old Quantity

.ColWidth(10) = TextWidth("A") * 0 'Batch Number

.ColWidth(11) = TextWidth("A") * 0 'Exp Date

.ColWidth(12) = TextWidth("A") * 0 'Mfg Date

.ColWidth(13) = TextWidth("A") * 0 'Free

.EnableEditing(3) = False 'Stock

.EnableEditing(6) = False 'Amount

.EnableEditing(7) = False 'Item Code

.EnableEditing(8) = False 'Stock

.EnableEditing(9) = False 'Old Quantity

.NumbersOnly(2, 3, 50) = True

.NumbersOnly(3, 7) = True

.NumbersOnly(4, 4) = True

.NumbersOnly(5, 6) = True

.NumbersOnly(6, 10) = True

End With

End Sub

Private Sub Form_Load()

TxtType.Text = "Medicine"

Call TxtType_Click

If Expiry = False Or TxtType.Text = "Other" Then Call SetGridProps Else Call SetGridPropsForMedicine

End Sub

Private Sub Form_Paint()

If FormLoaded Then Exit Sub

If Me.Tag = "" Then

MsgBox "Cannot indentified voucher type.", vbCritical, "Application Terminated"

Exit Sub

End If

VoucherType = Me.Tag

Me.Caption = IIf(VoucherType = "PV", "Purchase Entry", "Purchase Return Entry")

Label1(1).Caption = IIf(VoucherType = "PV", "Purchase Entry", "Purchase Return Entry")

Label2(4).Caption = IIf(VoucherType = "PV", "MRN No.", "Debit Note No.")

Set Conn = New ADODB.Connection

Conn.mode = adModeReadWrite

Conn.CursorLocation = adUseClient

Conn.Open ShapeConnectString

With AccSrch

.DBConnectString = ConnectString

.SQLString = "SELECT ACCode, ACDESC FROM ACMAST WHERE RECTYPE = 'A' AND CASH = 'P' And ( GRCode='000038' Or GRCode='000008') "

.PopulateList

End With

With VnoSrch

.DBConnectString = ConnectString

.SQLString = "SELECT VNO, VNO + space(5) + ACDESC FROM PURCHASE WHERE VTYPE = '" & VoucherType & "'"

.PopulateList

End With

' With ItemSrch

' .DBConnectString = ConnectString

' .SQLString = "SELECT ItemCode, Item_Desc FROM ITEM"

' .PopulateList

' End With

Set PurchaseRst = New ADODB.Recordset

PurchaseRst.CursorLocation = adUseClient

Dim SQL As String

SQL = "SHAPE {SELECT * FROM [Purchase] WHERE Purchase.VTYPE = '" & VoucherType & "' Order By ID DESC} AS Purchase APPEND ({SELECT Ledger.ICODE, ITEM.Item_Desc, Ledger.ISIZE, Ledger.QTY, Ledger.Rate, Ledger.QTY * Ledger.Rate as Amount,Ledger.Free , Ledger.VDATE, Ledger.VNO, Ledger.VTYPE, ItemSize.Stock FROM Ledger, ITEM, ITEMSIZE WHERE (Ledger.ICODE = ITEM.ItemCode) AND (LEDGER.ICODE = ITEMSIZE.ICODE AND LEDGER.ISIZE = ITEMSIZE.ISIZE)} AS Items RELATE 'VTYPE' TO 'VTYPE','VNO' TO 'VNO') AS Items"

PurchaseRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText

If PurchaseRst.RecordCount > 0 Then

Call SetFieldsValues(PurchaseRst)

Else

EmptyTable = True

End If

Call SetControls

FormLoaded = True

End Sub

Private Sub Form_Unload(Cancel As Integer)

On Error Resume Next

PurchaseRst.Close

Set PurchaseRst = Nothing

Conn.Close

Set Conn = Nothing

End Sub

Private Sub SetControls()

'Set Forms Control's status

'Called in ItemDBCtl_MoveComplete(), Form_Load(), Navigation Buttons Click()

VoucherFrame.Enabled = (ADDMode Or EditMode)

ItemFrame.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) And VoucherType = "PR"

PrintChk.Enabled = Not (EmptyTable Or ADDMode Or EditMode) And VoucherType = "PR"

SaveCmd.Enabled = (ADDMode Or EditMode)

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)

ItemGrid.ShowEditor = (ADDMode Or EditMode)

If Not (ADDMode Or EditMode) Then AccSrch.HideList

If Not (ADDMode Or EditMode) Then ItemSrch.HideList

If Not (ADDMode Or EditMode) Then VnoSrch.HideList

CashCB.Enabled = Not EditMode

If (ADDMode Or EditMode) Then

ItemGrid.Col = 1

ItemGrid.Row = IIf(ADDMode, 1, ItemGrid.Rows - 1)

End If

Set VnoSrch.BoundTextBox = IIf(EditMode, MrnTxt, Nothing)

TopCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (PurchaseRst.AbsolutePosition > 1)

PrevCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (PurchaseRst.AbsolutePosition > 1)

NextCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (PurchaseRst.AbsolutePosition < PurchaseRst.RecordCount)

LastCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (PurchaseRst.AbsolutePosition < PurchaseRst.RecordCount)

Timer1.Enabled = (ADDMode Or EditMode)

End Sub

Private Sub ItemGrid_EditorChange()

If ItemGrid.Col = 1 Then

ItemSrch.SearchValue ItemGrid.Text

End If

End Sub

Private Sub ItemGrid_EnterCell()

If Not (ADDMode Or EditMode) Then Exit Sub

If ItemGrid.Col = 1 Then

If ItemGrid.Row > (ItemGrid.FixedRows) And ItemGrid.TextMatrix(ItemGrid.Row, 1) = "" Then ItemGrid.TextMatrix(ItemGrid.Row, 1) = ItemGrid.TextMatrix(ItemGrid.Row - 1, 1)

ItemSrch.SearchValue ItemGrid.Text

Else

Call SelectText(ItemGrid.GridTextBox)

End If

End Sub

Public Sub LeaveCell()

Dim rst As ADODB.Recordset

If Not (ADDMode Or EditMode) Then Exit Sub

If ItemGrid.Col = 1 And Not ItemSrch.SelectedCompany = "" Then

ItemGrid.TextMatrix(ItemGrid.Row, 1) = Mid(ItemSrch.SelectedCompany, 1, InStr(ItemSrch.SelectedCompany, "-") - 1)

ItemGrid.TextMatrix(ItemGrid.Row, 2) = Right(ItemSrch.SelectedCompany, Len(ItemSrch.SelectedCompany) - InStr(ItemSrch.SelectedCompany, "="))

ItemGrid.TextMatrix(ItemGrid.Row, 7) = ItemSrch.UniqueCode

ElseIf ItemGrid.Col = 2 Then

'Get Stock Value of selected item

If (ItemGrid.TextMatrix(ItemGrid.Row, 7) = "" Or ItemGrid.TextMatrix(ItemGrid.Row, 2) = "") Then Exit Sub

Dim SQL As String

Set rst = New ADODB.Recordset

rst.CursorLocation = adUseClient

SQL = "SELECT * FROM ITEMSIZE WHERE ICODE = '" & ItemGrid.TextMatrix(ItemGrid.Row, 7) & "' AND ISIZE = " & ItemGrid.TextMatrix(ItemGrid.Row, 2)

rst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText

If rst.RecordCount > 0 Then

ItemGrid.TextMatrix(ItemGrid.Row, 3) = IIf(IsNull(rst!STOCK), 0, rst!STOCK)

ItemGrid.TextMatrix(ItemGrid.Row, 8) = IIf(IsNull(rst!STOCK), 0, rst!STOCK)

Else

'Inserting new entry in itemsize table if not exist

rst.AddNew

rst!ICODE = ItemGrid.TextMatrix(ItemGrid.Row, 7)

rst!ISIZE = ItemGrid.TextMatrix(ItemGrid.Row, 2)

rst!STOCK = 0

rst!OPPRCHRATE = 0

rst!PRCHRATE = 0

rst.Update

ItemGrid.TextMatrix(ItemGrid.Row, 3) = 0

ItemGrid.TextMatrix(ItemGrid.Row, 8) = 0

End If

rst.Close

ElseIf ItemGrid.Col = 4 Or ItemGrid.Col = 13 Then

Dim vQty As Integer

If ADDMode Then

ItemGrid.TextMatrix(ItemGrid.Row, 3) = IIf(VoucherType = "PV", Val(ItemGrid.TextMatrix(ItemGrid.Row, 8)) + Val(ItemGrid.TextMatrix(ItemGrid.Row, 4)) + Val(ItemGrid.TextMatrix(ItemGrid.Row, 13)), Val(ItemGrid.TextMatrix(ItemGrid.Row, 8)) - Val(ItemGrid.TextMatrix(ItemGrid.Row, 4)) - Val(ItemGrid.TextMatrix(ItemGrid.Row, 13)))

Else

vQty = IIf(VoucherType = "PV", Val(ItemGrid.TextMatrix(ItemGrid.Row, 8)) - Val(ItemGrid.TextMatrix(ItemGrid.Row, 9)) - Val(ItemGrid.TextMatrix(ItemGrid.Row, 13)), Val(ItemGrid.TextMatrix(ItemGrid.Row, 8)) + Val(ItemGrid.TextMatrix(ItemGrid.Row, 9)) + Val(ItemGrid.TextMatrix(ItemGrid.Row, 13))) 'vQty = Stock +- OldQuantity +- FREE QTY

ItemGrid.TextMatrix(ItemGrid.Row, 3) = IIf(VoucherType = "PV", vQty + Val(ItemGrid.TextMatrix(ItemGrid.Row, 4)) + Val(ItemGrid.TextMatrix(ItemGrid.Row, 13)), vQty - Val(ItemGrid.TextMatrix(ItemGrid.Row, 4)) - Val(ItemGrid.TextMatrix(ItemGrid.Row, 13))) 'Stock = vQty +- NewQuantity +- FREE QTY

End If

ElseIf (ItemGrid.Col = 5 Or ItemGrid.Col = 6) Then

ItemGrid.TextMatrix(ItemGrid.Row, 6) = AmountValue(ItemGrid.TextMatrix(ItemGrid.Row, 4), ItemGrid.TextMatrix(ItemGrid.Row, 5))

Call ItemGrid_LostFocus

If TxtType.Text = "Other" Then SendKeys "{ENTER}": SendKeys "{ENTER}"

End If

If Expiry = True Or TxtType.Text = "Medicine" Then Call LeaveCellForMedicine

End Sub

Private Sub ItemGrid_LeaveCell()

On Error GoTo ErHand

LeaveCell

ErHand:

If err.Number = 0 Then Exit Sub

If err.Description = "Could not update; currently locked." Then '-2147467259

MsgBox "The record you are trying to save could not successful because required table is currently used by another module's transaction." & vbCrLf & vbCrLf & "Please finish the active transaction (Save/Cancel) in that module and then try again.", vbExclamation, "Table Locked"

rst.CancelUpdate

Call CancelCmd_Click

Exit Sub

Else

ErrHandler "PurchFrm.ItemGrid_LeaveCell"

End If

End Sub

Private Sub ItemGrid_LostFocus()

TotalLbl.Caption = Format(SumOfValues(6), "#0.#0")

End Sub

Private Sub ItemGrid_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Not EditMode Then Exit Sub

End Sub

Private Sub LastCmd_Click()

LastMove PurchaseRst

Call SetFieldsValues(PurchaseRst)

Call SetControls

End Sub

Private Sub MrnTxt_GotFocus()

SelectText MrnTxt

End Sub

Private Sub MrnTxt_Validate(Cancel As Boolean)

If Not (ADDMode) Then Exit Sub

If Len(Trim(MrnTxt)) <> 6 Then

MsgBox Label2(4).Caption & " must be of 6 character.", vbCritical, "Invalid Value"

Cancel = True

Exit Sub

End If

Dim SQL As String

Dim rst As New ADODB.Recordset

rst.CursorLocation = adUseClient

SQL = "SELECT * FROM PURCHASE WHERE VNO = '" & MrnTxt & "' AND VTYPE = '" & VoucherType & "'"

rst.Open SQL, Conn, adOpenForwardOnly, adLockReadOnly, adCmdText

If rst.RecordCount > 0 Then

MsgBox Label2(4).Caption & " is already exist. Please enter unique no.", vbCritical, "Invalid Value"

Cancel = True

Exit Sub

End If

End Sub

Private Sub NetAmtTxt_GotFocus()

SelectText NetAmtTxt

End Sub

Private Sub NetPayableAmount()

If TotalLbl.Caption = "" Then TotalLbl.Caption = 0

If CartTxt = "" Then CartTxt = 0#

If TaxTxt = "" Then TaxTxt = 0#

NetAmtTxt = Format(CSng(TotalLbl.Caption) + CartTxt + TaxTxt, "#0.#0")

End Sub

Private Sub NetAmtTxt_KeyPress(KeyAscii As Integer)

ValidateNumber KeyAscii

End Sub

Private Sub NetAmtTxt_Validate(Cancel As Boolean)

ValidateDesimal NetAmtTxt, Cancel, 2

End Sub

Private Sub NextCmd_Click()

NextMove PurchaseRst

Call SetFieldsValues(PurchaseRst)

Call SetControls

End Sub

Private Sub PrevCmd_Click()

PreviousMove PurchaseRst

Call SetFieldsValues(PurchaseRst)

Call SetControls

End Sub

Private Sub PrintCmd_Click()

On Error GoTo ErHand

Dim SQL As String

Set PrchRtrnRpt.DataSource = DE

PrchRtrnRpt.Sections("SaleCmd_Footer").Controls("lblRemark").Visible = Trim(Me.RmrkTxt) <> ""

PrchRtrnRpt.Sections("SaleCmd_Footer").Controls("lblRemark").Caption = Trim(Me.RmrkTxt)

PrchRtrnRpt.Sections("SaleCmd_Footer").Controls("Label14").Visible = Trim(Me.RmrkTxt) <> ""

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

DE.PurchConn.Open ShapeConnectString

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

SQL = "SHAPE {SELECT Purchase.VTYPE, Purchase.VNO, Purchase.VDATE, Purchase.ACCODE AS SUPPLIERCODE, Purchase.ACDESC AS SUPPLIER, Purchase.SUPP_INV_NO, ACMAST.ACDESC AS SUPPLIERNAME, Purchase.PROD_VALUE, Purchase.NET_PAYABLE, Purchase.CARTAGE, Purchase.TAX, Purchase.REMARK FROM Purchase LEFT JOIN ACMAST ON Purchase.ACCODE = ACMAST.ACCODE WHERE Purchase.VTYPE ='" & VoucherType & "' AND Purchase.VNO = '" & MrnTxt & "'} AS PurchRtrnCmd " & _

"APPEND ({SELECT Ledger.VTYPE, Ledger.VNO, Ledger.ICODE, ITEM.Item_Desc + SPACE(5) + ITEM.PACKING AS [Item_Desc], Ledger.QTY, Ledger.Rate, [Ledger].[Qty]*[Ledger].[Rate] AS Amount FROM Ledger LEFT JOIN ITEM ON Ledger.ICODE = ITEM.ItemCode;} AS PurchRtrnChileCmd RELATE 'VTYPE' TO 'VTYPE','VNO' TO 'VNO') AS PurchRtrnChileCmd"

DE.rsPurchRtrnCmd.Open SQL, DE.PurchConn

If PrintChk.Value = vbChecked Then PrchRtrnRpt.Show Else PrchRtrnRpt.PrintReport

ErHand:

ErrHandler "PurchaseFrm.CmdPrint"

End Sub

Private Sub SaveCmd_Click()

On Error Resume Next

If Not SavedData Then Exit Sub

Conn.CommitTrans

If ADDMode Then

VnoSrch.AddItem MrnTxt & "|" & MrnTxt & Space(5) & Trim(SuplTxt.Text)

EmptyTable = False

Else

VnoSrch.PopulateList

End If

PurchaseRst.Requery

If EditMode And Not IsEmpty(Bmark) Then PurchaseRst.Bookmark = Bmark

Call SetFieldsValues(PurchaseRst)

ADDMode = False

EditMode = False

Call SetControls

End Sub

Private Function SavedData() As Boolean

On Error GoTo ErrHand

If Not ValidateData Then Exit Function

Dim SavedRows, i As Integer

Dim SQL As String

For i = 1 To ItemGrid.Rows - 1

If Not (ItemGrid.TextMatrix(i, 1) = "" Or ItemGrid.TextMatrix(i, 2) = "" _

Or ItemGrid.TextMatrix(i, 3) = "" Or ItemGrid.TextMatrix(i, 4) = "" _

Or ItemGrid.TextMatrix(i, 5) = "" Or ItemGrid.TextMatrix(i, 6) = "" _

Or ItemGrid.TextMatrix(i, 7) = "") Then SavedRows = SavedRows + 1

Next i

If Not SavedRows > 0 Then

MsgBox "There is no items to save.", vbExclamation, "No Items"

ItemGrid.SetFocus

Exit Function

End If

Dim VoucherNo As String

Dim VoucherRst As New ADODB.Recordset

VoucherRst.CursorLocation = adUseClient

Dim PurchRst As New ADODB.Recordset

PurchRst.CursorLocation = adUseClient

Dim SRst As New ADODB.Recordset

SRst.CursorLocation = adUseClient

SRst.Open "SELECT MAX(ID) FROM PURCHASE", Conn, adOpenForwardOnly, adLockReadOnly, adCmdText

SrNo = IIf(IsNull(SRst(0)), 0, SRst(0)) + 1

VoucherNo = IIf(ADDMode, GetVoucherCode(), MrnTxt.Text)

'Saving data to purchase table

If ADDMode Then

SQL = "SELECT * FROM PURCHASE"

Else

SQL = "SELECT * FROM PURCHASE WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"

End If

PurchRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText

If ADDMode Then

PurchRst.AddNew

PurchRst!VType = VoucherType

PurchRst!ID = SrNo

PurchRst!Vno = VoucherNo

End If

PurchRst!vDate = VoucherDate.Value

PurchRst!AcCode = IIf(CashCB.ListIndex <= 0, "000030", SuplTxt.Tag)

PurchRst!AcDESC = Trim(SuplTxt)

PurchRst!SUPP_INV_NO = Trim(BillNoTxt)

PurchRst!SUPP_INV_DATE = IIf(BillDate.Value = "", Null, BillDate.Value)

PurchRst!PROD_VALUE = Val(TotalLbl.Caption)

PurchRst!NET_PAYABLE = Val(NetAmtTxt)

PurchRst!REMARK = Trim(RmrkTxt)

PurchRst!CARTAGE = Val(CartTxt)

PurchRst!Tax = Val(TaxTxt)

PurchRst.Update

'Saving data to voucher table

' SQL = "DELETE FROM VOUCHER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"

' Conn.Execute SQL

'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

If VoucherRst.State = adStateOpen Then VoucherRst.Close

VoucherRst.Open "VOUCHER", Conn, adOpenKeyset, adLockOptimistic, adCmdTable

VoucherRst.AddNew

VoucherRst!sno = GetVoucherID

VoucherRst!VType = VoucherType

VoucherRst!Vno = VoucherNo

VoucherRst!vDate = VoucherDate.Value

VoucherRst!AcCode = IIf(CashCB.ListIndex <= 0, "000030", SuplTxt.Tag) 'Cash Account

VoucherRst!ACContra = "000033"

VoucherRst!DrAmt = IIf(VoucherType = "PV", 0, NetAmtTxt)

VoucherRst!CrAmt = IIf(VoucherType = "PV", NetAmtTxt, 0)

VoucherRst!DrCr = IIf(VoucherType = "PV", "C", "D")

'voucherrst!NARR

VoucherRst.Update

VoucherRst.AddNew

VoucherRst!sno = GetVoucherID

VoucherRst!VType = VoucherType

VoucherRst!Vno = VoucherNo

VoucherRst!vDate = VoucherDate.Value

VoucherRst!AcCode = "000033"

VoucherRst!ACContra = IIf(CashCB.ListIndex <= 0, "000030", SuplTxt.Tag) 'Cash Account

VoucherRst!DrAmt = IIf(VoucherType = "PV", NetAmtTxt, 0)

VoucherRst!CrAmt = IIf(VoucherType = "PV", 0, NetAmtTxt)

VoucherRst!DrCr = IIf(VoucherType = "PV", "D", "C")

'voucherrst!NARR

VoucherRst.Update

'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

Dim LgrRst As New ADODB.Recordset

LgrRst.CursorLocation = adUseClient

'Saving data to ledger table

If EditMode Then

SQL = "SELECT * FROM LEDGER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"

LgrRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText

Do Until LgrRst.EOF

SQL = "UPDATE ITEMSIZE SET STOCK = STOCK " & IIf(VoucherType = "PV", "-" & IIf(IsNull(LgrRst!free), 0, LgrRst!free) & "-", "+" & IIf(IsNull(LgrRst!free), 0, LgrRst!free) & "+") & IIf(IsNull(LgrRst!Qty), 0, LgrRst!Qty) & " WHERE ICODE = '" & LgrRst!ICODE & "' AND ISIZE = " & LgrRst!ISIZE

Conn.Execute SQL

LgrRst.MoveNext

Loop

SQL = "DELETE FROM LEDGER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & VoucherNo & "'"

Conn.Execute SQL

End If

If LgrRst.State = adStateOpen Then LgrRst.Close

LgrRst.Open "LEDGER", Conn, adOpenKeyset, adLockOptimistic, adCmdTable

With ItemGrid

For i = 1 To .Rows - 1

If Not (.TextMatrix(i, 1) = "" Or .TextMatrix(i, 2) = "" _

Or .TextMatrix(i, 3) = "" Or .TextMatrix(i, 4) = "" _

Or .TextMatrix(i, 5) = "" Or .TextMatrix(i, 6) = "" _

Or .TextMatrix(i, 7) = "") Then

LgrRst.AddNew

LgrRst!ID = GetLedgerID

LgrRst!VType = VoucherType

LgrRst!Vno = VoucherNo

LgrRst!vDate = VoucherDate.Value

LgrRst!ISIZE = .TextMatrix(i, 2)

LgrRst!Qty = .TextMatrix(i, 4)

LgrRst!Rate = .TextMatrix(i, 5)

LgrRst!ICODE = .TextMatrix(i, 7)

If Expiry = True And TxtType.Text = "Medicine" Then LgrRst!free = IIf(.TextMatrix(i, 13) = "", 0, .TextMatrix(i, 13))

LgrRst.Update

If Expiry = True And TxtType.Text = "Medicine" Then Conn.Execute ("insert into PurchaseDetail values('" & VoucherNo & "','" & "PV" & "','" & .TextMatrix(i, 7) & "','" & .TextMatrix(i, 11) & "','" & .TextMatrix(i, 12) & "','" & .TextMatrix(i, 4) & "','" & .TextMatrix(i, 10) & "')")

SQL = "UPDATE ITEMSIZE SET STOCK = STOCK " & IIf(VoucherType = "PV", "+", "-") & .TextMatrix(i, 4) & " WHERE ICODE = '" & .TextMatrix(i, 7) & "' AND ISIZE = " & .TextMatrix(i, 2)

Conn.Execute SQL

End If

Next i

End With

SavedData = True

Exit Function

ErrHand:

ErrHandler "Function PurchFrm.SavedData"

End Function

Private Function ValidateData() As Boolean

If CashCB.ListIndex = -1 Then

MsgBox "Please Select Cash or Credit.", vbExclamation, "Invalid Value"

CashCB.SetFocus

ElseIf CashCB.ListIndex = 1 And Trim(SuplTxt.Tag) = "" Then

MsgBox "Please Select supplier name from list.", vbExclamation, "Invalid Value"

SuplTxt.SetFocus

ElseIf Not IsDate(VoucherDate.Value) Then

MsgBox "Please enter voucher Date.", vbExclamation, "Invalid Value"

VoucherDate.SetFocus

ElseIf EditMode And MrnTxt.Tag = "" Then

MsgBox "Please select voucher no.", vbExclamation, "Invalid Value"

MrnTxt.SetFocus

Else

ValidateData = True

End If

End Function

Private Sub ItemGrid_KeyPress(KeyAscii As Integer)

If KeyAscii = 13 Then

If Not (ItemGrid.TextMatrix(ItemGrid.Row, 1) = "" Or _

ItemGrid.TextMatrix(ItemGrid.Row, 2) = "" Or _

ItemGrid.TextMatrix(ItemGrid.Row, 3) = "" Or _

ItemGrid.TextMatrix(ItemGrid.Row, 4) = "" Or _

ItemGrid.TextMatrix(ItemGrid.Row, 5) = "" Or _

ItemGrid.TextMatrix(ItemGrid.Row, 6) = "") Then

ItemGrid.TextMatrix(ItemGrid.Row, 0) = ItemGrid.Row

ItemGrid.CreateNewRows = True

Else

ItemGrid.CreateNewRows = False

End If

ElseIf ItemGrid.Col = 2 Or ItemGrid.Col = 3 Or ItemGrid.Col = 4 Or ItemGrid.Col = 5 Or ItemGrid.Col = 13 Then

If Not (InStr(".0123456789", Chr(KeyAscii)) > 0) And KeyAscii <> 8 Then KeyAscii = 0

End If

End Sub

Private Function SumOfValues(ByVal GridCol As Integer) As Double

Dim i, vSumVal As Double

If Not ItemGrid.Cols > GridCol Then Exit Function

For i = 1 To ItemGrid.Rows - 1

ItemGrid.TextMatrix(i, 6) = AmountValue(ItemGrid.TextMatrix(i, 4), ItemGrid.TextMatrix(i, 5))

If ItemGrid.TextMatrix(i, GridCol) = "" Then ItemGrid.TextMatrix(i, GridCol) = "0"

If Not IsNumeric(ItemGrid.TextMatrix(i, GridCol)) Then ItemGrid.TextMatrix(i, GridCol) = "0"

vSumVal = vSumVal + ItemGrid.TextMatrix(i, GridCol)

Next i

SumOfValues = Format(vSumVal, "#0.#0")

End Function

Private Function AmountValue(ByVal Rate, ByVal Qty) As String

Dim vVal As Double

If Rate = "" Then Rate = 0

If Qty = "" Then Qty = 0

If Not IsNumeric(Rate) Then Rate = 0

If Not IsNumeric(Qty) Then Qty = 0

vVal = Rate * Qty

AmountValue = Format(vVal, "#0.#0")

End Function

Private Function GetVoucherCode() As String

Dim RS As New ADODB.Recordset

Dim SQL As String

SQL = "Select Max(substring(VNO,2,len(VNO)-1)) From PURCHASE WHERE LEFT(VNO,1) = '" & IIf(CashCB.ListIndex <= 0, "C", "R") & "' AND VTYPE = '" & VoucherType & "'"

RS.Open SQL, Conn, adOpenDynamic, adLockOptimistic

GetVoucherCode = IIf(CashCB.ListIndex <= 0, "C", "R") & GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 5)

End Function

Private Sub TaxTxt_Change()

Call NetPayableAmount

End Sub

Private Sub TaxTxt_GotFocus()

SelectText TaxTxt

End Sub

Private Sub TaxTxt_KeyPress(KeyAscii As Integer)

ValidateNumber KeyAscii

End Sub

Private Sub TaxTxt_Validate(Cancel As Boolean)

ValidateDesimal TaxTxt, Cancel, 2

TaxTxt = Format(TaxTxt, "#0.#0")

End Sub

Private Sub TopCmd_Click()

TopMove PurchaseRst

Call SetFieldsValues(PurchaseRst)

Call SetControls

End Sub

Private Sub TotalLbl_Change()

Call NetPayableAmount

End Sub

Private Sub SetFieldsValues(ByVal rst As ADODB.Recordset)

On Error GoTo ErrHand

Dim rstDetail As New ADODB.Recordset

Dim ItemDetailString As String

Dim ItemString As String

Dim ItemRst As New ADODB.Recordset

ItemRst.CursorLocation = adUseClient

If Not rst.RecordCount > 0 Then Exit Sub

If rst.BOF Then rst.MoveFirst

If rst.EOF Then rst.MoveLast

CashCB.ListIndex = IIf(Left(rst!Vno, 1) = "C", 0, 1)

MrnTxt = rst!Vno

SuplTxt = rst!AcDESC

SuplTxt.Tag = rst!AcCode

VoucherDate = rst!vDate

DayLbl = Format(rst!vDate, "dddd")

BillNoTxt = IIf(IsNull(rst!SUPP_INV_NO), "", rst!SUPP_INV_NO)

BillDate = IIf(IsNull(rst!SUPP_INV_DATE), "", rst!SUPP_INV_DATE)

RmrkTxt = IIf(IsNull(rst!REMARK), "", rst!REMARK)

CartTxt = Format(IIf(IsNull(rst!CARTAGE), 0, rst!CARTAGE), "#0.#0")

TaxTxt = Format(IIf(IsNull(rst!Tax), 0, rst!Tax), "#0.#0")

TotalLbl = Format(rst!PROD_VALUE, "#0.#0")

NetAmtTxt = Format(rst!NET_PAYABLE, "#0.#0")

Set ItemRst = rst("Items").UnderlyingValue

Set rstDetail = New ADODB.Recordset

If Not ItemRst.EOF Then

rstDetail.Open "select * from PurchaseDetail Where VType='" & ItemRst!VType & "' And VNO='" & ItemRst!Vno & "'", Conn, adOpenDynamic, adLockBatchOptimistic

If Not rstDetail.EOF Then TxtType.Text = "Medicine" Else TxtType.Text = "Other"

Call TxtType_Click

End If

ItemGrid.Rows = 1

If Not ItemRst.RecordCount > 0 Then ItemGrid.AddItem "" 'Add a blank row if Item not found

Do Until ItemRst.EOF

Set rstDetail = New ADODB.Recordset

rstDetail.Open "select * from PurchaseDetail Where VType='" & ItemRst!VType & "' And VNO='" & ItemRst!Vno & "' And ProductCode='" & ItemRst!ICODE & "'", Conn, adOpenDynamic, adLockBatchOptimistic

If Not rstDetail.EOF Then

ItemDetailString = vbTab & rstDetail!BatchNo & vbTab & Format(rstDetail!ExpDate, "dd-mm-yyyy") & vbTab & Format(rstDetail!Mfgdate, "dd-mm-yyyy") & vbTab & ItemRst!free

End If

ItemString = ItemRst.AbsolutePosition & vbTab

ItemString = ItemString & ItemRst!ITEM_DESC & vbTab

ItemString = ItemString & ItemRst!ISIZE & vbTab

ItemString = ItemString & ItemRst!STOCK & vbTab

ItemString = ItemString & ItemRst!Qty & vbTab

ItemString = ItemString & ItemRst!Rate & vbTab

ItemString = ItemString & Format(ItemRst!amount, "#0.#0") & vbTab

ItemString = ItemString & ItemRst!ICODE & vbTab

ItemString = ItemString & ItemRst!STOCK & vbTab

ItemString = ItemString & ItemRst!Qty

ItemString = ItemString & ItemDetailString

ItemGrid.AddItem ItemString

ItemRst.MoveNext

Loop

ItemGrid.RefreshEditor

Exit Sub

ErrHand:

ErrHandler "Function PurchFrm.SavedData"

End Sub

Private Sub ClearFields()

CashCB.ListIndex = 0

MrnTxt = ""

SuplTxt = ""

SuplTxt.Tag = ""

VoucherDate = Date

DayLbl = ""

BillNoTxt = ""

BillDate = ""

RmrkTxt = ""

CartTxt = ""

TaxTxt = ""

TotalLbl = ""

NetAmtTxt = ""

'Call SetGridProps

Call TxtType_Click

End Sub

Private Sub vMenu_Click()

If Not EditMode Then Exit Sub

If ItemGrid.Rows > 2 Then

ItemGrid.RemoveItem ItemGrid.Row

Else

ItemGrid.Rows = 1

ItemGrid.AddItem ""

End If

ItemGrid.RefreshEditor

End Sub

Private Sub VnoSrch_ValidateBoundTextBox()

Dim BeforeSearchBmark

BeforeSearchBmark = PurchaseRst.Bookmark

PurchaseRst.MoveFirst

PurchaseRst.Find "VNO='" & MrnTxt & "'"

If PurchaseRst.EOF Then

MsgBox "Voucher No. not found.", vbCritical, "Invalid Voucher No."

PurchaseRst.Bookmark = BeforeSearchBmark

Else

Bmark = PurchaseRst.Bookmark

Call SetFieldsValues(PurchaseRst)

End If

End Sub

Private Sub DeleteVoucher()

Dim SQL As String

Dim LgrRst As New ADODB.Recordset

LgrRst.CursorLocation = adUseClient

SQL = "SELECT * FROM LEDGER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & MrnTxt & "'"

LgrRst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText

Do Until LgrRst.EOF

Conn.Execute SQL

LgrRst.MoveNext

Loop

'Delete from purchase

SQL = "DELETE FROM PURCHASE WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & MrnTxt & "'"

Conn.Execute SQL

'Delete from Ledger

SQL = "DELETE FROM LEDGER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & MrnTxt & "'"

Conn.Execute SQL

'Delete from Voucher

SQL = "DELETE FROM VOUCHER WHERE VTYPE = '" & VoucherType & "' AND VNO = '" & MrnTxt & "'"

Conn.Execute SQL

'Delete From Medicine Detail Table

SQL = "DELETE FROM PurchaseDetail WHERE VTYPE ='" & VoucherType & "' AND VNO = '" & MrnTxt & "'"

Conn.Execute SQL

End Sub

Private Sub VoucherDate_Validate(Cancel As Boolean)

If Not (ADDMode Or EditMode) Then Exit Sub

If Not IsInFinancialYear(VoucherDate) Then

MsgBox "This date is not of the current financial year", vbCritical, "Invalid Date"

Cancel = True

VoucherDate.SetFocus

Else

DayLbl = Format(VoucherDate, "dddd")

End If

End Sub

Private Sub ItemGrid_KeyDown(KeyCode As Integer, Shift As Integer)

If Not (ADDMode Or EditMode) Or Shift = 0 Then Exit Sub

If KeyCode = 40 Then

If Shift = vbCtrlMask Then ItemSrch.MoveNext

ElseIf KeyCode = 38 Then

If Shift = vbCtrlMask Then ItemSrch.MovePrevious

End If

End Sub

Private Sub Timer1_Timer()

On Error Resume Next

If Not ItemGrid.ShowEditor Then Exit Sub

If Not (ActiveControl.Name = "ItemGrid") Then

If ItemSrch.ListVisible Then ItemSrch.HideList

ElseIf (ActiveControl.Name = "ItemGrid") Then

If (ItemGrid.Col = 1) Then

If Not ItemSrch.ListVisible Then

ItemSrch.ShowList 490, 10

If ActiveControl.Name = "ItemGrid" Then ItemGrid.SetFocus

End If

Else

If ItemSrch.ListVisible Then ItemSrch.HideList

End If

End Sub

Private Sub TxtType_Click()

With ItemSrch

.DBConnectString = ConnectString

If Expiry = False Or TxtType.Text = "Other" Then

.SQLString = "SELECT ItemCode, Item_Desc + space(3) + ' -> Packing =' + Packing FROM ITEM where IGCode <> '0001'"

Call SetGridProps

Else

.SQLString = "SELECT ItemCode, Item_Desc + space(3) + ' -> Packing =' + Packing FROM ITEM where IGCode = '0001'"

Call SetGridPropsForMedicine

End If

.PopulateList

End With

End Sub

Public Sub LeaveCellForMedicine()

If ItemGrid.Col = 1 And Not ItemSrch.SelectedCompany = "" Then

ItemGrid.TextMatrix(ItemGrid.Row, 11) = Format(Date, "dd-MMM-yyyy")

ItemGrid.TextMatrix(ItemGrid.Row, 12) = Format(Date, "dd-MMM-yyyy")

ElseIf ItemGrid.Col = 11 Then

If IsDate(ItemGrid.TextMatrix(ItemGrid.Row, 11)) = False Then MsgBox "Invalid Expire Date,Please Enter Date Like [01-JUN-2004]", vbCritical + vbDefaultButton1

ElseIf ItemGrid.Col = 12 Then

If IsDate(ItemGrid.TextMatrix(ItemGrid.Row, 12)) = False Then MsgBox "Invalid Mfg. Date,Please Enter Date Like [01-JUN-2004]", vbCritical + vbDefaultButton1

End If

End Sub

'***************************************** EnhanceMent By Sameeullah *********************

Private Sub SetGridPropsForMedicine(Optional Rows As Integer)

With ItemGrid

.Clear

.Rows = IIf(Rows <= 1, 2, Rows)

.ColWidth(1) = TextWidth("A") * 40 'PARTICULARS

.ColWidth(2) = TextWidth("A") * 8 'Packing

.ColWidth(3) = TextWidth("A") * 8 'Stock

.ColWidth(4) = TextWidth("A") * 8 'QUANTITY

.ColWidth(5) = TextWidth("A") * 8 'RATE

.ColWidth(6) = TextWidth("A") * 15 'AMOUNT

.ColWidth(7) = TextWidth("A") * 0 'Item Code

.ColWidth(8) = TextWidth("A") * 0 'Stock

.ColWidth(9) = TextWidth("A") * 0 'Old Quantity

.ColWidth(10) = TextWidth("A") * 8 'Batch Number

.ColWidth(11) = TextWidth("A") * 10 'Exp Date

.ColWidth(12) = TextWidth("A") * 10 'Mfg Date

.ColWidth(13) = TextWidth("A") * 8 'Free

.EnableEditing(3) = False 'Stock

.EnableEditing(6) = False 'Amount

.EnableEditing(7) = False 'Item Code

.EnableEditing(8) = False 'Stock

.EnableEditing(9) = False 'Old Quantity

.NumbersOnly(2, 3, 50) = True

.NumbersOnly(3, 7) = True

.NumbersOnly(4, 4) = True

.NumbersOnly(5, 6) = True

.NumbersOnly(6, 10) = True

End With

ItemGrid.Refresh

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", RS(0) + 1), 6) Else GetVoucherID = GetProperCode("1", 6)

End Function

Private Function GetLedgerID() As String

Dim RS As New ADODB.Recordset

RS.Open "Select Max(ID) From LEDGER", Conn, adOpenDynamic, adLockOptimistic

If Not RS.EOF Then GetLedgerID = GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 6) Else GetLedgerID = GetProperCode("1", 6)

End Function