Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
Development of Front-End
Account Form
Dim Conn1 As ADODB.Connection
Dim ACRst As ADODB.Recordset
Dim GroupRst As ADODB.Recordset
Dim ADDMode As Boolean
Dim EditMode As Boolean
Dim EmptyTable As Boolean
Dim Bmark As Variant
Private Sub AcDescTxt_LostFocus()
If EditMode Then AcSrch.HideList
End Sub
Private Sub AcDescTxt_Validate(Cancel As Boolean)
If Not (ADDMode Or EditMode) Then Exit Sub
If Trim(AcDescTxt) = "" Then Exit Sub
Dim SQL As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
SQL = "SELECT * FROM ACMAST WHERE ACDESC = '" & Trim(AcDescTxt) & "' AND ACCODE <> '" & AcDescTxt.Tag & "'"
rst.Open SQL, Conn1, adOpenForwardOnly, adLockReadOnly, adCmdText
If rst.RecordCount > 0 Then
MsgBox "The account name could not be save because it will create duplicate entry in account description field.", vbCritical, "Duplicate Account Name"
Cancel = True
End If
End Sub
Private Sub AddCmd_Click()
ADDMode = True
Call ClearFields
Call SetControls
AcDescTxt.SetFocus
End Sub
Private Sub AliasTxt_Validate(Cancel As Boolean)
If Not (ADDMode Or EditMode) Then Exit Sub
If Trim(AliasTxt) = "" Then Exit Sub
Dim SQL As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
SQL = "SELECT * FROM ACMAST WHERE ACALIAS = '" & Trim(AliasTxt) & "' AND ACCODE <> '" & AcDescTxt.Tag & "'"
rst.Open SQL, Conn1, adOpenForwardOnly, adLockReadOnly, adCmdText
If rst.RecordCount > 0 Then
MsgBox "The account alias could not be save because it will create duplicate entry in alias field.", vbCritical, "Duplicate Alias"
Cancel = True
End If
End Sub
Private Sub CancelCmd_Click()
ADDMode = False
EditMode = False
Call SetControls
End Sub
Private Sub DelCmd_Click()
Conn.Execute "Delete from ACMAST where ACCode='" & Me.AcDescTxt.Tag & "'"
End Sub
Private Sub EditCmd_Click()
EditMode = True
AccLbl.Tag = ""
AccLbl.Caption = ""
AcSrch.SearchValue AcDescTxt
SelectText AcDescTxt
Call SetControls
End Sub
Private Sub ExitCmd_Click()
Unload Me
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If Not (Me.ActiveControl.Name = "GrpTxt") And KeyCode = vbKeyReturn Then
If Not (EditMode And Me.ActiveControl.Name = "AcDescTxt") Then
SendKeys "{TAB}"
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
End If
End Sub
Private Sub Form_Load()
Dim SQL As String
Set Conn1 = New ADODB.Connection
Conn1.CursorLocation = adUseClient
Conn1.Open ConnectString
Set ACRst = New ADODB.Recordset
ACRst.CursorLocation = adUseClient
GrpSrch.DBConnectString = ConnectString
GrpSrch.SQLString = "SELECT ACCODE, ACDESC, ACALIAS FROM ACMAST WHERE RECTYPE = 'G' ORDER BY ACDESC"
GrpSrch.Title = "Group List"
GrpSrch.FindExactMatch = False
GrpSrch.ReturnField = vCompanyName
Set GrpSrch.BoundTextBox = GrpTxt
GrpSrch.PopulateList
AcSrch.DBConnectString = ConnectString
AcSrch.SQLString = "SELECT ACCODE, ACDESC, ACALIAS FROM ACMAST WHERE RECTYPE = 'A' ORDER BY ACDESC"
AcSrch.Title = "Account List"
AcSrch.ReturnField = vCompanyName
AcSrch.FindExactMatch = False
AcSrch.PopulateList
SQL = "SELECT AC.MODIFY, AC.ACCODE, AC.ACDESC, AC.GRCODE, AC.GROUPDESC, AC.ACALIAS, AC.RECTYPE, AC.CASH, AC.ACTYPE, AC.[LEVEL], AC.BSHEET, AcTrans.CLOSING, AcTrans.YOBDR, AcTrans.YOBCR, AcTrans.Cr_Dr, AD.CONTACT, AD.ADDRESS, AD.CSTNO, AD.CSTDT, AD.LSTDT, AD.LSTNO, AD.PH_O, AD.PH_R, AD.FAX, AD.EMAIL FROM (ACCOUNTS AS AC LEFT JOIN AcTrans ON AC.ACCODE = AcTrans.Accode) LEFT JOIN ADDRESS AS AD ON AC.ACCODE = AD.ACCODE ORDER BY AC.ACCODE DESC"
ACRst.Open SQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
If Not (ACRst.RecordCount > 0) Then
EmptyTable = True
Else
Call SetFieldsValues(ACRst)
End If
Call SetControls
End Sub
Private Sub SetControls()
AcFrame.Enabled = (ADDMode Or EditMode)
AddFrame.Enabled = (ADDMode Or EditMode)
AddCmd.Enabled = Not (ADDMode Or EditMode)
EditCmd.Enabled = Not (EmptyTable Or ADDMode Or EditMode)
SaveCmd.Enabled = (ADDMode Or EditMode)
CancelCmd.Enabled = (ADDMode Or EditMode)
CancelCmd.Cancel = (ADDMode Or EditMode)
DelCmd.Enabled = (Not EmptyTable) And (ADDMode Or EditMode)
ExitCmd.Enabled = Not (ADDMode Or EditMode)
ExitCmd.Cancel = Not (ADDMode Or EditMode)
TopCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (ACRst.AbsolutePosition > 1)
PrevCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (ACRst.AbsolutePosition > 1)
NextCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (ACRst.AbsolutePosition < ACRst.RecordCount)
LastCmd.Enabled = (Not (EmptyTable Or ADDMode Or EditMode)) And (ACRst.AbsolutePosition < ACRst.RecordCount)
If Not (ADDMode Or EditMode) Then AcSrch.HideList
AccLbl.Visible = False
EdLbl.Visible = False
AccLbl.Caption = ""
AccLbl.Tag = ""
End Sub
Private Sub AcDescTxt_KeyDown(KeyCode As Integer, Shift As Integer)
Dim Trst As New ADODB.Recordset
Trst.CursorLocation = adUseClient
If Not EditMode Then Exit Sub
If KeyCode = 13 Then
If EditMode And AccLbl.Caption = "" And AcSrch.SelectedCompany <> "" Then
EdLbl.Visible = True
AccLbl.Visible = True
AccLbl.Caption = AcSrch.SelectedCompany
AccLbl.Tag = AcSrch.UniqueCode
AcSrch.HideList
AcDescTxt.Text = AccLbl.Caption
AcDescTxt.Tag = AcSrch.UniqueCode
SelectText AcDescTxt
Bmark = ACRst.Bookmark
ACRst.MoveFirst
ACRst.Find "ACCODE = '" & AccLbl.Tag & "'"
If ACRst.EOF Then
MsgBox "Please select a valid account to edit.", vbCritical, "Invalid Account"
ACRst.Bookmark = Bmark
Else
Call SetFieldsValues(ACRst)
End If
Else
SendKeys "{TAB}"
End If
ElseIf KeyCode = 40 And Shift = vbCtrlMask Then 'IF downarrow key withe ctrl
AcSrch.MoveNext
ElseIf KeyCode = 38 And Shift = vbCtrlMask Then 'IF uparrow key withe ctrl
AcSrch.MovePrevious
ElseIf KeyCode = 27 Then
If EditMode Then
AcDescTxt.Text = ""
AccLbl.Caption = ""
AccLbl.Tag = ""
EdLbl.Visible = False
AccLbl.Visible = False
AcSrch.ShowList 490, 10
End If
End If
End Sub
Private Sub SetAddressFields(ByVal vAccode As String)
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open "SELECT * FROM ADDRESS WHERE ACCODE = '" & vAccode & "'", Conn1, adOpenForwardOnly, adLockReadOnly, adCmdText
If Not (rst.RecordCount > 0) Then Exit Sub
'Address Fields
txtContact.Text = IIf(IsNull(rst!Contact), "", rst!Contact)
txtAddress.Text = IIf(IsNull(rst!Address), "", rst!Address)
txtCSTNo.Text = IIf(IsNull(rst!CstNo), "", rst!CstNo)
DtCst.Value = IIf(IsNull(rst!CSTDT), "", rst!CSTDT)
txtLST.Text = IIf(IsNull(rst!LstNo), "", rst!LstNo)
dtLst.Value = IIf(IsNull(rst!LSTDT), "", rst!LSTDT)
txtPh_o.Text = IIf(IsNull(rst!Ph_O), "", rst!Ph_O)
txtph_r.Text = IIf(IsNull(rst!Ph_R), "", rst!Ph_R)
txtFax.Text = IIf(IsNull(rst!Fax), "", rst!Fax)
MailTxt.Text = IIf(IsNull(rst!Email), "", rst!Email)
End Sub
Private Sub AcDescTxt_GotFocus()
If EditMode Then
AcSrch.ShowList 490, 10
End If
End Sub
Private Sub AcDescTxt_Change()
If EditMode And AccLbl.Caption = "" Then
AcSrch.SearchValue AcDescTxt
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
ACRst.Close
Set ACRst = Nothing
GroupRst.Close
Set GroupRst = Nothing
Conn1.Close
Set Conn1 = Nothing
End Sub
Private Sub GrpSrch_ValidateBoundTextBox()
Dim vCash As String
If GrpTxt.Tag = "" Then Exit Sub
If GroupRst Is Nothing Then Set GroupRst = New ADODB.Recordset
If GroupRst.State = adStateOpen Then GroupRst.Close
GroupRst.CursorLocation = adUseClient
GroupRst.Open "SELECT * FROM ACMAST WHERE ACCODE = '" & GrpTxt.Tag & "'", Conn1, adOpenForwardOnly, adLockOptimistic, adCmdText
If GroupRst.RecordCount = 1 Then
vCash = IIf(IsNull(GroupRst!CASH), "", GroupRst!CASH)
AddFrame.Enabled = (vCash = "R" Or vCash = "P" Or vCash = "B")
Else
MsgBox "Selected Group detail not found.", vbCritical, "Invalid Group"
End If
End Sub
Private Sub LastCmd_Click()
LastMove ACRst
Call SetFieldsValues(ACRst)
Call SetControls
End Sub
Private Sub NextCmd_Click()
NextMove ACRst
Call SetFieldsValues(ACRst)
Call SetControls
End Sub
Private Sub OpBalTxt_GotFocus()
SelectText OpBalTxt
End Sub
Private Sub OpBalTxt_KeyPress(KeyAscii As Integer)
ValidateNumber KeyAscii
End Sub
Private Sub OpBalTxt_Validate(Cancel As Boolean)
ValidateDesimal OpBalTxt, Cancel, 2
End Sub
Private Sub PrevCmd_Click()
PreviousMove ACRst
Call SetFieldsValues(ACRst)
Call SetControls
End Sub
Private Sub SaveCmd_Click()
If Not SavedData Then Exit Sub
If ADDMode Then EmptyTable = False
ADDMode = False
EditMode = False
EdLbl.Visible = False
AccLbl.Visible = False
Call SetControls
End Sub
Private Sub TopCmd_Click()
TopMove ACRst
Call SetFieldsValues(ACRst)
Call SetControls
End Sub
Private Sub SetFieldsValues(ByVal rst As ADODB.Recordset)
If Not (rst.RecordCount > 0) Then Exit Sub
If rst.BOF Then rst.MoveFirst
If rst.EOF Then rst.MoveNext
Dim OPBal As Single
'Account Fields
AcDescTxt.Tag = rst!AcCode
AcDescTxt.Text = rst!AcDESC
AliasTxt.Text = IIf(IsNull(rst!ACALIAS), "", rst!ACALIAS)
GrpTxt.Text = IIf(IsNull(rst!GROUPDESC), "", rst!GROUPDESC)
GrpTxt.Tag = IIf(IsNull(rst!GrCode), "", rst!GrCode)
'Actrans Fields
If rst!Cr_Dr = "D" Then
OPBal = IIf(IsNull(rst!YOBDR), 0, rst!YOBDR)
Else
OPBal = IIf(IsNull(rst!YOBCR), 0, rst!YOBCR)
End If
OpBalTxt = Format(OPBal, "0#.00##")
DrCrCB.ListIndex = IIf(rst!Cr_Dr = "D", 0, 1)
'Address Fields
txtContact.Text = IIf(IsNull(rst!Contact), "", rst!Contact)
txtAddress.Text = IIf(IsNull(rst!Address), "", rst!Address)
txtCSTNo.Text = IIf(IsNull(rst!CstNo), "", rst!CstNo)
DtCst.Value = IIf(IsNull(rst!CSTDT), "", rst!CSTDT)
txtLST.Text = IIf(IsNull(rst!LstNo), "", rst!LstNo)
dtLst.Value = IIf(IsNull(rst!LSTDT), "", rst!LSTDT)
txtPh_o.Text = IIf(IsNull(rst!Ph_O), "", rst!Ph_O)
txtph_r.Text = IIf(IsNull(rst!Ph_R), "", rst!Ph_R)
txtFax.Text = IIf(IsNull(rst!Fax), "", rst!Fax)
MailTxt.Text = IIf(IsNull(rst!Email), "", rst!Email)
End Sub
Private Function SavedData() As Boolean
On Error GoTo SaveError
Dim SQL, ACSQL, vCash, TransSQL As String
If DrCrCB.ListIndex < 0 Then DrCrCB.ListIndex = 0
OpBalTxt.Text = IIf(Trim(OpBalTxt.Text) = "", 0, OpBalTxt.Text)
'Generate new account code and set to AcDescTxt.Tag
If ADDMode Then AcDescTxt.Tag = GetAccountCode
If Trim(AcDescTxt.Text) = "" Or AcDescTxt.Tag = "" Then
MsgBox "Please, Enter the Account Description.", vbExclamation, "Empty Value..."
AcDescTxt.SetFocus
Exit Function
End If
If (GroupRst Is Nothing) Or (Trim(GrpTxt.Text)) = "" Or (GrpTxt.Tag = "") Then
MsgBox "Please, Enter a valid Group Description.", vbExclamation, "Empty Value..."
GrpTxt.SetFocus
Exit Function
End If
vCash = IIf(IsNull(GroupRst!CASH), "", GroupRst!CASH)
'Begin a new transaction
Conn1.BeginTrans
If Not (GroupRst.RecordCount > 0) Then
MsgBox "Account Group detail not found. Please make sure entered group is available in the Group List.", vbCritical, "Invalid Account Group"
Exit Function
End If
If ADDMode Then
ACSQL = "SELECT * FROM ACMAST"
TransSQL = "SELECT * FROM AcTrans"
ElseIf EditMode Then
ACSQL = "SELECT * FROM ACMAST WHERE ACCODE = '" & AcDescTxt.Tag & "'"
TransSQL = "SELECT * FROM AcTrans WHERE ACCODE = '" & AcDescTxt.Tag & "'"
End If
Dim AccountRst As New ADODB.Recordset
AccountRst.CursorLocation = adUseClient
AccountRst.Open ACSQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
If ADDMode Then AccountRst.AddNew
AccountRst!Modify = "Y"
AccountRst!AcCode = AcDescTxt.Tag
AccountRst!AcDESC = Trim(AcDescTxt.Text)
AccountRst!ACALIAS = IIf(Trim(AliasTxt.Text) = "", Null, Trim(AliasTxt.Text))
AccountRst!RECTYPE = "A"
AccountRst!CASH = Trim(IIf(IsNull(GroupRst!CASH), "", GroupRst!CASH))
AccountRst!GrCode = Trim(IIf(IsNull(GroupRst!AcCode), "", GroupRst!AcCode))
AccountRst!ACTYPE = Trim(IIf(IsNull(GroupRst!ACTYPE), "", GroupRst!ACTYPE))
AccountRst!Level = IIf(IsNull(GroupRst!Level), "", GroupRst!Level + 1)
AccountRst!bsheet = 0
AccountRst.Update
'Delete old address information
Conn1.Execute "DELETE FROM ADDRESS WHERE ACCODE = '" & AcDescTxt.Tag & "'"
If (vCash = "R" Or vCash = "P" Or vCash = "B") Then
Dim AddRst As New ADODB.Recordset
AddRst.CursorLocation = adUseClient
AddRst.Open "ADDRESS", Conn1, adOpenKeyset, adLockOptimistic, adCmdTable
AddRst.AddNew
AddRst!AcCode = AcDescTxt.Tag
AddRst!Contact = txtContact.Text
AddRst!Address = txtAddress.Text
AddRst!CstNo = txtCSTNo.Text
AddRst!CSTDT = IIf(IsDate(DtCst.Value), DtCst.Value, Null)
AddRst!LstNo = txtLST.Text
AddRst!LSTDT = IIf(IsDate(dtLst.Value), dtLst.Value, Null)
AddRst!Ph_O = txtPh_o.Text
AddRst!Ph_R = txtph_r.Text
AddRst!Fax = txtFax.Text
AddRst!Email = MailTxt.Text
AddRst.Update
End If
'Saveing Value to AcTrans
Dim OldClosing As Double
Dim TransRst As New ADODB.Recordset
TransRst.CursorLocation = adUseClient
TransRst.Open TransSQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
If ADDMode Then 'Add a new record
TransRst.AddNew
TransRst!AcCode = AcDescTxt.Tag
TransRst!CLOSING = IIf(UCase(Left(DrCrCB.Text, 1)) = "D", IIf(OpBalTxt.Text = "", 0, CDbl(OpBalTxt.Text)), IIf(OpBalTxt.Text = "", 0, -CDbl(OpBalTxt.Text)))
ElseIf EditMode Then 'Edit balance field
If TransRst.RecordCount = 1 Then
OldClosing = IIf(TransRst!Cr_Dr = "D", TransRst!YOBDR, TransRst!YOBCR)
Call BalancePost(EditPosting, OldClosing, IIf(IsNull(TransRst!Cr_Dr) = True, "C", TransRst!Cr_Dr), AcDescTxt.Tag, Conn1)
Set TransRst = New ADODB.Recordset
TransRst.CursorLocation = adUseClient
TransRst.Open TransSQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
ElseIf TransRst.RecordCount <= 0 Then 'Add a new record if record not available in EditMode
TransRst.AddNew
TransRst!AcCode = AcDescTxt.Tag
TransRst!CLOSING = IIf(UCase(Left(DrCrCB.Text, 1)) = "D", IIf(OpBalTxt.Text = "", 0, OpBalTxt.Text), -IIf(OpBalTxt.Text = "", 0, OpBalTxt.Text))
End If
End If
TransRst!AcCode = AcDescTxt.Tag
TransRst!Cr_Dr = UCase(Left(DrCrCB.Text, 1))
TransRst!YOBDR = IIf(UCase(Left(DrCrCB.Text, 1)) = "D", OpBalTxt.Text, 0)
TransRst!YOBCR = IIf(UCase(Left(DrCrCB.Text, 1)) = "D", 0, OpBalTxt.Text)
TransRst.Update
Call BalancePost(ADDPosting, Val(OpBalTxt), UCase(Left(DrCrCB.Text, 1)), AcDescTxt.Tag, Conn1)
If ADDMode Then
'Update all years actrans tables
Call UpdateAllAcTrans
End If
'Save transaction
Conn1.CommitTrans
'Refresh Objects
ACRst.Requery
AcSrch.PopulateList
SavedData = True
Exit Function
SaveError:
AccountRst.CancelUpdate
Conn1.RollbackTrans
ErrHandler "Function SavedData"
End Function
Function GetAccountCode() As String
Dim RS As New ADODB.Recordset
RS.Open "Select Max(ACCODE) From ACMAST", Conn1, adOpenDynamic, adLockOptimistic
GetAccountCode = GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 6)
End Function
Private Sub ClearFields()
'Account Fields
AcDescTxt.Tag = ""
AcDescTxt.Text = ""
AliasTxt.Text = ""
GrpTxt.Text = ""
GrpTxt.Tag = ""
MailTxt.Text = ""
'Actrans Fields
OpBalTxt = Format(0, "0#.00##")
DrCrCB.ListIndex = -1
Call ClearAddressFields
End Sub
Private Sub ClearAddressFields()
'Address Fields
txtContact.Text = ""
txtAddress.Text = ""
txtCSTNo.Text = ""
DtCst.Value = ""
txtLST.Text = ""
dtLst.Value = ""
txtPh_o.Text = ""
txtph_r.Text = ""
txtFax.Text = ""
txtFax.Text = ""
End Sub
Public Sub UpdateAllAcTrans()
'To Update ACTrans Table of all year of selected company
'Called in Function SavedDate
On Error GoTo ErHand
Dim SQL, vFile As String, i As Integer
Dim TempConn As New ADODB.Connection
Dim YrConn As New ADODB.Connection
Dim YrRst As New ADODB.Recordset
YrRst.CursorLocation = adUseClient
YrConn.Open ADOConnectString("Companies")
SQL = "SELECT * FROM Comp_Year WHERE CompCode = '" & SelectedCompany.CompCode & "'"
YrRst.Open SQL, YrConn, adOpenForwardOnly, adLockReadOnly, adCmdText
Do Until YrRst.EOF
'Expect year that is currentally selected
If Not (YrRst!FromDate = SelectedCompany.FromDate) Then
vFile = GetDBFileName(YrRst!CompCode, YrRst!FromDate)
If fso.FileExists(vFile) Then
If TempConn.State = adStateOpen Then TempConn.Close
TempConn.Open ADOConnectString(vFile)
SQL = "INSERT INTO AcTrans (Accode, CLOSING, YOBDR, YOBCR, BALANCE) VALUES ('" & AcDescTxt.Tag & "', 0, 0, 0, 0);"
TempConn.Execute SQL, i, adCmdText
If i <> 1 Then
MsgBox "Multiple records inserted in ACTRANS table of database [" & vFile & "] when all years transaction update.", vbExclamation
End If
Else
MsgBox "Database file for Financial Year (" & Year(YrRst!FromDate) & "-" & Year(YrRst!ToDate) & ") is missing.", vbCritical
End If
End If
YrRst.MoveNext
Loop
ErHand:
ErrHandler "Sub UpdateAllAcTrans()"
End Sub
Sponsored Links