Next Chapter 67 General Module

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