How to end a Basic function properly - macros

I'm trying to write a function in Basic for LibreOffice Calc to get the first letter of each word of the selected cell using the following code:
Function GetFirstLetters(rng) As String
Dim arr
Dim I As Long
arr = Split(rng, " ")
If IsArray(arr) Then
For I = LBound(arr) To UBound(arr)
GetFirstLetters = GetFirstLetters & Left(arr(I), 1)
Next I
Else
GetFirstLetters = Left(arr, 1)
End If
End Function
And it works correctly, unless I try to execute it again, then it seems that the new result gets appended to that of any previous execution and it will return both strings together, example:
It also doesn't matter if I delete some or even all cells, or if I call it using an empty cell or even in another page, it will always append the result to the previous one:
Why does this happen? How can I fix this behaviour?
I don't know anything about Basic, so please don't bash on me if this is something very simple.
The original function is this:
Function GetFirstLetters(rng As Range) As String
'Update 20140325
Dim arr
Dim I As Long
arr = VBA.Split(rng, " ")
If IsArray(arr) Then
For I = LBound(arr) To UBound(arr)
GetFirstLetters = GetFirstLetters & Left(arr(I), 1)
Next I
Else
GetFirstLetters = Left(arr, 1)
End If
End Function
And I got it from here: http://www.extendoffice.com/documents/excel/1580-excel-extract-first-letter-of-each-word.html.

The code you have found is VBA for Excel. Openoffice or Libreoffice uses StarBasic, not VBA. This is similar but not equal. So you can't simply use the same code as in Excel.
First difference is, there is no Range object. This you have noticed and have used rng as an Variant.
But another difference is, function names are like variable names in the global scope. And they will not be reseted if the function is called again. So in StarBasic we better do:
Function GetFirstLetters(sCellValue as String) As String
Dim arr As Variant
Dim I As Long
Dim sResult As String
arr = Split(sCellValue, " ")
If IsArray(arr) Then
For I = LBound(arr) To UBound(arr)
sResult = sResult & Left(arr(I), 1)
Next I
Else
sResult = Left(arr, 1)
End If
GetFirstLetters = sResult
End Function
sResult is reseted (new Dimed) every time the function is called. So even the function's return value.

Related

Inserting and removing text into a textbox on a SHEET in Libreoffice calc BASIC

As I can't solve my problem I'd like to ask someone more experienced.I created simple dialog (4 fields) to let the user enter few data. After clicking "Submit" button those data should be inserted into textboxes put ON THE SHEET (not on any dialog). How to refer to those sheet texboxes in code to insert those data? Other thing is deleting those data after clicking other button "Clear". Suppose it will be similar to inserting but how this piece of code should look like?
Thanks in advance.
The trick is to create a com.sun.star.drawing.TextShape object and add it to the Draw Page of the target sheet. The following works for me. You should be able to assign it to the appropriate button on your dialog.
Sub InsertTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim sText As String
sText = "Blah,blah, blah!"
Dim oPosition As New com.sun.star.awt.Point
oPosition.X = 1000
oPosition.Y = 1000
Dim oSize As New com.sun.star.awt.Size
oSize.Width = 10000
oSize.Height = 5000
Dim oTextShape As Object
oTextShape = oDocument.createInstance("com.sun.star.drawing.TextShape")
oTextShape.setPosition(oPosition)
oTextShape.setSize(oSize)
oTextShape.setPropertyValue("FillStyle", "SOLID")
oTextShape.Visible = 1
' Give it a name so you can find it again when you want to delete it
oTextShape.setPropertyValue("Name", "Thingy")
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
oDrawPage.add(oTextShape)
' Set the string of the text shape AFTER adding it to the
' draw page, otherwise the text will not be set.
oTextShape.setString(sText)
End If
End Sub
In the above routine the TextShape object was given the name "Thingy". You can obviously give it any name you like, but it should be unique. To delete it, you need to loop through all the objects in the draw page, find the one that is a TextShape and has the name you gave it (in this case "Thingy") and remove it. This can be done as follows:
Sub DeleteTextBox()
Dim oDocument As Object
oDocument = ThisComponent
If oDocument.SupportsService("com.sun.star.sheet.SpreadsheetDocument") Then
Dim oDrawPage As Object
oDrawPage = oDocument.getSheets().getByIndex(0).getDrawPage()
Dim oShape As Object
Dim i As Long
For i = (oDrawPage.getCount() - 1) To 0 Step -1
oShape = oDrawPage.getByIndex(i)
If oShape.SupportsService("com.sun.star.drawing.TextShape") Then
If StrComp(oShape.getPropertyValue("Name"), "Thingy") = 0 Then
oDrawPage.remove(oShape)
End If
End If
Next i
End If
End Sub
This will delete all objects of type TextShape and named "Thingy"

