Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Option Explicit
Sub GenerateXml(Opt As String)
Dim strXML As String
Dim path As String
Dim DirPath As String
Dim oRange As Object
DirPath = GetDirPath()
' sWriteFile strXML, ThisWorkbook.Path & filenameinput
If Opt = "P" Then
oRange = FindUsedRange(ShPurchase)
strXML = fGenerateXML(Opt, oRange, "DATA")
path = ConvertFromURL(ConvertToURL(DirPath) & "/Purchase.XML")
Else
oRange = FindUsedRange(ShSales)
strXML = fGenerateXML(Opt, oRange, "DATA")
path = ConvertFromURL(ConvertToURL(DirPath) & "/Sales.XML")
End If
sWriteFile strXML, path
MsgBox ("Completed. XML Written to " & path)
FolderError:
Exit Sub
Resume Next
End Sub
Sub GenerateTxt(Opt As String)
Dim strtxt As String
Dim path As String
Dim oRange As Object
Dim DirPath As String
' DirPath = GetDirPath()
If Dir("c:\KVATS",16)= "" then ' Does the directory exist ?
MkDir "c:\KVATS"
End If
If Opt = "P" Then
oRange = FindUsedRange(ShPurchase)
strtxt = fGenerateTxt(oRange)
'path = ConvertFromURL(ConvertToURL(DirPath) & "/Purchase.txt")
path = "C:\KVATS\Purchase.txt"
Else
oRange = FindUsedRange(ShSales)
strtxt = fGenerateTxt(oRange)
' path = ConvertFromURL(ConvertToURL(DirPath) & "/Sales.txt")
path = "C:\KVATS\Sales.txt"
End If
sWriteFile strtxt, path
MsgBox ("Completed. File Written to " & path)
End Sub
Function fGenerateTxt(ByVal rngData As Object) As String
Dim intColCount As Double
Dim intRowCount As Double
Dim intColCounter As Double
Dim intRowCounter As Double
Dim rngCell As Object
Dim rngCell1 as object
Dim rngCell2 as object
Dim strtxt As String
Dim strTemp As String
With rngData
strtxt = ""
intColCount = .Columns.Count
intRowCount = .Rows.Count
'Loop down the table's rows
For intRowCounter = 1 To intRowCount -1
strTemp = ""
'looping for numcols + 1 to add the CRLF in the last go
For intColCounter = 0 To intColCount
If intColCounter < intColCount -1 Then
rngCell = rngData.getCellByPosition(intColCounter,intRowCounter)
If strTemp <> "" Then
strTemp = strTemp & "|" & Trim(rngCell.String)
Else
strTemp = strTemp & intRowCounter & "|" & Trim(rngCell.String)
End If
'Added to Sum up the Cess Amt, Value of Goods and VAT amount
ElseIf intColCounter = intColCount -1 Then
rngCell1 = rngData.getCellByPosition(intColCounter - 3,intRowCounter)
rngCell2 = rngData.getCellByPosition(intColCounter - 2,intRowCounter)
strTemp = strTemp & "|" & clng(Trim(rngCell1.String)) + clng(Trim(rngCell2.String)) + clng(Trim(rngCell.String)) & vbCRLF
'Else
' strTemp = strTemp & vbCRLF
End If
Next
strtxt = strtxt & strTemp
Next
End With
fGenerateTxt = strtxt
End Function
Function GetDirPath()
Dim DirPath As String
REDO:
DirPath = InputBox ("Please enter the path to the directory where you wish to save the files. Remember that this will overwrite the previous Purchase.txt and Sales.txt if any present in the folder", "Path to writable direcotry")
'DirPath = "/home/user01/test"
If DirPath = "" Then
End
End If
If Dir(DirPath, vbDirectory) = "" Then
MsgBox DirPath & " is not a valid directory name. Please try again"
Goto REDO
End If
GetDirPath = DirPath
End Function
' Function for writing plain string into a file
Sub sWriteFile(strXML As String, strFullFileName As String)
Dim intFileNum As String
intFileNum = FreeFile
Open strFullFileName For Output As #intFileNum
Print #intFileNum, strXML
Close #intFileNum
End Sub
'Finds the range of cells that constitute the minimum rectangular area used in the sheet
Function FindUsedRange(ByVal oSheet as Object)
Dim oCell As Object
Dim oCursor As Object
oCell = oSheet.getCellByPosition(0, 0)
oCursor = oSheet.createCursorByRange(oCell)
oCursor.gotoStartOfUsedArea(False)
oCursor.GotoEndOfUsedArea(True)
FindUsedRange = oCursor
End Function
'Initializes global variables
Sub InitProc
ShPurchase = ThisComponent.Sheets.getByName("Purchases")
ShSales = ThisComponent.Sheets.getByName("Sales")
End Sub
'Finds the index of a sheet by name
Function findSheetIndex(SheetName as String) as Integer
Dim i as integer
for i = 0 to ThisComponent.Sheets.Count - 1
if ThisComponent.Sheets.getByIndex(i).Name = _
SheetName _
then
findSheetIndex = i
exit function
end if
next i
findSheetIndex = -1
End Function
'Sets the text in a Cell
Sub SetText(ByVal oSheet as Object, Address as String, Value as String)
Dim oRange as Object
Dim oCell as Object
oRange = oSheet.getCellRangeByName(Address)
oCell = oSheet.getCellByPosition(oRange.RangeAddress.StartColumn, oRange.RangeAddress.StartRow)
oCell.String = Value
End Sub
'Get the Index of a column given the column name.
Function GetColIndex(ByVal oSheet as Object, ColName as String)
Dim oRange as Object
oRange = oSheet.getCellRangeByName(ColName & "1")
GetColIndex = oRange.RangeAddress.StartColumn
End Function
'Get the address of a cell
Function GetCellAddress(ByRef oCell as Object)
Dim Address as String
XRay oCell
GetCellAddress = Address
End Function
'Select a given object
Sub SelectObject(obj)
ThisComponent.getCurrentController().Select(obj)
End Sub