commit dfeca12b63083958b3bdc493c1430aa7e6a83d6e
parent c63614bb3b8dfbc55a3997ffd4fb2342aff163c0
Author: Bharatvaj Hemanth <bharatvaj@yahoo.com>
Date: Tue, 25 Jun 2024 11:22:47 +0530
Fix UserFriendlyNames, HighlightOnline
Make the code more procedural
Diffstat:
4 files changed, 373 insertions(+), 124 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1 @@
+tags
diff --git a/Standard/Bharatgas.xba b/Standard/Bharatgas.xba
@@ -0,0 +1,370 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
+<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Bharatgas" script:language="StarBasic">REM ***** BASIC *****
+'Option VBASupport 1
+Option Explicit
+
+Global Const exportFolder = "C:\Users\bhara\export"
+Global Const rowsToSkip = 1
+Global Const insertNewRowFor = False
+Global Const printOnlySummary = True
+Global Const highlightBasedOn = "Payment Option"
+Global Const roughHeaderMatch = True
+Global Const highlightSearchString = "Online Payment"
+
+Function UsedRangeCursor(Optional ByRef oSheet as Object) as Object
+ 'FIXME Check if the split has already happen
+ Dim cursor as Object
+ if IsNull(oSheet) Or IsMissing(oSheet) Then
+ oSheet = ThisComponent.getCurrentController().getActiveSheet()
+ End If
+ cursor = oSheet.createCursor()
+ cursor.gotoStartOfUsedArea(False)
+ cursor.gotoEndOfUsedArea(True)
+ UsedRangeCursor = cursor
+End Function
+
+Function UserFriendlyName(str as String) as String
+ Dim l as Long
+ Dim c as String
+ Dim i as Long
+ Dim prevChar as String
+ str = Trim(str)
+ ' Check if Len(str) is really called multiple times
+ l = Len(str)
+ For i = 0 To l
+ c = Mid(str, i + 1, 1)
+ If i > 1 And (c > "A" And c < "Z") Then
+ ' Only prepend space if 'c' is not the first character...
+ ' or previous char doesn't have space
+ UserFriendlyName = UserFriendlyName & IIf(prevChar = " ", "", " ") & c
+ Else
+ UserFriendlyName = UserFriendlyName & c
+ End If
+ prevChar = c
+ Next
+End Function
+
+Sub TestFn()
+ MsgBox UserFriendlyName("Area Name")
+ MsgBox UserFriendlyName("AreaName")
+ MsgBox UserFriendlyName(" AreaName")
+End Sub
+
+Sub SortAreaName(Optional oSheet As Variant, Optional cursor as Variant)
+ Dim oRange as Object
+ Dim oSortFields(0) as new com.sun.star.util.SortField
+ Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue
+ Dim endRow as Integer
+ Dim endColumn as Integer
+
+ If IsMissing(oSheet) Then
+ oSheet = ThisComponent.Sheets(0)
+ cursor = UsedRangeCursor(oSheet)
+ End If
+
+ endRow = cursor.RangeAddress.EndRow
+ endColumn = cursor.RangeAddress.EndColumn
+
+ oRange = oSheet.getCellRangeByPosition(0, 1, endColumn, endRow)
+ ThisComponent.getCurrentController.select(oRange)
+
+ ' Area
+ oSortFields(0).Field = 0
+ oSortFields(0).SortAscending = True
+
+ ' FIXME This is not working
+ ' Date
+ 'oSortFields(1).Field = 4
+ 'oSortFields(1).SortAscending = True
+
+ oSortDesc(0).Name = "SortFields"
+ oSortDesc(0).Value = oSortFields
+
+ oRange.Sort(oSortDesc)
+End Sub
+
+Sub NewSheet(sheetName as String)
+ Dim sheets as Object
+ sheets = ThisComponent.Sheets()
+ If Not sheets.hasByName(sheetName) Then
+ sheets.insertNewByName(sheetName, sheets.getCount())
+ End If
+
+End Sub
+
+Sub CleanColumnHeaders(oSheet as Object, endColumn as Integer)
+ Dim cell as Object
+ Dim neatName as String
+ Dim i as Integer
+ For i = 0 To endColumn
+ cell = oSheet.getCellByPosition(i, 0)
+ neatName = cell.getString()
+ neatName = UserFriendlyName(neatName)
+ cell.setString(neatName)
+ Next
+End Sub
+
+Sub RemoveExtraMergeCells(oSheet as Object, oRangeAddress as Variant)
+ Dim oRange as Object
+ Dim oSortFields(0) as new com.sun.star.util.SortField
+ Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue
+ Dim endRow as Integer
+
+ endRow = oRangeAddress.EndRow
+ lastColumn = oRangeAddress.EndColumn
+
+ rem set the range on which to sort'
+
+ 'oRange = oSheet.getCellRangeByName("A2:F20")
+ oRange = oSheet.getCellRangeByPosition(0, 0, lastColumn, 0)
+ ThisComponent.getCurrentController.select(oRange)
+ initialColumnCount = oRange.Columns.getCount() - 1
+ deletedColumns = 0
+ For j = 0 To (initialColumnCount - deletedColumns)
+ oCell = oRange.getCellByPosition(j, 0)
+ con = oCell.String
+ If con = "" Then
+ oRange.Columns.removeByIndex(j, 1)
+ deletedColumns = deletedColumns - 1
+ Else
+ Print con
+ End If
+ Next
+End Sub
+
+
+Sub UnFreezeSelection
+ Dim document as Object
+ Dim dispatcher as Object
+ document = ThisComponent.CurrentController.Frame
+ dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
+ dispatcher.executeDispatch(document, ".uno:FreezePanes", "", 0, Array())
+End Sub
+
+Function GetHeaderPosition(ByRef oSheet as Object, searchString as String, endColumn as Long) as Integer
+ Dim iColumn as Integer
+ Dim oCell as Object
+ Dim cellString as String
+ If roughHeaderMatch Then
+ searchString = UserFriendlyName(searchString)
+ End If
+ For iColumn = 0 To endColumn - 1
+ oCell = oSheet.getCellByPosition(iColumn, 0)
+ cellString = oCell.String
+ If roughHeaderMatch Then
+ cellString = UserFriendlyName(cellString)
+ End If
+ If cellString = searchString Then
+ GetHeaderPosition = iColumn
+ Exit For
+ End If
+ Next iColumn
+End Function
+
+Sub HighlightOnline(ByRef oSheet as Object, endColumn as Long, endRow as Long)
+ ' Fix false positives when having ONLINE and the content has "Online Payment"
+ Dim currentStr as String
+ Dim oCell as Object
+ Dim oCellRange as Object
+ Dim str as String
+ Dim iSearchColumn as Long
+ Dim i as Integer
+
+ ' Search for column position that has highlightBasedOn
+ iSearchColumn = GetHeaderPosition(oSheet, highlightBasedOn, endRow)
+
+ For i = 0 To endRow - 1
+ oCell = oSheet.getCellByPosition(iSearchColumn, i)
+ If InStr(oCell.getString(), highlightSearchString) > 0 Then
+ oCellRange = oSheet.getCellRangeByPosition(0, i, endColumn, i)
+ oCellRange.CellBackColor = RGB(255, 255, 0) ' Yellow
+ End If
+ Next i
+End Sub
+
+
+Sub MainNew
+ Dim oRange as Object
+ Dim oSheet as Object
+ Dim oCellStyle as Object
+ oSheet = ThisComponent.Sheets.getByIndex(0)
+ oRange = oSheet.getCellRangeByPosition(1, 1, 4, 1)
+ 'oCellStyle = ThisComponent.StyleFamilies.getByName("CellStyles").getByName("InterHeader")
+ oRange.CellStyle = "InterHeader"
+End Sub
+
+Sub Main
+ Dim s as Object
+ Dim cursor as Object
+ Dim c as Integer
+ Dim destSheet as Variant
+ Dim sheetName as String
+ Dim iArea as Long
+ Dim d as String
+ Dim a as String
+ Dim startRow as Long
+ Dim areaNames as New Collection
+ Dim dColumns as Object
+ Dim endRow as Long
+ Dim endColumn as Long
+ Dim areaColumn as Object
+ Dim areaRange, idRange, bookRange
+ Dim headerRange as Object
+ Dim cellRangeToCopy as Object
+
+ s = ThisComponent.Sheets(0)
+ cursor = UsedRangeCursor(s)
+
+ ' Skip Header
+ startRow = rowsToSkip
+ endRow = cursor.RangeAddress.EndRow
+ endColumn = cursor.RangeAddress.EndColumn
+
+ ' TODO pass the column name/index as an argument
+ ' Transformations to be applied to the Main sheet before splitting the sheet by Area Name
+ 'Call UnFreezeSelection
+ cursor = UsedRangeCursor(s)
+ Call HighlightOnline(s, endColumn, endRow)
+ Call SortAreaName(s, cursor)
+ Call CleanColumnHeaders(s, endColumn)
+
+ ' Justify Leftmost cells to left and Rightmost cells to right
+ ' TODO Maybe use more descriptive code? Like ("AreaName")?
+ idRange = s.getCellRangeByPosition(1,startRow, 1, endRow)
+ idRange.setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.LEFT)
+
+ bookRange = s.getCellRangeByPosition(endColumn, startRow, endColumn, endRow)
+ bookRange.setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.RIGHT)
+
+ areaColumn = s.getCellRangeByPosition(0,startRow, 0, endRow)
+ headerRange = s.getCellRangeByPosition(0, 0, endColumn, 0)
+
+ headerRange.CellStyle = "Heading 1"
+ 'On Error Goto ErrorHandler
+ For iArea = rowsToSkip To endRow - 1
+ d = areaColumn.getCellByPosition(0, iArea).String
+ If d = "" Then
+ Exit For
+ End If
+
+ If a <> d Or iArea = (endRow - 1) Then
+ ' FIXME Get the columns automatically from the sheet
+ ' FIXME Covert the end column from endColumn above
+
+ If insertNewRowFor Then
+ ' FIXME This is a stub, not correct
+ s.Rows.insertByIndex(startRow, 1)
+ startRow = startRow + 1
+ endRow = endRow + 1
+ End If
+
+ areaRange = s.getCellRangeByPosition(0, startRow, endColumn, iArea)
+ If printOnlySummary Then
+ GoTo Continue
+ End If
+
+ ' TODO subtotals might solve this
+ 's.group(areaRange.RangeAddress, 1)
+
+ sheetName = a & " - PENDING"
+
+ ' Copy the Headers from the Main Document
+ ' FIXME This DOES NOT work when using with filtered data
+ ' TODO Get the number of columns to copy dynamically from the Sheet.
+ cellRangeToCopy = areaRange.RangeAddress
+
+ If (cellRangeToCopy.EndRow - cellRangeToCopy.StartRow) = 0 Then
+ Goto Continue
+ End If
+
+ ' Prepare Destination sheet
+ NewSheet(sheetName)
+
+ destSheet = ThisComponent.Sheets().getByName(sheetName)
+
+ ' Customize the Destination Sheet's Columns
+ ' TODO Make snuggly calculation. There should be a minimum width and AutoFit
+ destSheet.getColumns().getByName("B").Width = 2500
+ destSheet.getColumns().getByName("C").Width = 4500
+ 'destSheet.getColumns().getByName("F").Width = 8000
+
+ ' Copy Header
+ ' TODO Check if it's possible to use UsedRange instead of endColumn
+ s.copyRange(destSheet.getCellRangeByName("A1").CellAddress, _
+ headerRange.RangeAddress)
+
+ ' Copy all the contents uptil
+ s.copyRange(destSheet.getCellRangeByName("A2").CellAddress, _
+ cellRangeToCopy)
+
+ 'TODO Remove Columns that should be deleted in leaveColumns
+ ' Better leave it when copying above
+ destSheet.getColumns().removeByIndex(0, 1)
+ destSheet.getColumns().removeByIndex(4, 1)
+
+ 'TODO Maybe use Dispatcher?
+ ExportPDF(destSheet)
+ Continue:
+ startRow = (iArea + 1)
+ a = d
+ End If
+ Next iArea
+
+ ErrorHandler:
+ MsgBox "Error#: " & Erl & Error
+ 'MsgBox "arrCount: " & areaNames.Count
+ MsgBox "a: " & a & ", d: " & d
+ Reset
+End Sub
+
+Sub ValidateFileName(fileName as String)
+ Dim invalidChars as String : invalidChars = "\/:*?""<>|"
+
+ For i = 1 To Len(fileName)
+ c = Mid(fileName, i, 1)
+ If InStr(invalidChars, c) > 0 Then
+ Print "invalid" & c
+ End If
+ Next
+End Sub
+
+Sub ExportPDF(Optional ByVal oSheet as Object)
+ 'Exit Sub
+ Dim cursor as Object
+ Dim args(2) as New com.sun.star.beans.PropertyValue
+ Dim fd(2) as New com.sun.star.beans.PropertyValue
+
+ Dim fileName as String
+ Dim fileUrl As String
+
+ cursor = UsedRangeCursor(oSheet)
+
+ 'ThisComponent.CurrentController.select(cursor)
+ fileName = exportFolder & "\" & oSheet.Name & ".pdf"
+ fileUrl = ConvertToUrl(fileName)
+
+ args(0).Name = "FilterName"
+ args(0).Value = "calc_pdf_Export"
+
+ fd(0).Name = "Selection"
+ fd(0).Value = cursor
+
+ ' conflicts with the Selection
+ fd(1).Name = "SinglePageSheets"
+ fd(1).Value = False
+
+ fd(2).Name = "IsSkipEmptyPages"
+ fd(2).Value = True
+
+ args(1).Name = "FilterData"
+ args(1).Value = fd
+
+ args(2).Name = "Overwrite"
+ args(2).Value = True
+
+ ThisComponent.storeToURL(fileUrl, args)
+End Sub
+
+
+</script:module>
+\ No newline at end of file
diff --git a/Standard/Module1.xba b/Standard/Module1.xba
@@ -1,122 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
-<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Module1" script:language="StarBasic">Sub RemoveFreezedCells
- s = ThisComponent.Sheets(0)
- a = s.freezeAtPosition(0,1)
- 'iFreezeRow = s.getPropertyValue("SplitRow")
- 'MsgBox iFreezeRow
-End Sub
-
-Rem Copy this to do the Windows Macros
-
-Sub RemoveExtraMergeCells
- Dim oSheet as Variant
- Dim cursor as Object
- Dim oRange as Object
- Dim oSortFields(0) as new com.sun.star.util.SortField
- Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue
- Dim lastRow as Integer
-
- oSheet = ThisComponent.Sheets(0)
-
- cursor = oSheet.createCursor()
- cursor.gotoStartOfUsedArea(False)
- cursor.gotoEndOfUsedArea(True)
- lastRow = cursor.RangeAddress.EndRow
- lastColumn = cursor.RangeAddress.EndColumn
-
- rem set the range on which to sort'
-
- 'oRange = oSheet.getCellRangeByName("A2:F20")
- oRange = oSheet.getCellRangeByPosition(0, 0, lastColumn, 0)
- ThisComponent.getCurrentController.select(oRange)
- initialColumnCount = oRange.Columns.getCount() - 1
- deletedColumns = 0
- For j = 0 To (initialColumnCount - deletedColumns)
- oCell = oRange.getCellByPosition(j, 0)
- con = oCell.String
- If con = "" Then
- oRange.Columns.removeByIndex(j, 1)
- deletedColumns = deletedColumns - 1
- Else
- Print con
- End If
- Next
-End Sub
-
-Sub SortAreaName
- Dim oSheet as Variant
- Dim cursor as Object
- Dim oRange as Object
- Dim oSortFields(0) as new com.sun.star.util.SortField
- Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue
- Dim lastRow as Integer
-
- oSheet = ThisComponent.Sheets(0)
-
- cursor = oSheet.createCursor()
- cursor.gotoStartOfUsedArea(False)
- cursor.gotoEndOfUsedArea(True)
- lastRow = cursor.RangeAddress.EndRow
-
- rem set the range on which to sort'
- 'oRange = oSheet.getCellRangeByPosition(0, 0, oSheet.Columns.Count - 1, oSheet.Rows.Count - 1)
- 'oRange = oSheet.getCellRangeByName("A2:F20")
- oRange = oSheet.getCellRangeByPosition(0, 1, 5, lastRow)
- 'ThisComponent.getCurrentController.select(oRange)
-
- oSortFields(0).Field = 0
- oSortFields(0).SortAscending = True
-
- oSortDesc(0).Name = "SortFields"
- oSortDesc(0).Value = oSortFields
-
- oRange.Sort(oSortDesc)
-End Sub
-
-Sub SortTest
- oSheet = ThisComponent.Sheets(0)
- oRange = oSheet.queryContentCells(com.sun.star.sheet.CellFlags.VALUE)
-
- MsgBox oRange.Rows.Count
- Exit Sub
-
- for x = 1 to oRange.Rows.Count
- for y = 1 to oRange.Columns.Count
- oSheet.getCellByPosition(x, y).Value = 0
-
- next y
- next x
-
-End Sub
-
-Sub Main
- AssignVars
- SortTest
- rem SortAreaName
-End Sub
-
-sub UnFreezeSelection
- dim document as object
- dim dispatcher as object
- document = ThisComponent.CurrentController.Frame
- dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
- dispatcher.executeDispatch(document, ".uno:FreezePanes", "", 0, Array())
-end sub
-
-sub SortAscendingRecorded
-rem ----------------------------------------------------------------------
-rem define variables
-dim document as object
-dim dispatcher as object
-rem ----------------------------------------------------------------------
-rem get access to the document
-document = ThisComponent.CurrentController.Frame
-dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
-
-rem ----------------------------------------------------------------------
-dispatcher.executeDispatch(document, ".uno:SortAscending", "", 0, Array())
-
-
-end sub
-</script:module>
-\ No newline at end of file
diff --git a/Standard/script.xlb b/Standard/script.xlb
@@ -1,5 +1,5 @@
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE library:library PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "library.dtd">
<library:library xmlns:library="http://openoffice.org/2000/library" library:name="Standard" library:readonly="false" library:passwordprotected="false">
- <library:element library:name="Module1"/>
+ <library:element library:name="Bharatgas"/>
</library:library>
\ No newline at end of file
