Bharatgas.xba (13110B)
1 <?xml version="1.0" encoding="UTF-8"?> 2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> 3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Bharatgas" script:language="StarBasic">REM ***** BASIC ***** 4 'Option VBASupport 1 5 Option Explicit 6 7 Global Const exportFolder = "C:\Users\bhara\tSync\Pending-01-07-2024" 8 Global Const rowsToSkip = 1 9 Global Const insertNewRowFor = False 10 Global Const printOnlySummary = False 11 Global Const roughHeaderMatch = True 12 Global Const highlightBasedOn = "Payment Option" 13 Global Const highlightSearchString = "Online Payment" 14 Global Const highlightRemoveColumn = True 15 ' TODO change suffix based on the report type 16 Global Const sheetNameSuffix = "- PENDING" 17 Global Const shouldExportPDF = True 18 Global Const isPendingReport = True 19 20 Function UsedRangeCursor(Optional ByRef oSheet as Object) as Object 21 'FIXME Check if the split has already happen 22 Dim cursor as Object 23 if IsNull(oSheet) Or IsMissing(oSheet) Then 24 oSheet = ThisComponent.getCurrentController().getActiveSheet() 25 End If 26 cursor = oSheet.createCursor() 27 cursor.gotoStartOfUsedArea(False) 28 cursor.gotoEndOfUsedArea(True) 29 UsedRangeCursor = cursor 30 End Function 31 32 Function UserFriendlyName(str as String) as String 33 Dim l as Long 34 Dim c as String 35 Dim i as Long 36 Dim prevChar as String 37 str = Trim(str) 38 ' Check if Len(str) is really called multiple times 39 l = Len(str) 40 For i = 0 To l 41 c = Mid(str, i + 1, 1) 42 If i > 1 And (c > "A" And c < "Z") Then 43 ' Only prepend space if 'c' is not the first character... 44 ' or previous char doesn't have space 45 UserFriendlyName = UserFriendlyName & IIf(prevChar = " ", "", " ") & c 46 Else 47 UserFriendlyName = UserFriendlyName & c 48 End If 49 prevChar = c 50 Next 51 End Function 52 53 Sub TestFn() 54 MsgBox UserFriendlyName("Area Name") 55 MsgBox UserFriendlyName("AreaName") 56 MsgBox UserFriendlyName(" AreaName") 57 End Sub 58 59 Sub SortAreaName(Optional oSheet As Variant, Optional cursor as Variant) 60 Dim oRange as Object 61 Dim oSortFields(1) as new com.sun.star.util.SortField 62 Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue 63 Dim endRow as Integer 64 Dim endColumn as Integer 65 66 If IsMissing(oSheet) Then 67 oSheet = ThisComponent.Sheets(0) 68 cursor = UsedRangeCursor(oSheet) 69 End If 70 71 endRow = cursor.RangeAddress.EndRow 72 endColumn = cursor.RangeAddress.EndColumn 73 74 oRange = oSheet.getCellRangeByPosition(0, 1, endColumn, endRow) 75 ThisComponent.getCurrentController.select(oRange) 76 77 ' Area 78 oSortFields(0).Field = 0 79 oSortFields(0).SortAscending = True 80 81 ' FIXME This is not working 82 ' Date 83 oSortFields(1).Field = 4 84 oSortFields(1).SortAscending = True 85 86 oSortDesc(0).Name = "SortFields" 87 oSortDesc(0).Value = oSortFields 88 89 oRange.Sort(oSortDesc) 90 End Sub 91 92 Sub NewSheet(sheetName as String) 93 Dim sheets as Object 94 sheets = ThisComponent.Sheets() 95 If Not sheets.hasByName(sheetName) Then 96 sheets.insertNewByName(sheetName, sheets.getCount()) 97 End If 98 99 End Sub 100 101 Sub CleanColumnHeaders(oSheet as Object, endColumn as Integer) 102 Dim cell as Object 103 Dim neatName as String 104 Dim i as Integer 105 For i = 0 To endColumn 106 cell = oSheet.getCellByPosition(i, 0) 107 neatName = cell.getString() 108 neatName = UserFriendlyName(neatName) 109 cell.setString(neatName) 110 Next 111 End Sub 112 113 Sub RemoveExtraMergeCells(oSheet as Object, oRangeAddress as Variant) 114 Dim oRange as Object 115 Dim oSortFields(0) as new com.sun.star.util.SortField 116 Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue 117 Dim endRow as Integer 118 119 endRow = oRangeAddress.EndRow 120 lastColumn = oRangeAddress.EndColumn 121 122 rem set the range on which to sort' 123 124 'oRange = oSheet.getCellRangeByName("A2:F20") 125 oRange = oSheet.getCellRangeByPosition(0, 0, lastColumn, 0) 126 ThisComponent.getCurrentController.select(oRange) 127 initialColumnCount = oRange.Columns.getCount() - 1 128 deletedColumns = 0 129 For j = 0 To (initialColumnCount - deletedColumns) 130 oCell = oRange.getCellByPosition(j, 0) 131 con = oCell.String 132 If con = "" Then 133 oRange.Columns.removeByIndex(j, 1) 134 deletedColumns = deletedColumns - 1 135 Else 136 Print con 137 End If 138 Next 139 End Sub 140 141 142 Sub UnFreezeSelection 143 Dim document as Object 144 Dim dispatcher as Object 145 document = ThisComponent.CurrentController.Frame 146 dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") 147 dispatcher.executeDispatch(document, ".uno:FreezePanes", "", 0, Array()) 148 End Sub 149 150 Function GetHeaderPosition(ByRef oSheet as Object, searchString as String, endColumn as Long) as Integer 151 Dim iColumn as Integer 152 Dim oCell as Object 153 Dim cellString as String 154 GetHeaderPosition = -1 155 If roughHeaderMatch Then 156 searchString = UserFriendlyName(searchString) 157 End If 158 For iColumn = 0 To endColumn - 1 159 oCell = oSheet.getCellByPosition(iColumn, 0) 160 cellString = oCell.String 161 If roughHeaderMatch Then 162 cellString = UserFriendlyName(cellString) 163 End If 164 If cellString = searchString Then 165 GetHeaderPosition = iColumn 166 Exit For 167 End If 168 Next iColumn 169 End Function 170 171 Sub HighlightOnline(ByRef oSheet as Object, endColumn as Long, endRow as Long) 172 ' Fix false positives when having ONLINE and the content has "Online Payment" 173 Dim currentStr as String 174 Dim oCell as Object 175 Dim oCellRange as Object 176 Dim str as String 177 Dim iSearchColumn as Long 178 Dim i as Integer 179 180 ' Search for column position that has highlightBasedOn 181 iSearchColumn = GetHeaderPosition(oSheet, highlightBasedOn, endRow) 182 If iSearchColumn = -1 Then Exit Sub 183 For i = 0 To endRow - 1 184 oCell = oSheet.getCellByPosition(iSearchColumn, i) 185 If InStr(oCell.getString(), highlightSearchString) > 0 Then 186 oCellRange = oSheet.getCellRangeByPosition(0, i, endColumn, i) 187 oCellRange.CellBackColor = RGB(255, 255, 0) ' Yellow 188 End If 189 Next i 190 191 If highlightRemoveColumn Then 192 oSheet.Columns.removeByIndex(iSearchColumn, 1) 193 End If 194 End Sub 195 196 197 Sub MainNew 198 Dim oRange as Object 199 Dim oSheet as Object 200 Dim oCellStyle as Object 201 Dim pageStyle as Object 202 Dim oStyle as Object 203 oSheet = ThisComponent.Sheets.getByIndex(0) 204 'oRange = oSheet.getCellRangeByPosition(1, 1, 4, 1) 205 'oCellStyle = ThisComponent.StyleFamilies.getByName("CellStyles").getByName("InterHeader") 206 'oRange.CellStyle = "InterHeader" 207 pageStyle = ThisComponent.StyleFamilies.getByName("PageStyles") 208 oStyle = pageStyle.getByName("Default") 209 oStyle.CenterVertically = True 210 pageStyle.insertByName("NewStyle") 211 212 if NOT IsNull(pageStyle) then 213 Print pageStyle.dbg_methods 214 end if 215 216 End Sub 217 218 Sub Main 219 Dim s as Object 220 Dim cursor as Object 221 Dim c as Integer 222 Dim destSheet as Variant 223 Dim sheetName as String 224 Dim iArea as Long 225 Dim d as String 226 Dim a as String 227 Dim startRow as Long 228 Dim areaNames as New Collection 229 Dim dColumns as Object 230 Dim endRow as Long 231 Dim endColumn as Long 232 Dim areaColumn as Object 233 Dim areaRange, idRange, bookRange 234 Dim headerRange as Object 235 Dim cellRangeToCopy as Object 236 Dim pageStyle as Object 237 238 s = ThisComponent.Sheets(0) 239 cursor = UsedRangeCursor(s) 240 241 ' Skip Header 242 startRow = rowsToSkip 243 endRow = cursor.RangeAddress.EndRow 244 endColumn = cursor.RangeAddress.EndColumn 245 246 ' TODO pass the column name/index as an argument 247 ' Transformations to be applied to the Main sheet before splitting the sheet by Area Name 248 'Call UnFreezeSelection 249 cursor = UsedRangeCursor(s) 250 If isPendingReport Then 251 Call HighlightOnline(s, endColumn, endRow) 252 End If 253 Call SortAreaName(s, cursor) 254 Call CleanColumnHeaders(s, endColumn) 255 256 ' Justify Leftmost cells to left and Rightmost cells to right 257 ' TODO Maybe use more descriptive code? Like ("AreaName")? 258 idRange = s.getCellRangeByPosition(1,startRow, 1, endRow) 259 idRange.setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.LEFT) 260 261 bookRange = s.getCellRangeByPosition(endColumn, startRow, endColumn, endRow) 262 bookRange.setPropertyValue("HoriJustify", com.sun.star.table.CellHoriJustify.RIGHT) 263 264 areaColumn = s.getCellRangeByPosition(0,startRow, 0, endRow) 265 headerRange = s.getCellRangeByPosition(0, 0, endColumn, 0) 266 267 headerRange.CellStyle = "Heading 1" 268 269 'On Error Goto ErrorHandler 270 For iArea = rowsToSkip To endRow - 1 271 d = areaColumn.getCellByPosition(0, iArea).String 272 If d = "" Then 273 Exit For 274 End If 275 276 If a <> d Or iArea = (endRow - 1) Then 277 ' FIXME Get the columns automatically from the sheet 278 ' FIXME Covert the end column from endColumn above 279 280 If insertNewRowFor Then 281 ' FIXME This is a stub, not correct 282 s.Rows.insertByIndex(startRow, 1) 283 startRow = startRow + 1 284 endRow = endRow + 1 285 End If 286 287 areaRange = s.getCellRangeByPosition(0, startRow, endColumn, iArea) 288 If printOnlySummary Then 289 ' TODO maybe there is an elegant way than 290 ' writing this two times 291 If shouldExportPDF Then 292 ExportPDF(destSheet) 293 End If 294 GoTo Continue 295 End If 296 297 ' TODO subtotals might solve this 298 's.group(areaRange.RangeAddress, 1) 299 300 sheetName = a & sheetNameSuffix 301 302 ' Copy the Headers from the Main Document 303 ' FIXME This DOES NOT work when using with filtered data 304 ' TODO Get the number of columns to copy dynamically from the Sheet. 305 cellRangeToCopy = areaRange.RangeAddress 306 307 If (cellRangeToCopy.EndRow - cellRangeToCopy.StartRow) = 0 Then 308 Goto Continue 309 End If 310 311 ' Prepare Destination sheet 312 NewSheet(sheetName) 313 314 destSheet = ThisComponent.Sheets().getByName(sheetName) 315 316 pageStyle = ThisComponent.StyleFamilies.getByName("PageStyles").getByName("Default") 317 pageStyle.setPropertyValue("PrintGrid", True) 318 pageStyle.setPropertyValue("CenterHorizontally", True) 319 ' Make the margins 0.2" thick 320 pageStyle.setPropertyValue("LeftMargin", 0.2 * 2540) 321 pageStyle.setPropertyValue("RightMargin", 0.2 * 2540) 322 323 ' Customize the Destination Sheet's Columns 324 ' TODO Make snuggly calculation. There should be a minimum width and AutoFit 325 With destSheet.getColumns() 326 If isPendingReport Then 327 .getByName("B").Width = 2500 328 .getByName("C").Width = 8000 329 .getByName("D").Width = 2500 330 Else 331 .getByName("B").Width = 1700 332 .getByName("C").Width = 5000 333 .getByName("D").Width = 11000 334 .getByName("E").Width = 2200 335 End If 336 End With 337 338 339 ' Copy Header 340 ' TODO Check if it's possible to use UsedRange instead of endColumn 341 s.copyRange(destSheet.getCellRangeByName("A1").CellAddress, _ 342 headerRange.RangeAddress) 343 344 ' Copy all the contents uptil 345 s.copyRange(destSheet.getCellRangeByName("A2").CellAddress, _ 346 cellRangeToCopy) 347 348 'TODO Remove Columns that should be deleted in leaveColumns 349 ' Better leave it when copying above 350 destSheet.getColumns().removeByIndex(0, 1) 351 destSheet.getColumns().removeByIndex(4, 1) 352 353 354 'TODO Maybe use Dispatcher? 355 If shouldExportPDF Then 356 ExportPDF(destSheet) 357 End If 358 Continue: 359 startRow = (iArea + 1) 360 a = d 361 End If 362 Next iArea 363 364 ErrorHandler: 365 MsgBox "Error#: " & Erl & Error 366 'MsgBox "arrCount: " & areaNames.Count 367 MsgBox "a: " & a & ", d: " & d 368 Reset 369 End Sub 370 371 Sub ValidateFileName(fileName as String) 372 Dim invalidChars as String : invalidChars = "\/:*?""<>|" 373 374 For i = 1 To Len(fileName) 375 c = Mid(fileName, i, 1) 376 If InStr(invalidChars, c) > 0 Then 377 Print "invalid" & c 378 End If 379 Next 380 End Sub 381 382 Sub ExportPDF(Optional ByVal oSheet as Object) 383 'Exit Sub 384 Dim cursor as Object 385 Dim args(2) as New com.sun.star.beans.PropertyValue 386 Dim fd(2) as New com.sun.star.beans.PropertyValue 387 388 Dim fileName as String 389 Dim fileUrl As String 390 391 cursor = UsedRangeCursor(oSheet) 392 393 'ThisComponent.CurrentController.select(cursor) 394 fileName = exportFolder & "\" & oSheet.Name & ".pdf" 395 fileUrl = ConvertToUrl(fileName) 396 397 With args(0) : .Name = "FilterName" : .Value = "calc_pdf_Export" : End With 398 WIth fd(0) : .Name = "Selection" : .Value = cursor : End With 399 400 ' conflicts with the Selection 401 With fd(1) : .Name = "SinglePageSheets" : .Value = False : End With 402 With fd(2) : .Name = "IsSkipEmptyPages" : .Value = True : End With 403 404 With args(1) : .Name = "FilterData" : .Value = fd : End With 405 With args(2) : .Name = "Overwrite" : .Value = True : End With 406 407 ThisComponent.storeToURL(fileUrl, args) 408 End Sub 409 410 </script:module>