In LibreOffice Calc, how do I change through LibreOffice Basic the value of a cell with an event listener set to it without crashing the program?

I am trying to create two tables which mirror changes made to any of them to one another automatically.
To that end, I added event listeners which are triggered when the cells of these tables are edited by the user.
Unfortunately, editing one of the tables causes LibreOffice to crash, even though the changes are indeed reflected correctly, as seen upon reopening the file.
I thought the crash might be due to a never-ending circular reference, but it still crashes after it has been made non-circular (by commenting out the relevant parts of the code so that changes are reflected only one way rather than both ways).
I noticed the code worked fine when writing to a cell that didn't have an event listener set to it.
How can I write to one of the cells with event listeners set to them without causing LibreOffice to crash?
You may want to download the following file. Please run Main and then try editing the cell C3 of the Planning sheet. The arbitrary string "C" should be written in the cell C4 of the Services sheet.
Here is a simplified version of the code :
REM ***** BASIC *****
const SERVICESSHEET_NUMBER = 2
const SERVICESSHEET_SERVICES_COLUMN = 2
Type cellStruct
columnNumber As Integer
rowNumber As Integer
End Type
Sub UpdateServicesSheet(editedCell As cellStruct, newValue As String)
Dim oSheets
Dim servicesSheet
oSheets = ThisComponent.getSheets()
servicesSheet = oSheets.getByIndex(SERVICESSHEET_NUMBER)
servicesSheet.getCellByPosition(SERVICESSHEET_SERVICES_COLUMN, 3).setString(newValue)
End Sub
Private oListener, cellRange as Object
Sub AddListener
Dim sheet, cell as Object
sheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost sheet
servicesSheet = ThisComponent.Sheets.getByIndex(2)
cellRange = sheet.getCellrangeByName("C3")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
cellRange = servicesSheet.getCellrangeByName("C4")
oListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
cellRange.addModifyListener(oListener) 'register the listener
End Sub
global CircularReferenceAllowed As boolean
Sub Modify_modified(oEv)
Dim editedCell As cellStruct
Dim newValue As String
editedCell.columnNumber = 2
editedCell.rowNumber = 2
If CircularReferenceAllowed Then
CircularReferenceAllowed = false
UpdateServicesSheet(editedCell, "C")
End If
End Sub
Sub Modify_disposing(oEv)
End Sub
Sub RmvListener
cellRange.removeModifyListener(oListener)
End Sub
Sub Main
CircularReferenceAllowed = true
AddListener
End Sub
Crossposted to :
OpenOffice forums
LibreOffice discourse platform
It seems like the event trigger is within another event's function is causing the crash. In any case, the solution is to remove the listener, then add it back after modifying the other cell.
You do need to global the Listener and the Cell objects to make this work.
This code is simplified to work on C3 and C15 on the first sheet. It would also output some information on C14, which isn't really necessary for your purpose, but I use it to see what's happening. You need to adopt the according to what you need.
global goListener as Object
global goListener2 as Object
global goCellR as Object
global goCellR2 as Object
global goSheet as Object
global giRun as integer
global giUpd as Integer
Sub Modify_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 14)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR2.removeModifyListener(goListener2)
oCell.setString(sCurStr)
goCellR2.addModifyListener(goListener2)
End If
sNewStr =sCurStr & " M1 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify2_modified(oEv)
Dim sCurStr$
Dim sNewStr As String
Dim oCell as Object
'xRay oEv
giRun = giRun + 1
sCurStr = oEv.source.string
oCell = goSheet.getCellByPosition(2, 2)
If (oCell.getString() <> sCurStr) Then
' only update if it's different.
giUpd = giUpd + 1
goCellR.removeModifyListener(goListener)
oCell.setString(sCurStr)
goCellR.addModifyListener(goListener)
End If
sNewStr =sCurStr & " M2 Run=" & giRun & " Upd=" & giUpd
goSheet.getCellByPosition(2, 13).setString(sNewStr)
End Sub
Sub Modify_disposing(oEv)
MsgBox "In Modify_disposing"
End Sub
Sub Modify2_disposing(oEv)
MsgBox "In Modify2_disposing"
End Sub
Sub RmvListener
MsgBox "In RmvListener"
goCellR.removeModifyListener(goListener)
goCellR2.removeModifyListener(goListener2)
End Sub
Sub AddListener
goSheet = ThisComponent.Sheets.getByIndex(0) 'get leftmost goSheet
'servicesSheet = ThisComponent.Sheets.getByIndex(2)
goCellR = goSheet.getCellrangeByName("C3")
goListener = createUnoListener("Modify_","com.sun.star.util.XModifyListener") 'create a listener
goCellR.addModifyListener(goListener) 'register the listener
goCellR2 = goSheet.getCellrangeByName("C15")
goListener2 = createUnoListener("Modify2_","com.sun.star.util.XModifyListener") 'create a listener
goCellR2.addModifyListener(goListener2) 'register the listener
End Sub
Sub Main
giRun = 0
giUpd = 0
AddListener
End Sub

