Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
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
.FormatString = "S No.|<Item Particulars|>Packing|>Stock|>Qty|>Rate|>Amount|IID|Stock|OldQty"
.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
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
'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 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
.FormatString = "S No.|<Item Particulars|>Packing|>Stock|>Qty|>Rate|>Amount|IID|Stock|OldQty|>BatchNo|>Exp. Date|>Mfg. Date|>Free"
.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