commit dfeca12b63083958b3bdc493c1430aa7e6a83d6e
parent c63614bb3b8dfbc55a3997ffd4fb2342aff163c0
Author: Bharatvaj Hemanth <bharatvaj@yahoo.com>
Date: Tue, 25 Jun 2024 11:22:47 +0530
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
4 files changed, 373 insertions(+), 124 deletions(-)
A
|
371
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
D
|
123
-------------------------------------------------------------------------------
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