how to pass cellrange to a user defined macro paramenter

i would like to work with cellranges within my macro.
Function SumIfColor(SumRange)
Dim oRange as object
Dim oSheet as object
' Get Access to the Active Spreadsheet
oSheet = ThisComponent.CurrentController.ActiveSheet
' Get access to the Range listed in Sum Range
oRange = oSheet.getCellRangeByName(SumRange).RangeAddress
End Function
The question is how can I call this function with real cellRange object instead of String. Because getCellRangeByName works only with String variable.
Because when I call the function like this
sumifcolor(B1:B3)
I got the following error:
"Object variable not set"
I read some hint here but it did not helped me.
It is not possible to pass an actual CellRange object. One solution is to pass the row and column number, similar to the second part of #Axel Richter's answer in the link:
Function SumIfColor(lcol1, lrow1, lcol2, lrow2)
sum = 0
oCellRange = ThisComponent.CurrentController.ActiveSheet.getCellRangeByPosition(_
lcol1-1,lrow1-1,lcol2-1,lrow2-1)
For lCol = 0 To oCellRange.Columns.Count -1
For lRow = 0 To oCellRange.Rows.Count -1
oCell = oCellRange.getCellByPosition(lCol, lRow)
If oCell.CellBackColor > -1 Then
sum = sum + oCell.Value
End If
Next
Next
SumIfColor = sum
End Function
To call it:
=SUMIFCOLOR(COLUMN(B1:B3),ROW(B1),COLUMN(B3),ROW(B3))
The sum will be recalculated whenever a value in the range B1:B3 is changed, because of COLUMN(B1:B3). However, apparently changing only the color of a cell does not cause it to be recalculated.

LibreOffice Macro always show #NULL! after reopening the file

I wrote a macro in LibreOffice Calc and it is able to run correctly. But if I close the file and reopen, it always show #NULL! instead of the correct value. What am I missing here?
My macro code
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Function Calculate(CalType As String) As Double
'
' Calculate Macro
'
Dim i As Integer
Calc = 0
i = 1
Do While Not IsEmpty(Cells(i, 2))
If (Cells(i, 3).Value = CalType And (Cells(i,2) = "A" Or Cells(i,2) = "B")) Then
Calculate = Calculate + Cells(i, 4).Value
ElseIf (Cells(i, 3).Value = CalType And Cells(i,2) = "C") Then
Calculate = Calculate - Cells(i, 4).Value
End If
i = i + 1
Loop
'
End Function
The calling function will be something like =Calculate(J6)
The file is saved as .ods format.
The Cells call did not work at all for me. It is from VBA, not LO Basic. However I do not think that is the main problem.
LibreOffice expects that user-defined functions will be simple, only accessing the cell that contains the formula. Since the spreadsheet has not been fully loaded yet when the function is called, it is not possible to read other cells.
The workaround is to ignore errors and wait until the document is fully loaded before running the function. Take the following code as an example:
Function ReadOtherCell(row, col)
On Error GoTo ErrorHandler
oSheet = ThisComponent.CurrentController.ActiveSheet()
oCell = oSheet.getCellByPosition(row, col)
ReadOtherCell = "value is '" & oCell.getString() & "'"
Exit Function
ErrorHandler:
Reset
End Function
Sub RecalculateAll
' This is for user-defined functions that need to read the spreadsheet.
' Assign it to the "View created" event,
' because before that, the spreadsheet is not fully loaded.
ThisComponent.calculateAll
End Sub
Enter foo in A1, and =ReadOtherCell(0,0) in A2. So far, this has the same problem -- It will fail when the document is first opened.
Now, go to Tools -> Customize. In the Events tab, highlight View created. Press Macro... and find the RecalculateAll function. Then press OK.
Now when the document is closed and reopened, cell A2 should show the result value is 'foo'.
This is derived from B. Marcelly's answer at http://ooo-forums.apache.org/en/forum/viewtopic.php?f=20&t=73090&sid=f92a89d676058ab597b4b4494833b2a0.
I had the same problem.
I noticed that in the module, i had an empty Sub Main
After i 've erased it, the functions started working again

