REM ***** BASIC *****
Sub hell_world
dim hell_world as object
hell_world = Range("G31:G42")
Range("H45") = WorksheetFunction.Average(hell_world)
End Sub
I have that and I get the error:
BASIC runtime error.
Sub-procedure or function procedure not defined.
What should I do?
Thanks.
Use XFunctionAccess as described in 6.28. Use FunctionAccess to call Calc Functions of Andrew Pitonyak's macro document.
Sub CallAverage
Dim oSheet, oRange, oCell, nResult, oFuncAcc
oSheet = ThisComponent.CurrentController.ActiveSheet
oRange = oSheet.getCellRangeByName("G31:G42")
oCell = oSheet.getCellRangeByName("H45")
oFuncAcc = CreateUnoService("com.sun.star.sheet.FunctionAccess")
nResult = oFuncAcc.callFunction("Average", Array(oRange))
oCell.setValue(nResult)
End Sub
Related
I am writing a macro to generate pie chart in OpenOffice Basic but I can't find the method to change the colour of the different part of the pie.
We can take as example the macro of this subject:
OpenOffice Calc macro to add pie chart
That is, my data are:
And my code:
Sub Macro1
Dim oRange as Object
Dim oRangeAddress(1) As New com.sun.star.table.CellRangeAddress
Dim oRect As New com.sun.star.awt.Rectangle
Dim cTitle as String
oRange = thisComponent.getCurrentSelection.getRangeAddress
oSheets = ThisComponent.getSheets()
oSheet = oSheets.getByIndex(0)
oCharts = oSheet.Charts
oRect.Width = 10000
oRect.Height = 10000
oRect.X = 8000
oRect.Y = 1000
oRangeAddress(0).Sheet = oRange.Sheet
oRangeAddress(0).StartColumn = 0
oRangeAddress(0).StartRow = 0
oRangeAddress(0).EndColumn = 1
oRangeAddress(0).EndRow = 2
cTitle = "Test Results"
oCharts.addNewByName(cTitle,oRect,oRangeAddress(),TRUE, TRUE)
oChart = oCharts.getByName(cTitle).embeddedObject
oChart.Diagram = oChart.createInstance("com.sun.star.chart.PieDiagram")
oChart.HasMainTitle = True
oChart.Title.String = cTitle
End Sub
How can I get some green in my chart, instead of blue, for example?
Thank you for your help.
Here is one solution.
Sub Macro1
...
oFirstDiagram = oChart.getFirstDiagram()
oColorScheme = CreateUnoListener("XColorScheme_", "com.sun.star.chart2.XColorScheme")
oFirstDiagram.setDefaultColorScheme(oColorScheme)
End Sub
Function XColorScheme_getColorByIndex(index As Integer) As Long
Dim result As Long
result = &H0000FF ' blue
If index = 0 Then
result = &H00FF00 ' green
ElseIf index = 1 Then
result = &HFFFF00 ' yellow
End If
XColorScheme_getColorByIndex = result
End Function
The only relevant documentation I could find for this approach is the API docs: https://www.openoffice.org/api/docs/common/ref/com/sun/star/chart2/XDiagram.html.
Another way is to put the colors in column C.
Status Count Color
Unfinished 20 =COLOR(0,255,0)
Finished 30 =COLOR(255,0,0)
Then set the Range for Fill Color to use column C. If you want to see code for this second approach, post a comment and I'll look into it.
Yet another way is from https://forum.openoffice.org/en/forum/viewtopic.php?t=36001.
oChart.Diagram.DataRowSource = com.sun.star.chart.ChartDataRowSource.COLUMNS
oChart.FirstDiagram.CoordinateSystems(0).ChartTypes(0).DataSeries(0).Color = &H00FF00
However, this last approach did not change the color when I tried it.
In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub
Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.
I have following macro code, this will run macro automatically and login into mentioned website. But xls sheets remains opened ..
-----------------------------------------------------------------
Sub Auto_open()
login
End Sub
Sub login()
Dim IntExpl As Object
Set IntExpl = CreateObject("InternetExplorer.Application")
Dim dd As Object
Dim dd1 As Object
Dim dd2 As Object
Dim dd3 As Object
With IntExpl
.navigate "........."
.Visible = True
' If (.Document.getElementById("LoginUsername").exist) Then
Do Until IntExpl.ReadyState = 4
Loop
Set dd = .Document.getElementById("LoginUsername")
dd.Value = "AAAAA"
dd.Click
Set dd1 = .Document.getElementById("LoginPassword")
dd1.Value = "AAAAAA"
dd1.Click
Set dd2 = .Document.getElementById("loginBtn")
dd2.Click
End With
End Sub
-------------------------------------------------------------------------------
I want to close xls file also after running whole macro.
You can define your workbook and then close it once the macro is completed.
Sub Auto_open()
Dim wb as Workbook
set wb = ActiveWorkbook
login
wb.close
End Sub
Sub login()
Dim IntExpl As Object
Set IntExpl = CreateObject("InternetExplorer.Application")
Dim dd As Object
Dim dd1 As Object
Dim dd2 As Object
Dim dd3 As Object
With IntExpl
.navigate "........."
.Visible = True
' If (.Document.getElementById("LoginUsername").exist) Then
Do Until IntExpl.ReadyState = 4
Loop
Set dd = .Document.getElementById("LoginUsername")
dd.Value = "AAAAA"
dd.Click
Set dd1 = .Document.getElementById("LoginPassword")
dd1.Value = "AAAAAA"
dd1.Click
Set dd2 = .Document.getElementById("loginBtn")
dd2.Click
End With
End Sub
I have a simulation set up in OpenOffice. I want to display the results of the simulation, for say 100 replications, but I can't seem to work out how to do it. Obviously if you just copy the result to a cell and drag it down 100 rows, they all show the same figure.
Either a macro is necessary or there is a built in way. Neither of which I know.
Basically, the equivalent to http://www.youtube.com/watch?v=tpIhQuxQeNs
I created a macro as so:
Sub PasteSpecialNoFormula
dim args3(0) as new com.sun.star.beans.PropertyValue
args3(0).Name = "SelectedFormat"
args3(0).Value = 1
Dim document As Object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
oDesktop = createUnoService("com.sun.star.frame.Desktop")
oDocument = ThisComponent
oSheet1 = oDocument.Sheets.getByIndex(0)
oSheet2 = oDocument.Sheets.getByIndex(0)
Dim i As Long, n As Long
n = 1000
for i = 1 to n
oFromRange = oSheet1.getCellRangeByName("B464:C464")
oToCell = oSheet2.getCellByPosition(1,466+i)
oDocument.CurrentController.Select(oFromRange)
dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())
oDocument.CurrentController.Select(oToCell)
dispatcher.executeDispatch(document, ".uno:ClipboardFormatItems", "", 0, args3())
next i
End Sub