Due to some technical error All Project source code & Project report are now available on www.ignousupport.blogspot.com Download all project for free
PROJECT SOURCE CODE
SPONSORED LINKS
General Module
Option Explicit
Public Function SlashPath(ByVal Path As String) As String
If Path = "" Then Exit Function
SlashPath = IIf(Right(Path, 1) = "\", Path, Path & "\..\")
End Function
Public Sub Wait(ByVal Seconds As Single)
'To Pause Execution for wait
Dim Tm As Single
Tm = Timer
Do While Timer < Tm + Seconds
DoEvents
Loop
End Sub
Public Function ValidateDesimal(ByVal NumText As String, ByRef Cancel As Boolean, Optional DecimalPlace As Integer) As Boolean
'To Check Desimal (more then one)
If Not InStr(NumText, ".") > 0 Then ValidateDesimal = True: Exit Function
If InStr(InStr(NumText, ".") + 1, NumText, ".") > 0 Then
ValidateDesimal = False
Cancel = True
MsgBox "Invalid Numeric Value. Check decimal point.", vbCritical, "Invalid Value..."
Exit Function
ElseIf Not IsMissing(DecimalPlace) Then
If Len(Mid(NumText, InStr(NumText, ".") + 1)) > DecimalPlace And Not DecimalPlace = 0 Then
ValidateDesimal = False
Cancel = True
MsgBox "Only " & DecimalPlace & " decimal point allowed.", vbCritical, "Invalid Value..."
Exit Function
End If
End If
If IsNumeric(NumText) Then
ValidateDesimal = True
Cancel = False
Else
ValidateDesimal = False
Cancel = True
End If
End Function
Public Function ValidateNumber(KeyAscii As Integer) As Boolean
' To Restrict KeyStrock other then numeric
' Call in Numeric Datafields KeyPress() Event
If (InStr(".0123456789", Chr(KeyAscii)) = 0) And KeyAscii <> 8 And KeyAscii <> 13 Then KeyAscii = 0: ValidateNumber = False: MsgBox "Only Numeric allowed.", vbCritical, "Invalid Value..." Else ValidateNumber = True
End Function
Public Sub ErrHandler(Optional ByVal Source As String, Optional SilenceMode As Boolean = False)
'To Display Error Massage
Dim ErrString As String, Fno As Integer
If err.Number <> 0 Then
Fno = FreeFile
Open SlashPath(App.Path) & "ErrLog.log" For Append As Fno
If Not Source = "" Then
ErrString = "Err. No.: " & err.Number & " Date/Time: " & FormatDateTime(Now, vbLongDate) & ", " & FormatDateTime(Now, vbLongTime) & vbCrLf & _
err.Description & vbCrLf & vbCrLf & "Raised at: [" & Source & "]." & vbCrLf _
& "Error Source: " & err.Source
Else
ErrString = "Err. No.: " & err.Number & " Date/Time: " & FormatDateTime(Now, vbLongDate) & ", " & FormatDateTime(Now, vbLongTime) & vbCrLf & _
err.Description & vbCrLf & vbCrLf & vbCrLf & "Error Source: " & err.Source
End If
Print #Fno, ErrString & vbCrLf & "==========================================================" & vbCrLf
Close Fno
If Not SilenceMode Then MsgBox ErrString, vbCritical, "Error"
End If
End Sub
Public Sub SelectText(ByRef TxtBox As Object)
'To Select entire text of the text box
If TxtBox.Enabled And TxtBox.Visible Then
TxtBox.SetFocus
TxtBox.SelStart = 0
TxtBox.SelLength = Len(TxtBox.Text)
End If
End Sub
Public Function GetProperCode(ByVal vCode As String, ByVal vWidth As Integer) As String
'To Set Code width
Dim i As Integer
Dim TmpString As String
For i = 1 To (vWidth - Len(vCode))
TmpString = TmpString & "0"
Next i
GetProperCode = TmpString & vCode
End Function
Public Sub SetMenuItems()
With MDIForm1
If Not (SelectedCompany.Company = "") Then
MDIForm1.Caption = SelectedCompany.Company & " (" & Format(SelectedCompany.FromDate, "dd/mm/yyyy") & "-" & Format(SelectedCompany.ToDate, "dd/mm/yyyy") & ")"
MDIForm1.StatusBar1.Panels(1) = "Financial Year [" & Year(SelectedCompany.FromDate) & "-" & Year(SelectedCompany.ToDate) & "]"
MDIForm1.StatusBar1.Panels(2) = SelectedCompany.Company
Else
MDIForm1.Caption = ""
MDIForm1.StatusBar1.Panels(1) = ""
MDIForm1.StatusBar1.Panels(2) = ""
End If
.subMnCompany(0).Enabled = (SelectedCompany.Company = "") 'Select Company
.subMnCompany(1).Enabled = Not (SelectedCompany.Company = "") 'Create Company
.subMnCompany(2).Enabled = Not (SelectedCompany.Company = "") 'Alter Company
.subMnCompany(3).Enabled = Not (SelectedCompany.Company = "")
.subMnCompany(5).Enabled = Not (SelectedCompany.Company = "") 'Back/Restore Company
.subMnMasterEntries(0).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(1).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(2).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(3).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(5).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(6).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(8).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(9).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(10).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(12).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(13).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(15).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(15).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(16).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(17).Enabled = Not (SelectedCompany.Company = "")
.subMnMasterEntries(18).Enabled = Not (SelectedCompany.Company = "")
.subMnPatientEntries(0).Enabled = Not (SelectedCompany.Company = "") '
.subMnPatientEntries(1).Enabled = Not (SelectedCompany.Company = "") '
.subMnTransactionEntries(0).Enabled = Not (SelectedCompany.Company = "")
.subMnTransactionEntries(1).Enabled = Not (SelectedCompany.Company = "")
.subMnTransactionEntries(3).Enabled = Not (SelectedCompany.Company = "") '
.subMnTransactionEntries(4).Enabled = Not (SelectedCompany.Company = "")
.subMnTransactionEntries(6).Enabled = Not (SelectedCompany.Company = "")
.subMnVoucherEntries(0).Enabled = Not (SelectedCompany.Company = "")
.subMnVoucherEntries(1).Enabled = Not (SelectedCompany.Company = "")
.subMnVoucherEntries(3).Enabled = Not (SelectedCompany.Company = "")
.subMnVoucherEntries(4).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(0).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(1).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(3).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(4).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(5).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(7).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(8).Enabled = Not (SelectedCompany.Company = "")
.subMnInventoryReports(9).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(0).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(1).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(2).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(3).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(4).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(5).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(6).Enabled = Not (SelectedCompany.Company = "")
.subMnAccountReports(7).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(0).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(1).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(2).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(3).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(4).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(5).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(6).Enabled = Not (SelectedCompany.Company = "")
.subMnMiscellaneousReports(7).Enabled = Not (SelectedCompany.Company = "")
.subMnUtilities(5).Enabled = Not (SelectedCompany.Company = "")
.subMnUtilities(6).Enabled = Not (SelectedCompany.Company = "") 'Error Due To Some Problem
.subMnUtilities(8).Enabled = Not (SelectedCompany.Company = "")
End With
End Sub
Public Sub NextMove(ByRef rst As ADODB.Recordset)
If rst Is Nothing Then Exit Sub
If Not rst.State = adStateOpen Then Exit Sub
If Not (rst.RecordCount > 0) Then Exit Sub
If Not rst.EOF Then rst.MoveNext
If rst.EOF Then rst.MoveLast
End Sub
Public Sub PreviousMove(ByRef rst As ADODB.Recordset)
If rst Is Nothing Then Exit Sub
If Not rst.State = adStateOpen Then Exit Sub
If Not (rst.RecordCount > 0) Then Exit Sub
If Not rst.BOF Then rst.MovePrevious
If rst.BOF Then rst.MoveFirst
End Sub
Public Sub LastMove(ByRef rst As ADODB.Recordset)
If rst Is Nothing Then Exit Sub
If Not rst.State = adStateOpen Then Exit Sub
If Not (rst.RecordCount > 0) Then Exit Sub
rst.MoveLast
End Sub
Public Sub TopMove(ByRef rst As ADODB.Recordset)
If rst Is Nothing Then Exit Sub
If Not rst.State = adStateOpen Then Exit Sub
If Not (rst.RecordCount > 0) Then Exit Sub
rst.MoveFirst
End Sub
Public Function IsInFinancialYear(ByVal vDate As Date)
IsInFinancialYear = (vDate >= SelectedCompany.FromDate And vDate <= SelectedCompany.ToDate)
End Function
Public Function RecentRate(ByVal ItemCode As String, ByVal VoucherType As String, Optional ItemSize As Single, Optional ClosingDate) As Double
Dim Rt As Double
Dim SQL, Dt, ItmSz As String
Dim rst As New ADODB.Recordset
rst.CursorLocation = adUseClient
If Not VBA.IsMissing(ClosingDate) Then
Dt = " AND VDATE < '" & CDate(ClosingDate) & "'"
Else
Dt = ""
End If
ItmSz = IIf(ItemSize = 0, "", " AND ISIZE = " & ItemSize)
SQL = "SELECT RATE FROM LEDGER WHERE (ICODE = '" & ItemCode & "'" & ItmSz & " AND VTYPE = '" & VoucherType & "' AND VDATE = (SELECT MAX(VDATE) FROM LEDGER WHERE ICODE = '" & ItemCode & "' AND VTYPE = '" & VoucherType & "'" & Dt & ItmSz & ")) ORDER BY VDATE DESC"
rst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If rst.RecordCount > 0 Then Rt = IIf(IsNull(rst!Rate), 0, rst!Rate)
'If Rate found then exit function
If Rt > 0 Then GoTo EndFunctionLbl
'Get purchase rate from item table if rate not found from ledger table
If rst.State = adStateOpen Then rst.Close
SQL = "SELECT Purch_Rate, Sale_Rate FROM ITEM WHERE (ITEM.ITEMCODE = '" & ItemCode & "')"
rst.Open SQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If rst.RecordCount > 0 Then Rt = IIf(VoucherType = "SV", IIf(IsNull(rst!Sale_Rate), 0, rst!Sale_Rate), IIf(IsNull(rst!Purch_Rate), 0, rst!Purch_Rate))
EndFunctionLbl:
RecentRate = Rt
End Function
Public Function BalancePost(ByVal mode As BalancePostingMode, ByVal PostAmount As Double, ByRef DrCr As String, ByRef AccountCode As String, ByRef Conn1 As ADODB.Connection)
Dim SQL, mAccode As String
Dim i As Integer
mAccode = AccountCode
Dim ACRst As New ADODB.Recordset
ACRst.CursorLocation = adUseClient
SQL = "Select * From ACMAST ORDER BY ACCODE"
ACRst.Open SQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
If Not (ACRst.RecordCount > 0) Then
MsgBox "ACMAST Table having no records.", vbCritical, "Table blank"
Exit Function
End If
Dim AcTransRst As New ADODB.Recordset
Set AcTransRst = New ADODB.Recordset
'AcTransRst.CursorLocation = adUseServer
AcTransRst.CursorLocation = adUseClient
SQL = "Select * From AcTrans ORDER BY ACCODE"
AcTransRst.Open SQL, Conn1, adOpenKeyset, adLockOptimistic, adCmdText
If AcTransRst.EOF Then
MsgBox "AcTrans Table having no records.", vbCritical, "Table blank"
Exit Function
End If
mAccode = AccountCode
Do
AcTransRst.MoveFirst
AcTransRst.Find "ACCODE = '" & mAccode & "'"
If AcTransRst.EOF Then
'MsgBox "Account Code [" & mAccode & "] is not found in ACTrans Table.", vbCritical, "Record not found"
Exit Function
Else
SQL = "UPDATE ACTRANS SET CLOSING = (CLOSING " & IIf(mode = ADDPosting, "+", "-") & IIf(DrCr = "D", PostAmount, -PostAmount) & ") Where ACCODE = '" & mAccode & "'"
SQL = VBA.Replace(SQL, "--", "+")
Conn1.Execute SQL, i, adCmdText
If i = 0 Then MsgBox "Posting Amount for Accound Code [" & mAccode & "] could not update in ACTRANS Table", vbCritical, "Unsuccessfull Updatation"
i = 0
End If
ACRst.MoveFirst
ACRst.Find "ACCODE = '" & mAccode & "'"
If ACRst.EOF Then
MsgBox "Account Code [" & mAccode & "] is not found in ACMAST Table.", vbCritical, "Record not found"
Exit Function
Else
If IsNull(ACRst!GrCode) Or ACRst!GrCode = "" Then
Exit Do
Else
mAccode = ACRst!GrCode
End If
End If
Loop
End Function
Public Function BrowseFolderPath(ByVal Title As String) As String
Dim vRoot As String
With BrowFrm
.TitleLbl = Title
.Show vbModal
BrowseFolderPath = .FolderList.Tag
Unload BrowFrm
End With
End Function
Public Sub SelectListItem(GroupList As ListBox, Optional Action As ListSelectAction)
Dim i As Integer
For i = 0 To GroupList.ListCount - 1
Select Case Action
Case 0
GroupList.Selected(i) = True
Case 1
GroupList.Selected(i) = False
Case 2
GroupList.Selected(i) = Not GroupList.Selected(i)
End Select
Next i
End Sub
Public Sub UnloadApplication(Optional CompleteUnload As Boolean = True)
Dim Frm As Form
For Each Frm In Forms
If Frm.Name = "MDIForm1" Then
If CompleteUnload Then Unload Frm
Else
Unload Frm
End If
Next
End Sub
Public Function DeCodeText(ByVal vText As String) As String
Dim i As Long
Dim Tmp As String
vText = StrReverse(vText)
For i = 1 To Len(vText)
Tmp = Tmp & Chr(Asc(Mid(vText, i, 1)) + i)
Next i
DeCodeText = Tmp
End Function
Public Function UnCodeText(ByVal vText As String) As String
Dim i As Long
Dim Tmp As String
For i = 1 To Len(vText)
Tmp = Tmp & Chr(Asc(Mid(vText, i, 1)) - i)
Next i
UnCodeText = StrReverse(Tmp)
End Function
Public Function DoBlankDatabase(ByVal CurrentDB As String) As Boolean
On Error GoTo ErrHand
Dim SQL As String
Dim CnString As String
Dim DBConn As New ADODB.Connection
CnString = ADOConnectString(CurrentDB)
DBConn.Open CnString
'Constant Database
DBConn.Execute "DELETE FROM ACMAST WHERE MODIFY = 'Y'"
DBConn.Execute "DELETE FROM ACTRANS"
DBConn.Execute "INSERT INTO AcTrans (Accode, CLOSING, YOBDR, YOBCR, BALANCE) SELECT ACCODE, 0, 0, 0, 0 FROM ACMAST;"
DBConn.Execute "DELETE From Addmission"
DBConn.Execute "DELETE From Addmission1"
DBConn.Execute "DELETE FROM ADDRESS"
DBConn.Execute "DELETE FROM Anaes"
DBConn.Execute "DELETE FROM Apnt"
DBConn.Execute "DELETE FROM BankBook_Temp"
DBConn.Execute "DELETE from BedDetail"
DBConn.Execute "DELETE from Bill"
DBConn.Execute "DELETE from BillAdd"
DBConn.Execute "DELETE from BillDetail"
DBConn.Execute "DELETE from BillMast"
DBConn.Execute "DELETE from CompMast"
DBConn.Execute "DELETE from DailyMast"
DBConn.Execute "DELETE from DateWiseInvest"
DBConn.Execute "DELETE from Department"
DBConn.Execute "DELETE from DiMast"
DBConn.Execute "DELETE from DischargeTicket"
DBConn.Execute "DELETE from DnCnLedger"
DBConn.Execute "DELETE from DocMast"
DBConn.Execute "DELETE from DocTemp"
DBConn.Execute "DELETE from DrAnas"
DBConn.Execute "DELETE from Hospital"
DBConn.Execute "DELETE from Item"
DBConn.Execute "DELETE from ItemGroup"
DBConn.Execute "DELETE from ItemSize"
DBConn.Execute "DELETE from Ledger"
DBConn.Execute "DELETE from Manufacturer"
DBConn.Execute "DELETE from OPD"
DBConn.Execute "DELETE from OPDBill"
DBConn.Execute "DELETE from OPDBillDetail"
DBConn.Execute "DELETE from OPDPres"
DBConn.Execute "DELETE from OPDUltraSound"
DBConn.Execute "DELETE from OptNote"
DBConn.Execute "DELETE from Prescription"
DBConn.Execute "DELETE from Purchase"
DBConn.Execute "DELETE from PurchaseDetail"
DBConn.Execute "DELETE from Remark"
DBConn.Execute "DELETE from Sale"
DBConn.Execute "DELETE from SupMast"
DBConn.Execute "DELETE from UltraSound1"
DBConn.Execute "DELETE from Visit"
DBConn.Execute "DELETE from TempRegFee"
DBConn.Execute "DELETE from WorkDone"
DBConn.Execute "DELETE from Voucher"
DBConn.Execute "DELETE from WorkMast"
DBConn.Execute "DELETE from TempDwc"
DBConn.Execute "DELETE from TblTempStatement"
DBConn.Execute "DELETE from Stock_Ledger_Temp"
DBConn.Execute "DELETE from Pl_Temp"
DBConn.Execute "DELETE from Fin_Ledger_Temp"
DBConn.Execute "DELETE from DrPl_Temp"
DBConn.Execute "DELETE from DayBook_Temp"
DBConn.Execute "DELETE from CrPl_Temp"
DBConn.Execute "DELETE from CashBook_Temp"
DoBlankDatabase = True
ErrHand:
ErrHandler "Function DoBlankDatabase", True
End Function
Public Function ADOConnectString(ByVal DBFile As String) As String
ADOConnectString = "Provider=SQLOLEDB.1;Password=" & Password & ";Persist Security Info=True;User ID=" & UserName & ";Initial Catalog=" & DBFile & ";Data Source=" & ServerName & " "
End Function
Public Function GetDBFileName(ByVal vCode As String, vFromDate As Date)
GetDBFileName = "Database" & CStr(vCode & Format(vFromDate, "ddmmyyyy")) & ""
End Function
Public Function SaveAccount(ByVal accno As String, ByVal AccountName As String, GroupNO As String, ByVal ADDMode As Boolean, Optional Contact As String, Optional Address As String, Optional PhoneOff As String, Optional PhoneRes As String, Optional Alies As String) As String
'On Error GoTo SaveError
Dim SQL, ACSQL, vCash, TransSQL As String
Dim AccountNo As String
Dim GroupRst As New ADODB.Recordset
GroupRst.CursorLocation = adUseClient
GroupRst.Open "SELECT * FROM ACMAST WHERE ACCODE = '" & GetAccount(GroupNO) & "'", Conn, adOpenForwardOnly, adLockOptimistic, adCmdText
AccountNo = accno
'If AccountNo = "" Then ADDMode = True
If ADDMode Then AccountNo = GetAccountCode
If ADDMode Then
ACSQL = "SELECT * FROM ACMAST"
TransSQL = "SELECT * FROM AcTrans"
Else
ACSQL = "SELECT * FROM ACMAST WHERE ACCODE = '" & AccountNo & "'"
TransSQL = "SELECT * FROM AcTrans WHERE ACCODE = '" & AccountNo & "'"
End If
Dim AccountRst As New ADODB.Recordset
AccountRst.CursorLocation = adUseClient
AccountRst.Open ACSQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If ADDMode Then AccountRst.AddNew
AccountRst!Modify = "Y"
AccountRst!AcCode = AccountNo
AccountRst!AcDESC = AccountName
AccountRst!ACALIAS = Alies & ""
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
Conn.Execute "DELETE FROM ADDRESS WHERE ACCODE = '" & AccountNo & "'"
If (vCash = "R" Or vCash = "P" Or vCash = "B") Then
Dim AddRst As New ADODB.Recordset
AddRst.CursorLocation = adUseClient
AddRst.Open "ADDRESS", Conn, adOpenKeyset, adLockOptimistic, adCmdTable
AddRst.AddNew
AddRst!AcCode = AccountNo
AddRst!Contact = Contact
AddRst!Address = Address
AddRst!CstNo = ""
AddRst!CSTDT = Null
AddRst!LstNo = ""
AddRst!LSTDT = Null
AddRst!Ph_O = PhoneOff
AddRst!Ph_R = PhoneRes
AddRst!Fax = ""
AddRst!Email = ""
AddRst.Update
End If
'Saveing Value to AcTrans
Dim OldClosing As Double
Dim TransRst As New ADODB.Recordset
TransRst.CursorLocation = adUseClient
TransRst.Open TransSQL, Conn, adOpenKeyset, adLockOptimistic, adCmdText
If ADDMode Then 'Add a new record
TransRst.AddNew
TransRst!AcCode = AccountNo
TransRst!CLOSING = 0
TransRst!YOBDR = 0
TransRst!YOBCR = 0
TransRst!Cr_Dr = UCase(Left("C", 1))
Else 'Edit balance field
If TransRst.RecordCount = 1 Then
OldClosing = IIf(TransRst!Cr_Dr = "D", TransRst!YOBDR, TransRst!YOBCR)
Call BalancePost(EditPosting, OldClosing, TransRst!Cr_Dr, AccountNo, Conn)
ElseIf TransRst.RecordCount <= 0 Then 'Add a new record if record not available in EditMode
TransRst.AddNew
TransRst!AcCode = AccountNo
TransRst!CLOSING = 0
End If
End If
TransRst.Update
If Not ADDMode Then
'Update all years actrans tables
Call BalancePost(ADDPosting, Val(0), UCase(Left("C", 1)), AccountNo, Conn)
'Call UpdateAllAcTrans
End If
SaveAccount = AccountNo
Exit Function
SaveError:
AccountRst.CancelUpdate
ErrHandler "Function SavedAccount"
End Function
Public Function GetAccountCode() As String
Dim RS As New ADODB.Recordset
RS.Open "Select Max(ACCODE) From ACMAST", Conn, adOpenDynamic, adLockOptimistic
GetAccountCode = GetProperCode(IIf(IsNull(RS(0)), "1", RS(0) + 1), 6)
End Function
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(FolderRoot & "Companies.mdb")
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 TempConn.State = adStateOpen Then TempConn.Close
TempConn.Open ADOConnectString(vFile)
SQL = "INSERT INTO AcTrans (Accode, CLOSING, YOBDR, YOBCR, BALANCE) VALUES ('" & AcountFrm.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
' MsgBox "Database file for Financial Year (" & Year(YrRst!FromDate) & "-" & Year(YrRst!ToDate) & ") is missing.", vbCritical
End If
YrRst.MoveNext
Loop
ErHand:
ErrHandler "Sub UpdateAllAcTrans()"
End Sub
Public Function GetAccount(STR As String) As String
On Error GoTo SAM
Dim RstGet As New ADODB.Recordset
RstGet.Open "select ACCode from ACMast Where ACDesc='" & STR & "'", Conn, adOpenDynamic, adLockBatchOptimistic
If RstGet.EOF Then
MsgBox "Parent Account Does Not Exit", vbInformation
Else
GetAccount = RstGet.Fields(0) & ""
End If
SAM:
End Function