HandyTools.xba (16034B)
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="HandyTools" script:language="StarBasic" script:moduleType="normal">REM ***** BASIC ***** 4 Option Explicit 5 6 Function GetFriendlyWords() as Variant 7 GetFriendlyWords = Array( _ 8 "AreaCodeDesc", "Area", _ 9 "AreaDescription", "Area", _ 10 "ConsumerNumber", "ID", _ 11 "ConsumerName", "Name", _ 12 "MobileNumber", "Mobile", _ 13 "BookDate", "Book"_ 14 ) 15 If (UBound(GetFriendlyWords) Mod 2) <> 1 Then 16 Print "Mismatch in friendlyWords array" 17 Exit Function 18 End If 19 End Function 20 21 Sub FormatRangeAsNumber(oSheet, oLocale, ByRef oFormats, oRange, formatStr as String) 22 ' BASIC equivalent of 'Text to Columns' 23 Dim formatNum as Long, i as Integer 24 Dim oReplace 25 oReplace = oRange.createReplaceDescriptor() 26 27 If oRange.getCellByPosition(0,0).getValue() = 0 Then 28 formatNum = oFormats.queryKey(formatStr, oLocale, False) 29 ' add formatStr if it doesn't exist 30 If formatNum = -1 Then 31 formatNum = oFormats.addNew(formatStr, oLocale) 32 If formatNum = -1 Then 33 MsgBox "Cannot add " & formatStr & " as NumberFormat", 0, "Fatal" 34 Exit Sub 35 End If 36 End If 37 38 With oReplace 39 .searchString = ".+" 40 .replaceString = "&" 41 .SearchRegularExpression = True 42 End With 43 44 oRange.NumberFormat = formatNum 45 oRange.replaceAll(oReplace) 46 End If 47 End Sub 48 49 Function GetColumnRange(oSheet, endColumn as Long, endRow as Long, searchString as String) as Object 50 Dim iHeaderPos 51 'GetColumn = -1 52 iHeaderPos = GetHeaderPosition(oSheet, endColumn, searchString) 53 If iHeaderPos = -1 Then 54 Exit Function 55 End If 56 GetColumnRange = oSheet.getCellRangeByPosition(iHeaderPos, 1, iHeaderPos, endRow) 57 End Function 58 59 Function RemoveColumns(oSheet, endColumn as Integer, columnNames) as Long 60 Dim columnName as String 61 Dim iHeader as Integer 62 RemoveColumns = endColumn 63 For Each columnName in columnNames 64 iHeader = GetHeaderPosition(oSheet, endColumn, columnName) 65 If iHeader <> -1 Then 66 oSheet.getColumns().removeByIndex(iHeader, 1) 67 endColumn = endColumn - 1 68 End If 69 Next 70 RemoveColumns = endColumn 71 End Function 72 73 Function RemoveColumnsExcept(oSheet as Object, endColumn as Integer, columnNames as Variant) as Long 74 Dim headerStr as String, columnName as String 75 Dim i% : i = 0 76 Dim rI% : rI = 0 77 Dim columnsToRemove(endColumn) as String 78 Dim headerRange, headerData 79 Dim found as Boolean : found = False 80 RemoveColumnsExcept = endColumn 81 82 headerRange = oSheet.getCellRangeByPosition(0, 0, endColumn, 0) 83 headerData = headerRange.getFormulaArray() 84 85 ' TODO Handle condition when columnNames does not have valid header 86 ' This causes an extra string element in the array 87 For i = 0 To UBound(headerData(0)) 88 headerStr = headerData(0)(i) 89 found = False 90 For Each columnName in columnNames 91 If headerStr = columnName Then 92 found = True 93 Exit For 94 End If 95 Next columnName 96 If Not found Then 97 columnsToRemove(rI) = headerStr 98 rI = rI + 1 99 End If 100 Next i 101 102 If i = 0 Then 103 Exit Function 104 End If 105 106 ReDim Preserve columnsToRemove(rI - 1) 107 108 RemoveColumnsExcept = RemoveColumns(oSheet, endColumn, columnsToRemove) 109 End Function 110 111 Sub ApplyTheme(sFileName As String) 112 Dim oFamilies 113 Dim aOptions(0) as New com.sun.star.beans.PropertyValue 114 Dim stylesDir() 115 Dim StylePath as String 116 GlobalScope.BasicLibraries.loadLibrary("Tools") 117 oFamilies = ThisComponent.StyleFamilies 118 StylesDir = GetOfficeSubPath("Template", "wizard/styles/") 119 StylePath = StylesDir & sFileName 120 aOptions(0).Name = "OverwriteStyles" 121 aOptions(0).Value = true 122 oFamilies.loadStylesFromURL(StylePath, aOptions()) 123 End Sub 124 125 Function NaiveLastTable(oSheet) as Long 126 ' Return the row position last table that is separated by an empty row 127 Dim oRows 128 Dim iRow as Long 129 Dim usedRange 130 NaiveLastTable = 0 131 132 oRows = UsedRangeCursor(oSheet).Rows 133 134 For iRow = 0 To oRows.getCount() - 1 135 'Print rows(i).dbg_methods() 136 If oRows.getByIndex(iRow).computeFunction(com.sun.star.sheet.GeneralFunction.COUNT) = 0 Then 137 NaiveLastTable = iRow 138 End If 139 Next 140 End Function 141 142 Function IsValidFileName(fileName as String) as Boolean 143 Dim invalidChars as String : invalidChars = "\/:*?""<>|" 144 Dim c as String 145 Dim i as Integer 146 IsValidFileName = False 147 For i = 1 To Len(fileName) 148 c = Mid(fileName, i, 1) 149 If InStr(invalidChars, c) > 0 Then 150 Print "Invalid character '" & c & "' found in '" & fileName & "'" 151 Exit Function 152 End If 153 Next 154 IsValidFileName = True 155 End Function 156 157 Sub ExportPDF(oSheet, exportFolder as String) 158 Dim cursor as Object 159 Dim args(2) as New com.sun.star.beans.PropertyValue 160 Dim fd(2) as New com.sun.star.beans.PropertyValue 161 Dim fileName as String 162 163 If Not IsValidFileName(oSheet.Name) Then 164 Exit Sub 165 End If 166 167 fileName = exportFolder & "/" & oSheet.Name & ".pdf" 168 169 WIth fd(0) : .Name = "Selection" : .Value = UsedRangeCursor(oSheet) : End With 170 ' Disabled, because it conflicts with selection 171 With fd(1) : .Name = "SinglePageSheets" : .Value = False : End With 172 With fd(2) : .Name = "IsSkipEmptyPages" : .Value = True : End With 173 174 With args(0) : .Name = "FilterName" : .Value = "calc_pdf_Export" : End With 175 With args(1) : .Name = "FilterData" : .Value = fd : End With 176 With args(2) : .Name = "Overwrite" : .Value = True : End With 177 178 ThisComponent.storeToURL(ConvertToUrl(fileName), args) 179 End Sub 180 181 182 Sub ListOfActiveCustomers() 183 Dim oSheet, destSheet, cursor, oRange 184 Dim startRow as Long 185 Dim endRow as Long 186 Dim startColumn as Long 187 Dim endColumn as Long 188 Dim requiredFields() 189 Dim requiredFieldIndices() as Integer 190 Dim iColumn as Integer, iRequiredField as Integer 191 Dim headerCellStr as String 192 193 oSheet = ThisComponent.Sheets(0) 194 cursor = UsedRangeCursor(oSheet) 195 196 ' Skip Header 197 startRow = NaiveLastTable(ThisComponent, cursor) 198 endRow = cursor.RangeAddress.EndRow 199 endColumn = cursor.RangeAddress.EndColumn 200 ' TODO Use data from PhoneNumber if some MobileNumber is missing 201 requiredFields = Array("ConsumerNumber", "ConsumerName", "MobileNumber", "AreaCodeDesc", "LastDelivDate") 202 'oSheet.Rows.removeByIndex(0, 3) 203 204 For iColumn = startColumn To endColumn 205 headerCellStr = oSheet.getCellByPosition(iColumn, startRow, iColumn, startRow).getString() 206 For iRequiredField = 0 To UBound(requiredFields) 207 If headerCellStr = requiredFields(iRequiredField) Then 208 ' TODO Allocate memory before hand and use a tracker index? 209 ReDim Preserve requiredFieldIndices(UBound(requiredFieldIndices) + 1) 210 requiredFieldIndices(UBound(requiredFieldIndices)) = iColumn 211 End If 212 Next iRequiredField 213 Next iColumn 214 destSheet = NewSheet("SBC Connection") 215 216 Print Join(requiredFieldIndices) 217 218 ' TODO Ignore the Header Table if it exists 219 ' i.e. If two tables exists, assume the first one to be header table 220 ' and ignore it while copying to new sheet 221 222 ' Copy the cells in 'requiredFieldIndices' to 'destSheet' 223 End Sub 224 225 226 Function UsedRangeCursor(Optional ByRef oSheet as Object) as Object 227 Dim cursor as Object 228 if IsNull(oSheet) Or IsMissing(oSheet) Then 229 oSheet = ThisComponent.getCurrentController().getActiveSheet() 230 End If 231 cursor = oSheet.createCursor() 232 cursor.gotoStartOfUsedArea(False) 233 cursor.gotoEndOfUsedArea(True) 234 UsedRangeCursor = cursor 235 End Function 236 237 Function UserFriendlyName(str as String) as String 238 ' Checks headerName and headerNameMatches for the string 'str', 239 ' If it's not available there, a naïve implementation adds spacing to 'str' 240 Dim l as Long 241 Dim c as String 242 Dim i as Long 243 Dim prevChar as String 244 Dim friendlyWords : friendlyWords = GetFriendlyWords() 245 str = Trim(str) 246 ' Check if Len(str) is really called multiple times 247 l = Len(str) 248 ' Check with header "database" 249 250 For i = 0 To UBound(friendlyWords) Step 2 251 If friendlyWords(i) = str Then 252 UserFriendlyName = friendlyWords(i + 1) 253 Exit Function 254 End If 255 Next i 256 257 For i = 0 To l 258 c = Mid(str, i + 1, 1) 259 If i > 1 And (c > "A" And c < "Z") Then 260 ' Only prepend space if 'c' is not the first character... 261 ' or previous char doesn't have space 262 UserFriendlyName = UserFriendlyName & IIf(prevChar = " ", "", " ") & c 263 Else 264 UserFriendlyName = UserFriendlyName & c 265 End If 266 prevChar = c 267 Next 268 End Function 269 270 Sub SortColumn(oSheet As Variant, endColumn as Integer, endRow as Integer, columnName as String) 271 Dim oRange as Object 272 Dim iHeaderPos as Integer 273 Dim oSortFields(1) as new com.sun.star.util.SortField 274 Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue 275 276 oRange = oSheet.getCellRangeByPosition(0, 1, endColumn, endRow) 277 ThisComponent.getCurrentController.select(oRange) 278 279 iHeaderPos = GetHeaderPosition(oSheet, endColumn, columnName) 280 If iHeaderPos = -1 Then 281 Exit Sub 282 End If 283 ' Area 284 oSortFields(0).Field = iHeaderPos 285 oSortFields(0).SortAscending = True 286 287 ' TODO Enable this later 288 ' Date 289 'oSortFields(1).Field = 4 290 'oSortFields(1).SortAscending = True 291 292 oSortDesc(0).Name = "SortFields" 293 oSortDesc(0).Value = oSortFields 294 295 oRange.Sort(oSortDesc) 296 End Sub 297 298 Function NewSheet(sheetName as String) as Object 299 Dim sheets as Object 300 sheets = ThisComponent.Sheets() 301 If Not sheets.hasByName(sheetName) Then 302 sheets.insertNewByName(sheetName, sheets.getCount()) 303 End If 304 NewSheet = sheets.getByName(sheetName) 305 End Function 306 307 Sub CleanColumnHeaders(oSheet as Object, endColumn as Integer) 308 Dim cell as Object 309 Dim neatName as String 310 Dim i as Integer 311 For i = 0 To endColumn 312 cell = oSheet.getCellByPosition(i, 0) 313 neatName = cell.getString() 314 neatName = UserFriendlyName(neatName) 315 cell.setString(neatName) 316 Next 317 End Sub 318 319 Sub RemoveExtraMergeCells(oSheet as Object, oRangeAddress as Variant) 320 Dim oRange as Object 321 Dim oSortFields(0) as new com.sun.star.util.SortField 322 Dim oSortDesc(0) as new com.sun.star.beans.PropertyValue 323 Dim endRow as Integer 324 325 endRow = oRangeAddress.EndRow 326 lastColumn = oRangeAddress.EndColumn 327 328 rem set the range on which to sort' 329 330 'oRange = oSheet.getCellRangeByName("A2:F20") 331 oRange = oSheet.getCellRangeByPosition(0, 0, lastColumn, 0) 332 ThisComponent.getCurrentController.select(oRange) 333 initialColumnCount = oRange.Columns.getCount() - 1 334 deletedColumns = 0 335 For j = 0 To (initialColumnCount - deletedColumns) 336 oCell = oRange.getCellByPosition(j, 0) 337 con = oCell.String 338 If con = "" Then 339 oRange.Columns.removeByIndex(j, 1) 340 deletedColumns = deletedColumns - 1 341 Else 342 Print con 343 End If 344 Next 345 End Sub 346 347 348 Sub UnFreezeSelection 349 Dim document as Object 350 Dim dispatcher as Object 351 document = ThisComponent.CurrentController.Frame 352 dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") 353 dispatcher.executeDispatch(document, ".uno:FreezePanes", "", 0, Array()) 354 End Sub 355 356 Function GetHeaderPosition(ByRef oSheet as Object, endColumn as Integer, searchString as String) as Integer 357 Dim iColumn as Integer 358 Dim oCell as Object 359 Dim cellString as String 360 GetHeaderPosition = -1 361 If searchString = "" Then 362 Exit Function 363 End If 364 If roughHeaderMatch Then 365 searchString = UserFriendlyName(searchString) 366 End If 367 For iColumn = 0 To endColumn 368 oCell = oSheet.getCellByPosition(iColumn, 0) 369 cellString = oCell.String 370 If cellString = "" Then 371 'MsgBox "Cannot have empty column, endColumn is " & CStr(endColumn), 16, "Bad argument" 372 Exit Function 373 End If 374 If roughHeaderMatch Then 375 cellString = UserFriendlyName(cellString) 376 End If 377 If cellString = searchString OR Instr(cellString, searchString) = 1 Then 378 GetHeaderPosition = iColumn 379 Exit For 380 End If 381 Next iColumn 382 End Function 383 384 Function HighlightRowWithColumn(ByRef oSheet as Object, endColumn as Long, endRow as Long, highlightColumnName, highlightValue, removeColumn as Boolean, Optional highlightColor as Long) as Long 385 Dim currentStr as String 386 Dim oCell as Object 387 Dim oCellRange as Object 388 Dim str as String 389 Dim iSearchColumn as Long 390 Dim i as Integer 391 HighlightRowWithColumn = endColumn 392 393 394 ' Search for column position that has highlightBasedOn 395 iSearchColumn = GetHeaderPosition(oSheet, endColumn, highlightColumnName) 396 If iSearchColumn = -1 Then Exit Function 397 For i = 0 To endRow - 1 398 oCell = oSheet.getCellByPosition(iSearchColumn, i) 399 If InStr(oCell.getString(), highlightValue) > 0 Then 400 oCellRange = oSheet.getCellRangeByPosition(0, i, endColumn, i) 401 oCellRange.CellBackColor = highlightColor 402 End If 403 Next i 404 405 If removeColumn Then 406 oSheet.Columns.removeByIndex(iSearchColumn, 1) 407 endColumn = endColumn - 1 408 End If 409 End Function 410 411 Function FindHighestDateAsString(oSheet as Object, columnName as String, endColumn as Integer, endRow as Integer) as Date 412 Dim dateHeaderPos 413 Dim dateColumn 414 Dim dateVal 415 dateHeaderPos = GetHeaderPosition(oSheet, endColumn, columnName) 416 If dateHeaderPos = -1 Then 417 MsgBox "Cannot find a column header that starts with '" & columnName & "'", 0, "Bad column name" 418 Exit Function 419 End If 420 ' TODO Check if the column we are searching, actually has date values. 421 dateColumn = oSheet.getCellRangeByPosition(dateHeaderPos, 1, dateHeaderPos, endRow) 422 dateVal = dateColumn.computeFunction(com.sun.star.sheet.GeneralFunction.MAX) 423 If dateVal = 0 Then MsgBox "Invalid date found in column '" & columnName & "' - " & dateHeaderPos & "", 16, "Bad date found" 424 FindHighestDateAsString = dateVal 425 End Function 426 427 ' TODO Use a general function that takes arrays 428 ' and instead of the function ShortenDirections, use 429 ' ReplaceArrays to make it more usable across other projects. 430 Sub ShortenDirections(oSheet as Object, columnIdx as Integer) 431 'Shorten East as E. etc 432 Dim toReplace() as String 433 Dim toReplaceWith() as String 434 Dim i as Long 435 Dim oDescriptor 436 Dim oColumn 437 Dim columnToReplace 438 oColumn = oSheet.getColumns().getByIndex(columnIdx) 439 ' TODO arrange it with convention 440 toReplace() = Array("East", "West", "South", "North") 441 toReplaceWith() = Array("E.", "W.", "S.", "N.") 442 oDescriptor = oColumn.createReplaceDescriptor() 443 For i = LBound(toReplace) To UBound(toReplace) 444 With oDescriptor 445 .SearchString = toReplace(i) 446 .ReplaceString = toReplaceWIth(i) 447 End With 448 oColumn.replaceAll(oDescriptor) 449 Next i 450 End Sub 451 452 Sub SetWidths(oSheet, endColumn as Integer, columnWidthArray() as Variant) 453 ' columnWidthArray has values like Array(Array("Area", 0), Array("ID", 2000)) 454 ' 0 means autofill 455 Dim i as Integer 456 Dim columnWidth 457 Dim iHeaderColumn 458 For Each columnWidth in columnWidthArray 459 iHeaderColumn = GetHeaderPosition(oSheet, endColumn, columnWidth(0)) 460 If iHeaderColumn = -1 Then 461 Print "Cannot find: " & columnWidth(0) & " in headers" 462 Exit Sub 463 End If 464 if columnWidth(1) = 0 Then 465 oSheet.getColumns().getByIndex(iHeaderColumn).OptimalWidth = True 466 Else 467 oSheet.getColumns().getByIndex(iHeaderColumn).Width = columnWidth(1) 468 End If 469 Next 470 End Sub 471 472 </script:module>