Excel creating autofilling form

I'm trying to create a form which contains two entries:
-folder number
-list of toms which are in folders
This is for archiving purpose. Form is divided on 4 section which will be printed on labels for archive boxes.
Folders are numbered from 1 to 1500, some of them contain 1 tom of documents, some of them up to 10. For now I'm doing this manualy by just copying from the table which looks like this:
table
Only thing I need in form is TOM NUMBER from this table
form
I was trying to use VLOOKUP but it only returns first row which has searched folder number.
So bascially I want a function which will take folder number from label form and find all toms which are assigned to and write it below. first 3 digits in folder number aren't important, only last 4 digits are considered most important variable
Unfortunately vlookup will not work, you are going to have to use an array folder. I am making an assumption that you will have a table that is called [Folders]
and I am going to create a form form with some vba on how to do this.
1. Create a Table by selecting the folder dataset and push ctl+T.
Alt + F11 to enter Visual basic editor
At the top choose insert ==> UserForm
Push F4 and in the properties window name your form FileFinder
Your toolbox maynot appear if it doesn't choose view => toolbox to open
drag 2 labels, 2 listboxes, and 2 buttons, you can format it however you like.
7.Create a new Module same as adding userform only choose module
Copy paste this code
Public Function CreateWorksheet(Optional name As String = "") As Worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add
If name <> "" Then ws.name = name
Set Create = ws
End Function
Public Function LastRow() As Integer 'gets last row from column A
LastRow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
End Function
Public Function DistintFolders() As String()
Dim list() As String
Dim counter As Integer
For Each cell In ActiveSheet.Range("E2:E" & LastRow)
If Not IsInList(list, cell.Value, counter) Then
counter = counter + 1
ReDim Preserve list(1 To counter)
list(counter) = cell.Value
End If
Next cell
DistintFolders = list
End Function
Public Function TomNumberByFolder(folderName As Variant) As String()
Dim list() As String
Dim counter As Integer
Dim rowNumber As Integer
For Each cell In ActiveSheet.Range("B2:B" & LastRow)
rowNumber = rowNumber + 1
If IsCorrectFolder(folderName, rowNumber) Then
counter = counter + 1
ReDim Preserve list(1 To counter)
list(counter) = cell.Value
End If
Next cell
TomNumberByFolder = list
End Function
Public Function IsInList(ByRef list() As String, compare As String, count As Integer) As Boolean
Dim l As Variant
If compare = "" Then
IsInList = True
Exit Function
End If
If count = 0 Then
IsInList = False
Exit Function
End If
For Each l In list
If l = compare Then
IsInList = True
Exit Function
End If
Next l
IsInList = False
End Function
Public Function IsCorrectFolder(folderName As Variant, rowNumber As Integer) As Boolean
IsCorrectFolder = (ActiveSheet.Range("E" & rowNumber).Value = folderName)
End Function
double click your form and paste this code
`
Private Sub btnCancel_Click()
Unload Me
End Sub
Private Sub btnCreate_Click()
Dim ws As Worksheet
If lstTom.ListCount = 0 Then
MessageBox "Please select a folder"
End If
Set ws = ThisWorkbook.Sheets.Add
ws.Cells(1, 1).Value = "Tom Number"
ws.Cells(2, 1).Resize(Me.lstTom.ListCount, 1) = Me.lstTom.list
End Sub
Private Sub lstFolder_Click()
Dim folder As String
If ActiveSheet.name <> "Data" Then ThisWorkbook.Sheets("Data").Activate 'please name this whatever your datasheet is called
For i = 0 To lstFolder.ListCount - 1
If lstFolder.Selected(i) Then
Me.lstTom.Clear
For Each s In TomNumberByFolder(lstFolder.list(i))
With lstTom
.AddItem s
End With
Next s
End If
Next i
End Sub
Private Sub UserForm_Initialize()
For Each s In DistintFolders
With lstFolder
.AddItem s
End With
Next s
End Sub
`
please note that you may have to change sheet names if you would like I will send you this.
Download Here