lobasic-macros

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 <?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( _
	    &quot;AreaCodeDesc&quot;, &quot;Area&quot;, _
	     &quot;AreaDescription&quot;,  &quot;Area&quot;, _
	    &quot;ConsumerNumber&quot;, &quot;ID&quot;, _
	    &quot;ConsumerName&quot;, &quot;Name&quot;, _
	    &quot;MobileNumber&quot;, &quot;Mobile&quot;, _
	    &quot;BookDate&quot;, &quot;Book&quot;_
	    )
	    If (UBound(GetFriendlyWords) Mod 2) &lt;&gt; 1 Then
			Print &quot;Mismatch in friendlyWords array&quot;
			Exit Function
		End If
End Function

Sub FormatRangeAsNumber(oSheet, oLocale, ByRef oFormats, oRange, formatStr as String)
	&apos; BASIC equivalent of &apos;Text to Columns&apos;
	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)
		&apos; add formatStr if it doesn&apos;t exist
		If formatNum = -1 Then
			formatNum = oFormats.addNew(formatStr, oLocale)
			If formatNum = -1 Then
				MsgBox &quot;Cannot add &quot; &amp; formatStr &amp; &quot; as NumberFormat&quot;, 0, &quot;Fatal&quot;
				Exit Sub
			End If
		End If
		
		With oReplace
			.searchString = &quot;.+&quot;
			.replaceString = &quot;&amp;&quot;
			.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
	&apos;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 &lt;&gt; -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()

	&apos; TODO Handle condition when columnNames does not have valid header
	&apos; 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(&quot;Tools&quot;)
	oFamilies = ThisComponent.StyleFamilies
	StylesDir = GetOfficeSubPath(&quot;Template&quot;, &quot;wizard/styles/&quot;)
	StylePath = StylesDir &amp; sFileName
	aOptions(0).Name = &quot;OverwriteStyles&quot;
	aOptions(0).Value = true
	oFamilies.loadStylesFromURL(StylePath, aOptions())
End Sub

Function NaiveLastTable(oSheet) as Long
	&apos; 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
		&apos;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 = &quot;\/:*?&quot;&quot;&lt;&gt;|&quot;
    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) &gt; 0 Then
    		Print &quot;Invalid character &apos;&quot; &amp; c &amp; &quot;&apos; found in &apos;&quot; &amp; fileName &amp; &quot;&apos;&quot;
    		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 &amp; &quot;/&quot; &amp; oSheet.Name &amp; &quot;.pdf&quot;
	
	WIth fd(0) : .Name = &quot;Selection&quot; : .Value = UsedRangeCursor(oSheet) : End With
	&apos; Disabled, because it conflicts with selection
	With fd(1) : .Name = &quot;SinglePageSheets&quot; : .Value = False : End With
	With fd(2) : .Name = &quot;IsSkipEmptyPages&quot; : .Value = True : End With

	With args(0) : .Name = &quot;FilterName&quot; : .Value = &quot;calc_pdf_Export&quot; : End With
	With args(1) : .Name = &quot;FilterData&quot; : .Value = fd : End With
	With args(2) : .Name = &quot;Overwrite&quot; : .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)

	&apos; Skip Header
	startRow =  NaiveLastTable(ThisComponent, cursor)
	endRow = cursor.RangeAddress.EndRow
	endColumn = cursor.RangeAddress.EndColumn
	&apos; TODO Use data from PhoneNumber if some MobileNumber is missing
	requiredFields = Array(&quot;ConsumerNumber&quot;, &quot;ConsumerName&quot;, &quot;MobileNumber&quot;, &quot;AreaCodeDesc&quot;, &quot;LastDelivDate&quot;)
	&apos;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
				&apos; 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(&quot;SBC Connection&quot;)
	
	Print Join(requiredFieldIndices)
	
	&apos; TODO Ignore the Header Table if it exists
	&apos; i.e. If two tables exists, assume the first one to be header table
	&apos; and ignore it while copying to new sheet
	
	&apos; Copy the cells in &apos;requiredFieldIndices&apos; to &apos;destSheet&apos;
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
	&apos; Checks headerName and headerNameMatches for the string &apos;str&apos;,
	&apos; If it&apos;s not available there, a naïve implementation adds spacing to &apos;str&apos;
	Dim l as Long
	Dim c as String
	Dim i as Long
	Dim prevChar as String
	Dim friendlyWords : friendlyWords = GetFriendlyWords()
	str = Trim(str)
	&apos; Check if Len(str) is really called multiple times
	l = Len(str)
	&apos; Check with header &quot;database&quot;

	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 &gt; 1 And (c &gt; &quot;A&quot; And c &lt; &quot;Z&quot;) Then
				&apos; Only prepend space if &apos;c&apos; is not the first character...
				&apos; or previous char doesn&apos;t have space
				UserFriendlyName = UserFriendlyName &amp;  IIf(prevChar = &quot; &quot;, &quot;&quot;, &quot; &quot;)  &amp; c
		Else
			UserFriendlyName = UserFriendlyName &amp; 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
	&apos; Area
	oSortFields(0).Field = iHeaderPos
	oSortFields(0).SortAscending = True
	
	&apos; TODO Enable this later
	&apos; Date
	&apos;oSortFields(1).Field = 4
	&apos;oSortFields(1).SortAscending = True
	
	oSortDesc(0).Name = &quot;SortFields&quot;
    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&apos;

	&apos;oRange = oSheet.getCellRangeByName(&quot;A2:F20&quot;)
	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 = &quot;&quot; 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(&quot;com.sun.star.frame.DispatchHelper&quot;)
	dispatcher.executeDispatch(document, &quot;.uno:FreezePanes&quot;, &quot;&quot;, 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 = &quot;&quot; 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 = &quot;&quot; Then
        	&apos;MsgBox &quot;Cannot have empty column, endColumn is &quot; &amp; CStr(endColumn), 16, &quot;Bad argument&quot;
        	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
	

	&apos; 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) &gt; 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 &quot;Cannot find a column header that starts with &apos;&quot; &amp; columnName &amp; &quot;&apos;&quot;, 0, &quot;Bad column name&quot;
		Exit Function
	End If
	&apos; 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 &quot;Invalid date found in column &apos;&quot; &amp; columnName &amp; &quot;&apos; - &quot; &amp; dateHeaderPos &amp; &quot;&quot;, 16, &quot;Bad date found&quot;
	FindHighestDateAsString = dateVal
End Function

&apos; TODO Use a general function that takes arrays
&apos; and instead of the function ShortenDirections, use
&apos; ReplaceArrays to make it more usable across other projects.
Sub ShortenDirections(oSheet as Object, columnIdx as Integer)
	&apos;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)
	&apos; TODO arrange it with convention
	toReplace() = Array(&quot;East&quot;, &quot;West&quot;, &quot;South&quot;, &quot;North&quot;)
	toReplaceWith() = Array(&quot;E.&quot;, &quot;W.&quot;, &quot;S.&quot;, &quot;N.&quot;)
	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)
	&apos; columnWidthArray has values like Array(Array(&quot;Area&quot;, 0), Array(&quot;ID&quot;, 2000))
	&apos; 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 &quot;Cannot find: &quot; &amp; columnWidth(0) &amp; &quot; in headers&quot;
			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>