commit ec2b843e116b1f28600d2f3f75c2c55447b75ed5
parent eb97a0eb5088fe1192a737243be809285ed40546
Author: Bharatvaj Hemanth <bharatvaj@yahoo.com>
Date: Sat, 24 Aug 2024 23:33:36 +0530
parent eb97a0eb5088fe1192a737243be809285ed40546
Author: Bharatvaj Hemanth <bharatvaj@yahoo.com>
Date: Sat, 24 Aug 2024 23:33:36 +0530
Completed pending report generation Completed SBC list generation Automation 100%
4 files changed, 742 insertions(+), 412 deletions(-)
D
|
411
-------------------------------------------------------------------------------
A
|
267
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
A
|
473
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
diff --git a/Standard/Bharatgas.xba b/Standard/Bharatgas.xba @@ -1,410 +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="Bharatgas" script:language="StarBasic">REM ***** BASIC ***** -'Option VBASupport 1 -Option Explicit - -Global Const exportFolder = "C:\Users\bhara\tSync\Pending-01-07-2024" -Global Const rowsToSkip = 1 -Global Const insertNewRowFor = False -Global Const printOnlySummary = False -Global Const roughHeaderMatch = True -Global Const highlightBasedOn = "Payment Option" -Global Const highlightSearchString = "Online Payment" -Global Const highlightRemoveColumn = True -' TODO change suffix based on the report type -Global Const sheetNameSuffix = "- PENDING" -Global Const shouldExportPDF = True -Global Const isPendingReport = True - -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(1) 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 - GetHeaderPosition = -1 - 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) - If iSearchColumn = -1 Then Exit Sub - 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 - - If highlightRemoveColumn Then - oSheet.Columns.removeByIndex(iSearchColumn, 1) - End If -End Sub - - -Sub MainNew - Dim oRange as Object - Dim oSheet as Object - Dim oCellStyle as Object - Dim pageStyle as Object - Dim oStyle as Object - oSheet = ThisComponent.Sheets.getByIndex(0) - 'oRange = oSheet.getCellRangeByPosition(1, 1, 4, 1) - 'oCellStyle = ThisComponent.StyleFamilies.getByName("CellStyles").getByName("InterHeader") - 'oRange.CellStyle = "InterHeader" - pageStyle = ThisComponent.StyleFamilies.getByName("PageStyles") - oStyle = pageStyle.getByName("Default") - oStyle.CenterVertically = True - pageStyle.insertByName("NewStyle") - - if NOT IsNull(pageStyle) then - Print pageStyle.dbg_methods - end if - -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 - Dim pageStyle 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) - If isPendingReport Then - Call HighlightOnline(s, endColumn, endRow) - End If - 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 - ' TODO maybe there is an elegant way than - ' writing this two times - If shouldExportPDF Then - ExportPDF(destSheet) - End If - GoTo Continue - End If - - ' TODO subtotals might solve this - 's.group(areaRange.RangeAddress, 1) - - sheetName = a & sheetNameSuffix - - ' 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) - - pageStyle = ThisComponent.StyleFamilies.getByName("PageStyles").getByName("Default") - pageStyle.setPropertyValue("PrintGrid", True) - pageStyle.setPropertyValue("CenterHorizontally", True) - ' Make the margins 0.2" thick - pageStyle.setPropertyValue("LeftMargin", 0.2 * 2540) - pageStyle.setPropertyValue("RightMargin", 0.2 * 2540) - - ' Customize the Destination Sheet's Columns - ' TODO Make snuggly calculation. There should be a minimum width and AutoFit - With destSheet.getColumns() - If isPendingReport Then - .getByName("B").Width = 2500 - .getByName("C").Width = 8000 - .getByName("D").Width = 2500 - Else - .getByName("B").Width = 1700 - .getByName("C").Width = 5000 - .getByName("D").Width = 11000 - .getByName("E").Width = 2200 - End If - End With - - - ' 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? - If shouldExportPDF Then - ExportPDF(destSheet) - End If - 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) - - With args(0) : .Name = "FilterName" : .Value = "calc_pdf_Export" : End With - WIth fd(0) : .Name = "Selection" : .Value = cursor : End With - - ' conflicts with the Selection - With fd(1) : .Name = "SinglePageSheets" : .Value = False : End With - With fd(2) : .Name = "IsSkipEmptyPages" : .Value = True : End With - - With args(1) : .Name = "FilterData" : .Value = fd : End With - With args(2) : .Name = "Overwrite" : .Value = True : End With - - ThisComponent.storeToURL(fileUrl, args) -End Sub - -</script:module>- \ No newline at end of file
diff --git a/Standard/CylinderAutomation.xba b/Standard/CylinderAutomation.xba @@ -0,0 +1,266 @@ +<?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="CylinderAutomation" script:language="StarBasic">REM ***** BASIC ***** +'Option VBASupport 1 +Option Explicit + +Global Const rowsToSkip = 1 +Global Const roughHeaderMatch = True +Global Const highlightBasedOn = "Payment Option" ' A yellow background is drawn that matches this column and 'highlightSearchString' +Global Const highlightSearchString = "Online" ' Does partial match +Global Const highlightRemoveColumn = True ' True if you want remove the column once the highlight is done +Global Const reportType = "PENDING" ' Allowed values are "PENDING", "SAFETY" and "SBC". The number of columns that are copied and the column size will be affected +Global Const shouldExportPDF = True ' If True this will export all the created sheets with Area specific data individually TODO change name to easily understand +Global Const badDayThreshold = 4 ' The days below 'the maximum date in report' to show as bad +Global Const shouldSegregateAreaWise = True' True if you want to create sheets with Area specific data +Global Const exportFolderPrefix = "C:\Users\bhara\Sync\" + +' Values are loaded from the document +Private tillDate as Date +Private tillDateStr as String +Private sheetNameSuffix as String +Private exportFolder as String + +'Private shouldExportSummaryPDF as Boolean' If True the first page will be exported as PDF + +Sub Main + Dim oDoc : oDoc = ThisComponent + Dim s as Object + Dim cursor as Object + Dim c as Integer + Dim destSheet as Variant + Dim sheetName$, d$, a$ + Dim areaColumn%, areaNames as New Collection + Dim startColumn%, startRow%, endColumn%, endRow% + Dim rowsToRemove%, iArea% + Dim areaRange, idRange, bookRange + Dim dColumns as Object + Dim headerRange as Object + Dim cellRangeToCopy as Object + Dim pageStyle as Object + Dim oCellStyles + Dim oConFormat + Dim oCondition(2) as new com.sun.star.beans.PropertyValue + Dim T4Style + + ' Initialize Globals + ' Casting to Long removes the time component + tillDate = CLng(Now()) + + s = oDoc.Sheets(0) + cursor = UsedRangeCursor(s) + + ' NaiveLastTable gives us the last non-blank table's + rowsToRemove = NaiveLastTable(s) + If rowsToRemove <> 0 Then + s.getRows().removeByIndex(0, rowsToRemove + 1) + End If + + startRow = 1 + startColumn = 0 + endRow = cursor.RangeAddress.EndRow + endColumn = cursor.RangeAddress.EndColumn + + ' TODO move this to knowledge base + oCellStyles = ThisComponent.StyleFamilies("CellStyles") + If Not oCellStyles.hasByName("T4") Then + T4Style = oDoc.createInstance("com.sun.star.style.CellStyle") + oCellStyles.insertByName("T4", T4Style) + oCellStyles.getByName("T4").CellBackColor = RGB(255, 0, 0) + End If + + If ThisComponent.CurrentController.hasFrozenPanes() Then + Call UnFreezeSelection + End If + + ' TODO pass the column name/index as an argument + ' Transformations to be applied to the Main sheet before splitting the sheet by Area Name + cursor = UsedRangeCursor(s) + + Call CleanColumnHeaders(s, endColumn) + + areaColumn = GetHeaderPosition(s, endColumn, "Area") + Call ShortenDirections(s, areaColumn) + + If Left(reportType, 1) = "P" Then + Call ApplyTheme "millennium.ots" + endColumn = RemoveColumnsExcept(s, endColumn, Array( _ + "Area", _ + "ID", _ + "Name", _ + "Mobile", _ + "Book", _ + "Payment Option" _ + )) + + endColumn = HighlightRowWithColumn(s, endColumn, endRow, _ + "Payment Option", "Online Payment", True, _ + RGB(255, 255, 0)) + + ' Justify Leftmost cells to left and Rightmost cells to right + + bookRange = GetColumnRange(s, endColumn, endRow, "Book") + bookRange.setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.RIGHT) + + FormatRangeAsNumber(s, new com.sun.star.lang.Locale, oDoc.getNumberFormats(), bookRange, "DD/MM") + + tillDate = FindHighestDateAsString(s, "Book", endColumn, endRow) + + With oCondition(0) : .Name = "Operator" : .Value = com.sun.star.sheet.ConditionOperator.LESS_EQUAL : End With + oCondition(1).Name = "Formula1" : oCondition(1).Value = CLng(tillDate - badDayThreshold) + With oCondition(2) : .Name = "StyleName" : .Value = "T4" : End With + oConFormat = bookRange.ConditionalFormat + oConFormat.clear() : oConFormat.addNew(oCondition) + + SetWidths(s, endColumn, Array( _ + Array("Area", 0), _ + Array("ID", 0), _ + Array("Name", 7000), _ + Array("Mobile", 0), _ + Array("Book", 0) _ + )) + ElseIf reportType = "SBC" Then + Call ApplyTheme "pumpkin.ots" + endColumn = RemoveColumnsExcept(s, endColumn, Array( _ + "ID", _ + "Name", _ + "Address", _ + "Mobile", _ + "Area", _ + "No Of Cylinder" _ + )) + SetWidths(s, endColumn, Array( _ + Array("ID", 0), _ + Array("Name", 3000), _ + Array("Address", 8000), _ + Array("Mobile", 0), _ + Array("Area", 0) _ + )) + End If + + idRange = GetColumnRange(s , endColumn, endRow, "ID") _ + .setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.LEFT) + + Call SortColumn(s, endColumn, endRow, "Area") + + ' Setup exportFolder and sheetName + tillDateStr = Replace(CDate(tillDate), "/", "-") + tillDateStr = Trim(tillDateStr) + sheetNameSuffix = " - " & reportType & " " & tillDateStr + exportFolder = exportFolderPrefix & "/" & reportType & " " & tillDateStr + + headerRange = s.getCellRangeByPosition(0, 0, endColumn, 0) + headerRange.CellStyle = "Heading 1" + + pageStyle = ThisComponent.StyleFamilies.getByName("PageStyles").getByName("Default") + pageStyle.setPropertyValue("PrintGrid", True) + pageStyle.setPropertyValue("CenterHorizontally", True) + ' Make the margins 0.2" thick + + pageStyle.setPropertyValue("LeftMargin", 0.2 * 2540) + pageStyle.setPropertyValue("RightMargin", 0.2 * 2540) + + ' Change original sheet name + s.Name = "SUMMARY" & sheetNameSuffix + + ' Export summary + If shouldExportPDF Then + ExportPDF(s, exportFolder) + End If + + If NOT shouldSegregateAreaWise Then Exit Sub + + Dim statusBar + statusBar = oDoc.CurrentController.StatusIndicator + statusBar.start("Creating Area Wise", 10) + + areaRange = s.getCellRangeByPosition(areaColumn, startRow, areaColumn, endRow) + a = areaRange.getCellByPosition(0, startRow).getString() + 'On Error Goto ErrorHandler + For iArea = startRow To endRow - 1 + d = areaRange.getCellByPosition(0, iArea).getString() + If d = "" Then + Exit For + End If + + If a <> d Or iArea = (endRow - 1) Then + statusBar.setValue((iArea / endRow) * 100) + ' FIXME Get the columns automatically from the sheet + ' FIXME Covert the end column from endColumn above + + Goto Con: + Dim cName + s.Rows.insertByIndex(startRow, 1) + cName = s.getCellByPosition(startColumn, startRow) + cName.setString(d) + startRow = startRow + 1 + endRow = endRow + 1 + + Con: + ' TODO maybe there is an elegant way than + ' writing this two times + sheetName = a & sheetNameSuffix + + ' TODO subtotals might solve this + 's.group(areaRange.RangeAddress, 1) + + ' Prepare Destination sheet + destSheet = NewSheet(sheetName) + + + ' Copy the Headers from the Main Document + If areaColumn > 0 And areaColumn < endColumn Then + MsgBox "Can't have Area column in the middle", 16 + Exit Sub + End If + + ' start end + '1 : endColumn 0 4 + 'areaColumn + 1 : endColumn 2 4 + '0 : endColumn - 1 4 4 + + ' Copy Header + s.copyRange(destSheet.getCellRangeByName("A1").CellAddress, _ + s.getCellRangeByPosition( _ + (endColumn - areaColumn)/ endColumn, _ + 0, endcolumn - CInt(areaColumn/endColumn), 0).RangeAddress) + + ' Copy Contents + s.copyRange(destSheet.getCellRangeByName("A2").CellAddress, _ + s.getCellRangeByPosition(_ + (endColumn - areaColumn)/ endColumn, _ + startRow, _ + endcolumn - CInt(areaColumn/endColumn), _ + iArea).RangeAddress) + + ' Customize the Destination Sheet's Columns + If Left(reportType, 1) = "P" Then + SetWidths(destSheet, endColumn, Array( _ + Array("ID", 0), _ + Array("Name", 7000), _ + Array("Mobile", 0), _ + Array("Book", 0) _ + )) + ElseIf reportType = "SBC" Then + SetWidths(destSheet, endColumn, Array( _ + Array("ID", 0), _ + Array("Name", 4000), _ + Array("Address", 11000), _ + Array("Mobile", 0) _ + )) + End If + + If shouldExportPDF Then + ExportPDF(destSheet, exportFolder) + End If + Continue: + startRow = (iArea + 1) + a = d + End If + Next iArea + + ErrorHandler: + statusBar.end() + Reset +End Sub +</script:module>+ \ No newline at end of file
diff --git a/Standard/HandyTools.xba b/Standard/HandyTools.xba @@ -0,0 +1,472 @@ +<?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="HandyTools" script:language="StarBasic" script:moduleType="normal">REM ***** BASIC ***** +Option Explicit + +Function GetFriendlyWords() as Variant + GetFriendlyWords = Array( _ + "AreaCodeDesc", "Area", _ + "AreaDescription", "Area", _ + "ConsumerNumber", "ID", _ + "ConsumerName", "Name", _ + "MobileNumber", "Mobile", _ + "BookDate", "Book"_ + ) + If (UBound(GetFriendlyWords) Mod 2) <> 1 Then + Print "Mismatch in friendlyWords array" + Exit Function + End If +End Function + +Sub FormatRangeAsNumber(oSheet, oLocale, ByRef oFormats, oRange, formatStr as String) + ' BASIC equivalent of 'Text to Columns' + Dim formatNum as Long, i as Integer + Dim oReplace + oReplace = oRange.createReplaceDescriptor() + + If oRange.getCellByPosition(0,0).getValue() = 0 Then + formatNum = oFormats.queryKey(formatStr, oLocale, False) + ' add formatStr if it doesn't exist + If formatNum = -1 Then + formatNum = oFormats.addNew(formatStr, oLocale) + If formatNum = -1 Then + MsgBox "Cannot add " & formatStr & " as NumberFormat", 0, "Fatal" + Exit Sub + End If + End If + + With oReplace + .searchString = ".+" + .replaceString = "&" + .SearchRegularExpression = True + End With + + oRange.NumberFormat = formatNum + oRange.replaceAll(oReplace) + End If +End Sub + +Function GetColumnRange(oSheet, endColumn as Long, endRow as Long, searchString as String) as Object + Dim iHeaderPos + 'GetColumn = -1 + iHeaderPos = GetHeaderPosition(oSheet, endColumn, searchString) + If iHeaderPos = -1 Then + Exit Function + End If + GetColumnRange = oSheet.getCellRangeByPosition(iHeaderPos, 1, iHeaderPos, endRow) +End Function + +Function RemoveColumns(oSheet, endColumn as Integer, columnNames) as Long + Dim columnName as String + Dim iHeader as Integer + RemoveColumns = endColumn + For Each columnName in columnNames + iHeader = GetHeaderPosition(oSheet, endColumn, columnName) + If iHeader <> -1 Then + oSheet.getColumns().removeByIndex(iHeader, 1) + endColumn = endColumn - 1 + End If + Next + RemoveColumns = endColumn +End Function + +Function RemoveColumnsExcept(oSheet as Object, endColumn as Integer, columnNames as Variant) as Long + Dim headerStr as String, columnName as String + Dim i% : i = 0 + Dim rI% : rI = 0 + Dim columnsToRemove(endColumn) as String + Dim headerRange, headerData + Dim found as Boolean : found = False + RemoveColumnsExcept = endColumn + + headerRange = oSheet.getCellRangeByPosition(0, 0, endColumn, 0) + headerData = headerRange.getFormulaArray() + + ' TODO Handle condition when columnNames does not have valid header + ' This causes an extra string element in the array + For i = 0 To UBound(headerData(0)) + headerStr = headerData(0)(i) + found = False + For Each columnName in columnNames + If headerStr = columnName Then + found = True + Exit For + End If + Next columnName + If Not found Then + columnsToRemove(rI) = headerStr + rI = rI + 1 + End If + Next i + + If i = 0 Then + Exit Function + End If + + ReDim Preserve columnsToRemove(rI - 1) + + RemoveColumnsExcept = RemoveColumns(oSheet, endColumn, columnsToRemove) +End Function + +Sub ApplyTheme(sFileName As String) + Dim oFamilies + Dim aOptions(0) as New com.sun.star.beans.PropertyValue + Dim stylesDir() + Dim StylePath as String + GlobalScope.BasicLibraries.loadLibrary("Tools") + oFamilies = ThisComponent.StyleFamilies + StylesDir = GetOfficeSubPath("Template", "wizard/styles/") + StylePath = StylesDir & sFileName + aOptions(0).Name = "OverwriteStyles" + aOptions(0).Value = true + oFamilies.loadStylesFromURL(StylePath, aOptions()) +End Sub + +Function NaiveLastTable(oSheet) as Long + ' Return the row position last table that is separated by an empty row + Dim oRows + Dim iRow as Long + Dim usedRange + NaiveLastTable = 0 + + oRows = UsedRangeCursor(oSheet).Rows + + For iRow = 0 To oRows.getCount() - 1 + 'Print rows(i).dbg_methods() + If oRows.getByIndex(iRow).computeFunction(com.sun.star.sheet.GeneralFunction.COUNT) = 0 Then + NaiveLastTable = iRow + End If + Next +End Function + +Function IsValidFileName(fileName as String) as Boolean + Dim invalidChars as String : invalidChars = "\/:*?""<>|" + Dim c as String + Dim i as Integer + IsValidFileName = False + For i = 1 To Len(fileName) + c = Mid(fileName, i, 1) + If InStr(invalidChars, c) > 0 Then + Print "Invalid character '" & c & "' found in '" & fileName & "'" + Exit Function + End If + Next + IsValidFileName = True +End Function + +Sub ExportPDF(oSheet, exportFolder as String) + 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 + + If Not IsValidFileName(oSheet.Name) Then + Exit Sub + End If + + fileName = exportFolder & "/" & oSheet.Name & ".pdf" + + WIth fd(0) : .Name = "Selection" : .Value = UsedRangeCursor(oSheet) : End With + ' Disabled, because it conflicts with selection + With fd(1) : .Name = "SinglePageSheets" : .Value = False : End With + With fd(2) : .Name = "IsSkipEmptyPages" : .Value = True : End With + + With args(0) : .Name = "FilterName" : .Value = "calc_pdf_Export" : End With + With args(1) : .Name = "FilterData" : .Value = fd : End With + With args(2) : .Name = "Overwrite" : .Value = True : End With + + ThisComponent.storeToURL(ConvertToUrl(fileName), args) +End Sub + + +Sub ListOfActiveCustomers() + Dim oSheet, destSheet, cursor, oRange + Dim startRow as Long + Dim endRow as Long + Dim startColumn as Long + Dim endColumn as Long + Dim requiredFields() + Dim requiredFieldIndices() as Integer + Dim iColumn as Integer, iRequiredField as Integer + Dim headerCellStr as String + + oSheet = ThisComponent.Sheets(0) + cursor = UsedRangeCursor(oSheet) + + ' Skip Header + startRow = NaiveLastTable(ThisComponent, cursor) + endRow = cursor.RangeAddress.EndRow + endColumn = cursor.RangeAddress.EndColumn + ' TODO Use data from PhoneNumber if some MobileNumber is missing + requiredFields = Array("ConsumerNumber", "ConsumerName", "MobileNumber", "AreaCodeDesc", "LastDelivDate") + 'oSheet.Rows.removeByIndex(0, 3) + + For iColumn = startColumn To endColumn + headerCellStr = oSheet.getCellByPosition(iColumn, startRow, iColumn, startRow).getString() + For iRequiredField = 0 To UBound(requiredFields) + If headerCellStr = requiredFields(iRequiredField) Then + ' TODO Allocate memory before hand and use a tracker index? + ReDim Preserve requiredFieldIndices(UBound(requiredFieldIndices) + 1) + requiredFieldIndices(UBound(requiredFieldIndices)) = iColumn + End If + Next iRequiredField + Next iColumn + destSheet = NewSheet("SBC Connection") + + Print Join(requiredFieldIndices) + + ' TODO Ignore the Header Table if it exists + ' i.e. If two tables exists, assume the first one to be header table + ' and ignore it while copying to new sheet + + ' Copy the cells in 'requiredFieldIndices' to 'destSheet' +End Sub + + +Function UsedRangeCursor(Optional ByRef oSheet as Object) as Object + 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 + ' Checks headerName and headerNameMatches for the string 'str', + ' If it's not available there, a naïve implementation adds spacing to 'str' + Dim l as Long + Dim c as String + Dim i as Long + Dim prevChar as String + Dim friendlyWords : friendlyWords = GetFriendlyWords() + str = Trim(str) + ' Check if Len(str) is really called multiple times + l = Len(str) + ' Check with header "database" + + For i = 0 To UBound(friendlyWords) Step 2 + If friendlyWords(i) = str Then + UserFriendlyName = friendlyWords(i + 1) + Exit Function + End If + Next i + + 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 SortColumn(oSheet As Variant, endColumn as Integer, endRow as Integer, columnName as String) + Dim oRange as Object + Dim iHeaderPos as Integer + Dim oSortFields(1) as new com.sun.star.util.SortField + Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue + + oRange = oSheet.getCellRangeByPosition(0, 1, endColumn, endRow) + ThisComponent.getCurrentController.select(oRange) + + iHeaderPos = GetHeaderPosition(oSheet, endColumn, columnName) + If iHeaderPos = -1 Then + Exit Sub + End If + ' Area + oSortFields(0).Field = iHeaderPos + oSortFields(0).SortAscending = True + + ' TODO Enable this later + ' Date + 'oSortFields(1).Field = 4 + 'oSortFields(1).SortAscending = True + + oSortDesc(0).Name = "SortFields" + oSortDesc(0).Value = oSortFields + + oRange.Sort(oSortDesc) +End Sub + +Function NewSheet(sheetName as String) as Object + Dim sheets as Object + sheets = ThisComponent.Sheets() + If Not sheets.hasByName(sheetName) Then + sheets.insertNewByName(sheetName, sheets.getCount()) + End If + NewSheet = sheets.getByName(sheetName) +End Function + +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, endColumn as Integer, searchString as String) as Integer + Dim iColumn as Integer + Dim oCell as Object + Dim cellString as String + GetHeaderPosition = -1 + If searchString = "" Then + Exit Function + End If + If roughHeaderMatch Then + searchString = UserFriendlyName(searchString) + End If + For iColumn = 0 To endColumn + oCell = oSheet.getCellByPosition(iColumn, 0) + cellString = oCell.String + If cellString = "" Then + 'MsgBox "Cannot have empty column, endColumn is " & CStr(endColumn), 16, "Bad argument" + Exit Function + End If + If roughHeaderMatch Then + cellString = UserFriendlyName(cellString) + End If + If cellString = searchString OR Instr(cellString, searchString) = 1 Then + GetHeaderPosition = iColumn + Exit For + End If + Next iColumn +End Function + +Function HighlightRowWithColumn(ByRef oSheet as Object, endColumn as Long, endRow as Long, highlightColumnName, highlightValue, removeColumn as Boolean, Optional highlightColor as Long) as Long + Dim currentStr as String + Dim oCell as Object + Dim oCellRange as Object + Dim str as String + Dim iSearchColumn as Long + Dim i as Integer + HighlightRowWithColumn = endColumn + + + ' Search for column position that has highlightBasedOn + iSearchColumn = GetHeaderPosition(oSheet, endColumn, highlightColumnName) + If iSearchColumn = -1 Then Exit Function + For i = 0 To endRow - 1 + oCell = oSheet.getCellByPosition(iSearchColumn, i) + If InStr(oCell.getString(), highlightValue) > 0 Then + oCellRange = oSheet.getCellRangeByPosition(0, i, endColumn, i) + oCellRange.CellBackColor = highlightColor + End If + Next i + + If removeColumn Then + oSheet.Columns.removeByIndex(iSearchColumn, 1) + endColumn = endColumn - 1 + End If +End Function + +Function FindHighestDateAsString(oSheet as Object, columnName as String, endColumn as Integer, endRow as Integer) as Date + Dim dateHeaderPos + Dim dateColumn + Dim dateVal + dateHeaderPos = GetHeaderPosition(oSheet, endColumn, columnName) + If dateHeaderPos = -1 Then + MsgBox "Cannot find a column header that starts with '" & columnName & "'", 0, "Bad column name" + Exit Function + End If + ' TODO Check if the column we are searching, actually has date values. + dateColumn = oSheet.getCellRangeByPosition(dateHeaderPos, 1, dateHeaderPos, endRow) + dateVal = dateColumn.computeFunction(com.sun.star.sheet.GeneralFunction.MAX) + If dateVal = 0 Then MsgBox "Invalid date found in column '" & columnName & "' - " & dateHeaderPos & "", 16, "Bad date found" + FindHighestDateAsString = dateVal +End Function + +' TODO Use a general function that takes arrays +' and instead of the function ShortenDirections, use +' ReplaceArrays to make it more usable across other projects. +Sub ShortenDirections(oSheet as Object, columnIdx as Integer) + 'Shorten East as E. etc + Dim toReplace() as String + Dim toReplaceWith() as String + Dim i as Long + Dim oDescriptor + Dim oColumn + Dim columnToReplace + oColumn = oSheet.getColumns().getByIndex(columnIdx) + ' TODO arrange it with convention + toReplace() = Array("East", "West", "South", "North") + toReplaceWith() = Array("E.", "W.", "S.", "N.") + oDescriptor = oColumn.createReplaceDescriptor() + For i = LBound(toReplace) To UBound(toReplace) + With oDescriptor + .SearchString = toReplace(i) + .ReplaceString = toReplaceWIth(i) + End With + oColumn.replaceAll(oDescriptor) + Next i +End Sub + +Sub SetWidths(oSheet, endColumn as Integer, columnWidthArray() as Variant) + ' columnWidthArray has values like Array(Array("Area", 0), Array("ID", 2000)) + ' 0 means autofill + Dim i as Integer + Dim columnWidth + Dim iHeaderColumn + For Each columnWidth in columnWidthArray + iHeaderColumn = GetHeaderPosition(oSheet, endColumn, columnWidth(0)) + If iHeaderColumn = -1 Then + Print "Cannot find: " & columnWidth(0) & " in headers" + Exit Sub + End If + if columnWidth(1) = 0 Then + oSheet.getColumns().getByIndex(iHeaderColumn).OptimalWidth = True + Else + oSheet.getColumns().getByIndex(iHeaderColumn).Width = columnWidth(1) + End If + Next +End Sub + +</script:module>+ \ No newline at end of file
diff --git a/Standard/script.xlb b/Standard/script.xlb @@ -1,5 +1,6 @@ <?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="Bharatgas"/> + <library:element library:name="HandyTools"/> + <library:element library:name="CylinderAutomation"/> </library:library> \ No newline at end of file