| View previous topic :: View next topic |
| Author |
Message |
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
 Posted: Sat Apr 02, 2005 12:32 pm Post subject: Danny's Basic Library |
 |
|
In all of the Basic languge macros I post here to OOoForum, I often make use of numerous routines that I repeatedly post and re-post. As some may have guessed, these routines come out of a library that I use.
After waiting way too long to do so, I have decided that I should post that library here for others to use.
This library consists of a number of modules. I will post each module as a separate message in this thread. This message will serve as the table of contents.
Table Of Contents
Modules in Danny's Library
- DocCalc
Module of routines to create and manipulate OpenOffice.org Calc documents.
- DocDraw
Module of routines to create and manipulate OpenOffice.org Draw documents.
- DocDraw2
Module of routines to create and manipulate OpenOffice.org Draw documents.
- DocWriter
Module of routines to create and manipulate OpenOffice.org Writer documents.
- UtilAPI
Module of utility routines for working with the OOo API.
These utilities are not specific to Draw, or Writer, or Calc, for instance.
- UtilBasic
Module of utility routines to make OOo Basic easier to use.
Various type conversions, convenience routines, etc.
These utilities are not specific to Draw, or Writer, or Calc, for instance.
- UtilColor
Routines to make it easy to work with colors.
- UtilConfig
Routines to make it easy to work with OOo Configuration Manager.
- UtilFile
File and pathname manipulation routines.
- UtilForm
Utility functions for working with document Forms.
- UtilProperty
Module of utilities to manipulate arrays of PropertyValue's.
- UtilString
String manipulation utility functions.
See Also....
Danny's Python Modules
http://www.oooforum.org/forum/viewtopic.phtml?t=14409
Danny's Java classes
http://www.oooforum.org/forum/viewtopic.phtml?t=12954
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:09 pm; edited 7 times in total |
|
| Back to top |
|
 |
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:32 pm Post subject: |
|
|
| Code: | '**********************************************************************
' DocCalc module
'
' Module of routines to create and manipulate
' OpenOffice.org Calc documents.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-12-18-01
'
'**********************************************************************
'############################################################
' Utilities to create, initialize and return common
' structs or services.
'############################################################
'----------
' Create and return a new com.sun.star.table.CellRangeAddress.
'
Function MakeCellRangeAddress( nSheetIndex, nStartColumn, nStartRow, nEndColumn, nEndRow ) As com.sun.star.table.CellRangeAddress
oCellRangeAddress = createUnoStruct( "com.sun.star.table.CellRangeAddress" )
With oCellRangeAddress
.Sheet = nSheetIndex
.StartColumn = nStartColumn
.StartRow = nStartRow
.EndColumn = nEndColumn
.EndRow = nEndRow
End With
MakeCellRangeAddress() = oCellRangeAddress
End Function
'----------
' Create and return a new com.sun.star.table.BorderLine.
'
Function MakeCellBorderLine( nColor, nInnerLineWidth, nOuterLineWidth, nLineDistance ) _
As com.sun.star.table.BorderLine
oBorderLine = createUnoStruct( "com.sun.star.table.BorderLine" )
With oBorderLine
.Color = nColor
.InnerLineWidth = nInnerLineWidth
.OuterLineWidth = nOuterLineWidth
.LineDistance = nLineDistance
End With
MakeCellBorderLine = oBorderLine
End Function
'############################################################
' Miscellaneous API help
'############################################################
' Convert between column number and column name.
' See...
' http://www.oooforum.org/forum/viewtopic.php?p=23013#23013
Function CalcColumnNameToNumber( oSheet As com.sun.star.sheet.Spreadsheet,_
cColumnName As String ) As Long
oColumns = oSheet.getColumns()
oColumn = oColumns.getByName( cColumnName )
oRangeAddress = oColumn.getRangeAddress()
nColumn = oRangeAddress.StartColumn
CalcColumnNameToNumber() = nColumn
End Function
Function CalcColumnNumberToName( oSheet As com.sun.star.sheet.Spreadsheet,_
nColumnNumber As Long ) As String
oColumns = oSheet.getColumns()
oColumn = oColumns.getByIndex( nColumnNumber )
cColumnName = oColumn.getName()
CalcColumnNumberToName() = cColumnName
End Function
Function SheetNumberToName( ByVal nSheetNumber As Long ) As String
oSheets = ThisComponent.getSheets()
' aSheetNames is an Array() of String. (The sheet names).
aSheetNames = oSheets.getElementNames()
cSheetName = aSheetNames( nSheetNumber )
SheetNumberToName() = cSheetName
End Function
' Given the name of a sheet, return it's index.
' Return -1 if not found.
Function SheetNameToNumber( ByVal cSheetName As String ) As Long
oSheets = ThisComponent.getSheets()
' aSheetNames is an Array() of String. (The sheet names).
aSheetNames = oSheets.getElementNames()
For i = LBound( aSheetNames ) To UBound( aSheetNames )
cSheetName2 = aSheetNames( i ) ' get string from array
If cSheetName = cSheetName2 Then
SheetNameToNumber() = i
Exit Function
EndIf
Next
SheetNameToNumber() = -1
End Function
' Select some cells on a spreadsheet document.
' Parameters:
' oDocCtrl
' - The document controller.
' Note: is okay if you pass in either the
' document model or frame instead of a controller.
' cCellsName
' - The name of the cell or cell range to select.
' Optional Parameters:
' oSheet
' - The sheet within the document. A com.sun.star.sheet.Spreadsheet.
' If not supplied, then the currently visible sheet is used.
'
Sub CalcSelectCellsByName( ByVal oDocCtrl, ByVal cCellsName As String, Optional oSheet )
' If they gave us the incorrect parameter...
If Not HasUnoInterfaces( oDocCtrl, "com.sun.star.frame.XController" ) Then
' Be sure that we've got the document frame.
' Someone might have passed us the document model or one of
' its controller's.
oDocCtrl = GetDocumentController( oDocCtrl )
EndIf
If IsMissing( oSheet ) Then
oSheet = oDocCtrl.getActiveSheet()
EndIf
oRange = oSheet.getCellRangeByName( cCellsName )
oDocCtrl.select( oRange )
End Sub
' The oSelectedCells must be either....
' * empty
' * com.sun.star.sheet.SheetCellRange
' * com.sun.star.sheet.SheetCellRanges
' A string is returned which describes the selected cells.
' This is useful to get a text description of the selected cells in a spreadsheet.
Function CalcCellRangesToName( oCalcDoc As com.sun.star.sheet.SpreadsheetDocument,_
oSheet As com.sun.star.sheet.Spreadsheet,_
oSelectedCells As Object,_
Optional bRemoveSheetNames As Boolean ) As String
cSelectedCells = ""
' Are any cells selected?
If HasUnoInterfaces( oSelectedCells, "com.sun.star.lang.XServiceInfo" ) Then
If oSelectedCells.supportsService( "com.sun.star.sheet.SheetCellRange" ) Then
oRangeAddress = oSelectedCells.getRangeAddress()
cSelectedCells = CellRangeAddressToName( oSheet, oRangeAddress )
ElseIf oSelectedCells.supportsService( "com.sun.star.sheet.SheetCellRanges" ) Then
aRangeAddresses = oSelectedCells.getRangeAddresses()
For i = 0 To UBound( aRangeAddresses )
oRangeAddress = aRangeAddresses( i )
If i > 0 Then
cSelectedCells = cSelectedCells + ";"
EndIf
cSelectedCells = cSelectedCells + CellRangeAddressToName( oSheet, oRangeAddress )
Next
EndIf
EndIf
CalcCellRangesToName = cSelectedCells
End Function
' This is the complement of the above function.
' Pass in a string from the above function, and this returns a
' com.sun.star.sheet.SheetCellRanges.
' This is useful to take a text description of cells, and get an object
' that can be passed to the document controller's select() method to select the cells.
Function CalcNameToCellRanges( oCalcDoc As com.sun.star.sheet.SpreadsheetDocument,_
oSheet As com.sun.star.sheet.Spreadsheet,_
cSelectedCells As String ) As Object
oSheetCellRanges = oCalcDoc.createInstance( "com.sun.star.sheet.SheetCellRanges" )
If Len( cSelectedCells ) > 0 Then
' If cSelectedCells contains multiple ranges, separated by semicolons,
' then turn those into an array of strings describing each individual range.
aSelections = Split( cSelectedCells, ";" )
' Iterate over the array.
For i = LBound( aSelections ) To UBound( aSelections )
cSelection = aSelections( i )
oCells = oSheet.getCellRangeByName( cSelection )
oSheetCellRanges.addRangeAddress( oCells.getRangeAddress(), True )
Next
EndIf
CalcNameToCellRanges = oSheetCellRanges
End Function
Function CellRangeAddressToName( oSheet As com.sun.star.sheet.Spreadsheet,_
oRangeAddress As com.sun.star.table.CellRangeAddress ) As String
If oRangeAddress.StartColumn = oRangeAddress.EndColumn _
And oRangeAddress.StartRow = oRangeAddress.EndRow Then
CellRangeAddressToName = CalcColumnNumberToName( oSheet, oRangeAddress.StartColumn ) _
+ CSTR( oRangeAddress.StartRow + 1 )
Else
CellRangeAddressToName = CalcColumnNumberToName( oSheet, oRangeAddress.StartColumn ) _
+ CSTR( oRangeAddress.StartRow + 1 ) _
+ ":" _
+ CalcColumnNumberToName( oSheet, oRangeAddress.EndColumn ) _
+ CSTR( oRangeAddress.EndRow + 1 )
EndIf
End Function
' Sugar coatings to manipulate single cells by name.
Sub SetCellString( oSheet, cCellName, cString )
oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).setString( cString )
End Sub
Function GetCellString( oSheet, cCellName )
GetCellString = oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).getString()
End Function
Sub SetCellValue( oSheet, cCellName, cValue )
oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).setValue( cValue )
End Sub
Function GetCellValue( oSheet, cCellName )
GetCellValue = oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).getValue()
End Function
Sub SetCellFormula( oSheet, cCellName, cFormula )
oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).setFormula( cFormula )
End Sub
Function GetCellFormula( oSheet, cCellName )
GetCellFormula = oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 ).getFormula()
End Function
Function GetCell( oSheet, cCellName )
GetCell = oSheet.getCellRangeByName( cCellName ).getCellByPosition( 0, 0 )
End Function
Function GetLastUsedCell( oSheet As com.sun.star.sheet.Spreadsheet ) As com.sun.star.sheet.SheetCell
' The Spreadsheet interface XSpreadsheet has method createCursor(),
' which returns a SheetCellCursor.
oCellCursor = oSheet.createCursor()
' The SheetCellCursor has interface XUsedAreaCursor, which has method gotoEndOfUsedArea().
oCellCursor.gotoEndOfUsedArea( False )
' The SheetCellCursor includes service SheetCellRange which has interface XCellRangeAddressable
' which has method getRangeAddress(), which returns a struct com.sun.star.table.CellRangeAddress.
tCellRangeAddress = oCellCursor.getRangeAddress()
' Get the last used cell on the spreadsheet.
oCell = oSheet.getCellByPosition( tCellRangeAddress.EndColumn, tCellRangeAddress.EndRow )
GetLastUsedCell = oCell
end function
Function GetFirstUsedCell( oSheet As com.sun.star.sheet.Spreadsheet ) As com.sun.star.sheet.SheetCell
' The Spreadsheet interface XSpreadsheet has method createCursor(),
' which returns a SheetCellCursor.
oCellCursor = oSheet.createCursor()
' The SheetCellCursor has interface XUsedAreaCursor, which has method gotoStartOfUsedArea().
oCellCursor.gotoStartOfUsedArea( False )
' The SheetCellCursor includes service SheetCellRange which has interface XCellRangeAddressable
' which has method getRangeAddress(), which returns a struct com.sun.star.table.CellRangeAddress.
tCellRangeAddress = oCellCursor.getRangeAddress()
' Get the first used cell on the spreadsheet.
oCell = oSheet.getCellByPosition( tCellRangeAddress.EndColumn, tCellRangeAddress.EndRow )
GetFirstUsedCell = oCell
end function
|
_________________
Want to make OOo Drawings like the colored flower design to the left? |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:32 pm Post subject: |
|
|
DocDraw module
Just for fun...
be sure to execute the DrawModTest() test routine near the end of this module.
See also....
Draw Examples
http://www.oooforum.org/forum/viewtopic.phtml?t=10795
Draw: Introduction to draw and basic shapes
http://www.oooforum.org/forum/viewtopic.php?t=5383
Draw: duplicate selected drawing shape
http://www.oooforum.org/forum/viewtopic.php?t=5089
Color conversions: HSB to RGB and back again
http://www.oooforum.org/forum/viewtopic.php?t=4945
| Code: | '**********************************************************************
' DocDraw module
'
' Module of routines to create and manipulate
' OpenOffice.org Draw documents.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-12-01-01
'
'**********************************************************************
' TO DO:
' * Recursive FindShape function.
Sub Main
' Test program for this module.
DrawModTest()
End Sub
'------------------------------------------------------------
' Notes about some properties and constants for shape objects...
'------------------------------------------------------------
' LineStyle can be one of...
' com.sun.star.drawing.LineStyle.NONE
' com.sun.star.drawing.LineStyle.SOLID
' com.sun.star.drawing.LineStyle.DASH
' DashStyle can be one of...
' com.sun.star.drawing.DashStyle.RECT
' com.sun.star.drawing.DashStyle.ROUND
' com.sun.star.drawing.DashStyle.RECTRELATIVE
' com.sun.star.drawing.DashStyle.ROUNDRELATIVE
' FillStyle can be one of...
' com.sun.star.drawing.FillStyle.NONE
' com.sun.star.drawing.FillStyle.SOLID
' com.sun.star.drawing.FillStyle.GRADIENT
' com.sun.star.drawing.FillStyle.HATCH
' com.sun.star.drawing.FillStyle.BITMAP
' CircleKind can be one of...
' com.sun.star.drawing.CircleKind.FULL
' com.sun.star.drawing.CircleKind.SECTION ' a circle with a cut connected by two lines
' com.sun.star.drawing.CircleKind.CUT ' a circle with a cut connected by a line
' com.sun.star.drawing.CircleKind.ARC ' a circle with an open cut
' TextHorizontalAdjust can be one of...
' com.sun.star.drawing.TextHorizontalAdjust.LEFT
' com.sun.star.drawing.TextHorizontalAdjust.CENTER
' com.sun.star.drawing.TextHorizontalAdjust.RIGHT
' com.sun.star.drawing.TextHorizontalAdjust.BLOCK
' TextVerticalAdjust can be one of...
' com.sun.star.drawing.TextVerticalAdjust.TOP
' com.sun.star.drawing.TextVerticalAdjust.CENTER
' com.sun.star.drawing.TextVerticalAdjust.BOTTOM
' com.sun.star.drawing.TextVerticalAdjust.BLOCK
' TextFitToSize can be one of...
' com.sun.star.drawing.TextFitToSizeType.NONE
' com.sun.star.drawing.TextFitToSizeType.PROPORTIONAL
' com.sun.star.drawing.TextFitToSizeType.ALLLINES
' com.sun.star.drawing.TextFitToSizeType.RESIZEATTR
'############################################################
' Utilities to create, initialize and return common
' structs or services.
'############################################################
'----------
' Easy sugar coated way to create and initialize a new Point struct.
'
Function MakePoint( ByVal x As Long, ByVal y As Long ) As com.sun.star.awt.Point
oPoint = createUnoStruct( "com.sun.star.awt.Point" )
oPoint.X = x
oPoint.Y = y
MakePoint = oPoint
End Function
'----------
' Easy sugar coated way to create and initialize a new Size struct.
'
Function MakeSize( ByVal width As Long, ByVal height As Long ) As com.sun.star.awt.Size
oSize = createUnoStruct( "com.sun.star.awt.Size" )
oSize.Width = width
oSize.Height = height
MakeSize = oSize
End Function
'----------
' Create and return a new LineDash struct.
' See...
' http://api.openoffice.org/docs/common/ref/com/sun/star/drawing/LineDash.html
'
Function MakeLineDash( nDashStyle As Long, nDots As Integer, nDotLen As Long,_
nDashes As Integer, nDashLen As Long, nDistance As Long ) As com.sun.star.drawing.LineDash
oLineDash = createUnoStruct( "com.sun.star.drawing.LineDash" )
oLineDash.Style = nDashStyle
oLineDash.Dots = nDots
oLineDash.DotLen = nDotLen
oLineDash.Dashes = nDashes
oLineDash.DashLen = nDashLen
oLineDash.Distance = nDistance
MakeLineDash = oLineDash
End Function
'----------
' Create and return a new GluePoint struct.
' Use a constant from com.sun.star.drawing.EscapeDirection.
' Use a constant from com.sun.star.drawing.Alignment.
Function MakeGluePoint( oPosition As com.sun.star.awt.Point,_
bIsRelative As Boolean,_
nEscapeDirection As Long,_
nPositionAlignment As Long,_
bIsUserDefined As Boolean )
oGluePoint = createUnoStruct( "com.sun.star.drawing.GluePoint2" )
With oGluePoint
.Position = oPosition
.PositionAlignment = nPositionAlignment
.IsRelative = bIsRelative
.Escape = nEscapeDirection
.IsUserDefined = bIsUserDefined
End With
MakeGluePoint = oGluePoint
End Function
'############################################################
' Drawing document
'############################################################
'----------
' Pass in any GenericDrawPage object in portrait orientation,
' and this changes it to Lanscape orientation.
'
Sub SetDrawPageOrientationLandscape( oDrawPage As com.sun.star.drawing.GenericDrawPage )
If oDrawPage.Orientation = com.sun.star.view.PaperOrientation.LANDSCAPE Then
Exit Sub
EndIf
' Save some settings
nOldWidth = oDrawPage.Width
nOldHeight = oDrawPage.Height
nOldBorderTop = oDrawPage.BorderTop
nOldBorderLeft = oDrawPage.BorderLeft
nOldBorderRight = oDrawPage.BorderRight
nOldBorderBottom = oDrawPage.BorderBottom
' Change so that it will PRINT in landscape
oDrawPage.Orientation = com.sun.star.view.PaperOrientation.LANDSCAPE
' Now change some paper dimensions to match
oDrawPage.Width = nOldHeight
oDrawPage.Height = nOldWidth
oDrawPage.BorderTop = nOldBorderRight
oDrawPage.BorderLeft = nOldBorderTop
oDrawPage.BorderRight = nOldBorderBottom
oDrawPage.BorderBottom = nOldBorderLeft
End Sub
'----------
' Pass in any GenericDrawPage object in portrait orientation,
' and this changes it to Lanscape orientation.
'
Sub SetDrawPageOrientationPortrait( oDrawPage As com.sun.star.drawing.GenericDrawPage )
If oDrawPage.Orientation = com.sun.star.view.PaperOrientation.PORTRAIT Then
Exit Sub
EndIf
' Save some settings
nOldWidth = oDrawPage.Width
nOldHeight = oDrawPage.Height
nOldBorderTop = oDrawPage.BorderTop
nOldBorderLeft = oDrawPage.BorderLeft
nOldBorderRight = oDrawPage.BorderRight
nOldBorderBottom = oDrawPage.BorderBottom
' Change so that it will PRINT in landscape
oDrawPage.Orientation = com.sun.star.view.PaperOrientation.PORTRAIT
' Now change some paper dimensions to match
oDrawPage.Width = nOldHeight
oDrawPage.Height = nOldWidth
oDrawPage.BorderTop = nOldBorderLeft
oDrawPage.BorderLeft = nOldBorderBottom
oDrawPage.BorderRight = nOldBorderTop
oDrawPage.BorderBottom = nOldBorderRight
End Sub
'############################################################
' Misc functions
'############################################################
'----------
' Given an angle in 100's of a degree,
' adjust it to be from 0 to 360 degrees.
'
Function NormalizeAngleOOo( ByVal nAngle As Long ) As Long
nAngle = nAngle - (Int( Abs( nAngle ) / 36000 ) * 36000 * Sgn( nAngle ))
If nAngle < 0 Then
nAngle = nAngle + 36000
EndIf
NormalizeAngleOOo = nAngle
End Function
'----------
' Given an angle in radians,
' adjust it to be from 0 to 2*PI radians.
'
Function NormalizeAngleRadians( ByVal nAngle As Double ) As Double
nAngle = nAngle - (Int( Abs( nAngle ) / (2*PI) ) * (2*PI) * Sgn( nAngle ))
If nAngle < 0 Then
nAngle = nAngle + (2*PI)
EndIf
NormalizeAngleRadians = nAngle
End Function
'############################################################
' Shapes
'############################################################
' The following functions are a convenient way to create Shape objects
' and initialize their size and position.
'
' An example of how you would use them would be...
'
' oShape = MakeEllipseShape( oDrawDoc, MakePoint( 1000, 1000 ), MakeSize( 5000, 3000 ) )
' oShape.FillStyle = com.sun.star.drawing.FillStyle.SOLID
' oShape.FillColor = RGB( 255, 0, 0 )
' oShape.LineStyle = com.sun.star.drawing.LineStyle.SOLID
' oShape.LineColor = RGB( 0, 0, 255 )
' oShape.LineWidth = 100
'----------
' Create and return a RectangleShape object,
' optionally with its position and size initialized.
'
Function MakeRectangleShape( oDoc As Object,_
Optional oPosition As com.sun.star.awt.Point,_
Optional oSize As com.sun.star.awt.Size ) As com.sun.star.drawing.RectangleShape
oShape = oDoc.createInstance( "com.sun.star.drawing.RectangleShape" )
If Not IsMissing( oPosition ) Then
oShape.Position = oPosition
EndIf
If Not IsMissing( oSize ) Then
oShape.Size = oSize
EndIf
MakeRectangleShape = oShape
End Function
'----------
' Create and return a EllipseShape object,
' optionally with its position and size initialized.
'
Function MakeEllipseShape( oDoc As Object,_
Optional position As com.sun.star.awt.Point,_
Optional size As com.sun.star.awt.Size ) As com.sun.star.drawing.EllipseShape
oShape = oDoc.createInstance( "com.sun.star.drawing.EllipseShape" )
If Not IsMissing( position ) Then
oShape.Position = position
EndIf
If Not IsMissing( size ) Then
oShape.Size = size
EndIf
MakeEllipseShape = oShape
End Function
'----------
' Create and return a TextShape object,
' optionally with its position and size initialized.
'
Function MakeTextShape( oDoc As Object,_
Optional position As com.sun.star.awt.Point,_
Optional size As com.sun.star.awt.Size ) As com.sun.star.drawing.TextShape
oShape = oDoc.createInstance( "com.sun.star.drawing.TextShape" )
If Not IsMissing( position ) Then
oShape.Position = position
EndIf
If Not IsMissing( size ) Then
oShape.Size = size
EndIf
MakeTextShape = oShape
End Function
'----------
' Create and return a LineShape object,
' optionally with its position and size initialized.
'
Function MakeLineShape( oDoc As Object,_
Optional position As com.sun.star.awt.Point,_
Optional size As com.sun.star.awt.Size ) As com.sun.star.drawing.LineShape
oShape = oDoc.createInstance( "com.sun.star.drawing.LineShape" )
If Not IsMissing( position ) Then
oShape.Position = position
EndIf
If Not IsMissing( size ) Then
oShape.Size = size
EndIf
MakeLineShape = oShape
End Function
'----------
' Create and return a ControlShape object,
' optionally with its position and size initialized.
'
Function MakeControlShape( oDoc As Object,_
Optional position As com.sun.star.awt.Point,_
Optional size As com.sun.star.awt.Size ) As com.sun.star.drawing.ControlShape
oShape = oDoc.createInstance( "com.sun.star.drawing.ControlShape" )
If Not IsMissing( position ) Then
oShape.Position = position
EndIf
If Not IsMissing( size ) Then
oShape.Size = size
EndIf
MakeControlShape = oShape
End Function
'----------
' Create and return a GraphicObjectShape object,
' optionally with its position and size initialized.
'
Function MakeGraphicObjectShape( oDoc As Object,_
Optional oPosition As com.sun.star.awt.Point,_
Optional oSize As com.sun.star.awt.Size ) As com.sun.star.drawing.GraphicObjectShape
oShape = oDoc.createInstance( "com.sun.star.drawing.GraphicObjectShape" )
If Not IsMissing( oPosition ) Then
oShape.Position = oPosition
EndIf
If Not IsMissing( oSize ) Then
oShape.Size = oSize
EndIf
MakeGraphicObjectShape = oShape
End Function
'----------
' Given an object supporting the XShapes interface,
' find and return a named shape in that collection of shapes.
' Since a drawing page supports XShapes, you can use this
' function to find a named shape within a draw page,
' or within a grouped shape, or a selection of shapes.
'
Function FindShapeByName( oShapes, cShapeName As String )
nNumShapes = oShapes.getCount()
For i = 0 To nNumShapes - 1
oShape = oShapes.getByIndex( i )
If oShape.getName() = cShapeName Then
FindShapeByName = oShape
Exit Function
EndIf
Next
End Function
'############################################################
' Utilities to build PolyPolygons and Bezier shapes.
'############################################################
' Convenient way to build up a PolyPolygonBezierCoords structure.
' See example in test routine TestBezierShape() below.
' Call this to start a new polygon of points.
Sub PolyPoly_BeginPoly( oCoords As com.sun.star.drawing.PolyPolygonBezierCoords )
aArrayOfArrayPoints = oCoords.Coordinates
aArrayOfArrayFlags = oCoords.Flags
Array1_AppendElement( aArrayOfArrayPoints, Array() )
Array1_AppendElement( aArrayOfArrayFlags, Array() )
oCoords.Coordinates = aArrayOfArrayPoints
oCoords.Flags = aArrayOfArrayFlags
End Sub
' Call this to add a point, and flag, to the currently open polygon.
Sub PolyPoly_AddPoint( oCoords As com.sun.star.drawing.PolyPolygonBezierCoords,_
ByVal oNewPoint As com.sun.star.awt.Point,_
ByVal nNewFlag As Long )
aArrayOfArrayPoints = oCoords.Coordinates
aArrayOfArrayFlags = oCoords.Flags
nNumPolys = Array1_Size( aArrayOfArrayPoints )
aPoints = aArrayOfArrayPoints( nNumPolys - 1 )
aFlags = aArrayOfArrayFlags( nNumPolys - 1 )
Array1_AppendElement( aPoints, oNewPoint )
Array1_AppendElement( aFlags, nNewFlag )
aArrayOfArrayPoints( nNumPolys - 1 ) = aPoints
aArrayOfArrayFlags( nNumPolys - 1 ) = aFlags
oCoords.Coordinates = aArrayOfArrayPoints
oCoords.Flags = aArrayOfArrayFlags
End Sub
'############################################################
' Styles
'############################################################
'----------
' Add a new style to the style catalog if it is not already present.
' This returns the style object so that you can alter its properties.
'
Function DefineGraphicsStyle( oDoc As Object, cStyleName As String, Optional cParentStyleName As String )
If IsMissing( cParentStyleName ) Then
cParentStyleName = ""
EndIf
DefineGraphicsStyle = DefineStyle( oDoc, "graphics", cStyleName, cParentStyleName )
End Function
'----------
' Lookup and return a graphics style from the document.
'
Function GetGraphicsStyle( oDoc As Object, cStyleName As String )
GetGraphicsStyle = GetStyle( oDoc, "graphics", cStyleName )
End Function
'############################################################
' Test program for DrawMod.
'############################################################
Sub DrawModTest
' Make sure DannysOOoLib library of modules are loaded.
BasicLibraries.LoadLibrary( "DannysOOoLib" )
' Create a new Draw document
oDoc = StarDesktop.loadComponentFromURL( "private:factory/sdraw", "_blank", 0, Array() )
' Get the first page
oDrawPage = oDoc.drawPages( 0 )
Test_ColorRectangles( oDoc, oDrawPage )
Test_ColorSpirals( oDoc, oDrawPage
Test_FlowerOfArcs( oDoc, oDrawPage )
Test_DrawLines( oDoc, oDrawPage )
Test_Polygon( oDoc, oDrawPage )
TestBezierShape( oDoc, oDrawPage )
End Sub
Sub Test_ColorRectangles( oDoc, oDrawPage )
' Draw some colored rectangles
oSize = MakeSize( 1000, 2000 )
For i = 0 To 15
oShape = MakeRectangleShape( oDoc, MakePoint( 1000 + (i * 1200), 1000 ), oSize )
oShape.FillColor = HSB( i / 15, 1.0, 1.0 )
oDrawPage.add( oShape )
Next
End Sub
Sub Test_ColorSpirals( oDoc, oDrawPage )
' Draw some spirals
nPosX = 5000 ' start position X
nPosY = 7000 ' start position Y
nAngle = 4500 ' 45 degrees starting angle
bTurnLeft = TRUE ' first spiral turns to the left
' Draw growing spiral
oSpiral1 = DrawSpiralOfArcs( oDoc, oDrawPage, nPosX, nPosY, nAngle,_
2000, 300, bTurnLeft, 72, 1.0, 30 )
' Draw shrinking spiral
oSpiral2 = DrawSpiralOfArcs( oDoc, oDrawPage, nPosX, nPosY, nAngle,_
2000, 2460, (Not bTurnLeft), 72, 1.0, -30 )
' Now add some color to the first spiral.
' Each segment gets an increasing hue.
nNumSegments = oSpiral1.getCount()
For i = 0 To nNumSegments - 1
oShape = oSpiral1.getByIndex( i ) ' get the arc segment of the spiral
oShape.LineColor = HSB( i / (nNumSegments-1), 1.0, 1.0 )
Next
' Now color the second spiral
nNumSegments = oSpiral2.getCount()
For i = 0 To nNumSegments - 1
oShape = oSpiral2.getByIndex( i ) ' get the arc segment of the spiral
oShape.LineColor = HSB( i / (nNumSegments-1), 1.0, 1.0 )
Next
End Sub
Sub Test_FlowerOfArcs( oDoc, oDrawPage )
' Draw a curvy flower
nPosX = 16000 ' start position X
nPosY = 8000 ' start position Y
DrawFlowerOfArcs( oDoc, oDrawPage, nPosX, nPosY,_
40, 8, 9000, 300, TRUE, 1.0, 0, 500 )
End Sub
Sub Test_DrawLines(oDoc, oDrawPage )
nSegments = 16
For i = 1 to nSegments
DrawLine( oDoc, oDrawPage,_
1000, i*250+11500, 5000, (nSegments-i)*250+11500,_
RGB(255*(i/nSegments),150,255*((nSegments-i)/nSegments)), 150 )
Next
nCenterX = 2500
nCenterY = 11000
nSegments = 18
For i = 1 to nSegments
DrawLineAngleDegrees( oDoc, oDrawPage, nCenterX, nCenterY,_
(i / nSegments) * 360,_
1000,_
RGB(255*(i/nSegments), 255*((nSegments-i)/nSegments), 190 ), 150 )
Next
End Sub
Sub Test_Polygon( oDoc, oDrawPage )
oShape = oDoc.createInstance( "com.sun.star.drawing.PolyLineShape" )
oDrawPage.add( oShape )
oCoord = Array(_
MakePoint( 1000, 1000 ),_
MakePoint( 2000, 2000 ),_
MakePoint( 3000, 1000 ),_
MakePoint( 0, 0 ),_
MakePoint( 500, 2000 ),_
MakePoint( 0, 3000 ),_
MakePoint( 1000, 2000 ),_
MakePoint( 2000, 3000 ),_
MakePoint( 3000, 2000 ) )
oShape.PolyPolygon = Array( oCoord )
oShape.LineWidth = 100
oShape.LineColor = RGB( 120, 200, 180 )
oShape.Position = MakePoint( 5500, 12000 )
End Sub
Sub TestBezierShape( oDoc, oDrawPage )
' Shorter constant names, just to make the code below easier to read.
POINT_NORMAL = com.sun.star.drawing.PolygonFlags.NORMAL
POINT_CONTROL = com.sun.star.drawing.PolygonFlags.CONTROL
' Create the object which holds geometry description of a poly-polygon.
oCoords = createUnoStruct( "com.sun.star.drawing.PolyPolygonBezierCoords" )
' Add one polygon (bezier polygon)
PolyPoly_BeginPoly( oCoords )
PolyPoly_AddPoint( oCoords, MakePoint( 1000, 1000 ), POINT_NORMAL )
PolyPoly_AddPoint( oCoords, MakePoint( 3000, 4000 ), POINT_CONTROL )
PolyPoly_AddPoint( oCoords, MakePoint( 3000, 4000 ), POINT_CONTROL )
PolyPoly_AddPoint( oCoords, MakePoint( 5000, 1000 ), POINT_NORMAL )
' Add another polygon (bezier polygon)
PolyPoly_BeginPoly( oCoords )
PolyPoly_AddPoint( oCoords, MakePoint( 1000, 2000 ), POINT_NORMAL )
PolyPoly_AddPoint( oCoords, MakePoint( 3000, 6000 ), POINT_CONTROL )
PolyPoly_AddPoint( oCoords, MakePoint( 3000, 6000 ), POINT_CONTROL )
PolyPoly_AddPoint( oCoords, MakePoint( 5000, 2000 ), POINT_NORMAL )
' Create the shape.
oPolyPolygonBezierShape = oDoc.createInstance( "com.sun.star.drawing.ClosedBezierShape" )
' Add it to page.
oDrawPage.add( oPolyPolygonBezierShape )
' Set its geometry.
oPolyPolygonBezierShape.PolyPolygonBezier = oCoords
' Move it...
oPolyPolygonBezierShape.Position = MakePoint( 11000, 12000 )
oPolyPolygonBezierShape.FillColor = HSB( 1/6, 1.0, 1.0 )
End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:45 pm; edited 2 times in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:33 pm Post subject: |
|
|
| Code: | '**********************************************************************
' DocDraw2 module
'
' Module of routines to create and manipulate
' OpenOffice.org Draw documents.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-06-01-01
'
'**********************************************************************
Sub Main
End Sub
'############################################################
' Higher level drawing primitives
'############################################################
'----------
' Draw a line from x1,y1 to x2,y2.
' This adds the line to the page.
' The line shape is returned as the function result.
'
Function DrawLine( oDoc As Object, oDrawPage As Object,_
ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long,_
Optional nLineColor As Long,_
Optional nLineWidth As Long )
' make sure size is non-zero
' If y2 = y1 Then y2 = y1 + 1
' If x2 = x1 Then x2 = x1 + 1
oPosition = MakePoint( x1, y1 )
oSize = MakeSize( x2-x1, y2-y1 )
' Create a line shape
oLineShape = MakeLineShape( oDoc, oPosition, oSize )
' Set line shape's properties
If Not IsMissing( nLineColor ) Then
oLineShape.LineColor = nLineColor
EndIf
If Not IsMissing( nLineWidth ) Then
oLineShape.LineWidth = nLineWidth
EndIf
' Add the line shape to the page
oDrawPage.add( oLineShape )
DrawLine() = oLineShape
End Function
'----------
' Draw a line from x1,y1 in the direction of nAngle, for
' a distance of nDistance.
' nAngle is measured clockwise from the 3 O'Clock (east) position,
' in radians. Zero would be a line pointing east or right.
' A positive angle is measured clockwise from 3 O'Clock.
' This adds the line to the page.
' The line shape is returned as the function result.
'
Function DrawLineAngleRadians( oDoc As Object, oDrawPage As Object,_
ByVal x1 As Long, ByVal y1 As Long, ByVal nAngle As Double, ByVal nDistance As Long,_
Optional nLineColor As Long,_
Optional nLineWidth As Long )
If IsMissing( nLineColor ) Then
nLineColor = 0 ' black
EndIf
If IsMissing( nLineWidth ) Then
nLineWidth = 0
EndIf
nDX = cos( nAngle ) * nDistance
nDY = sin( nAngle ) * nDistance
DrawLineAngleRadians() = DrawLine( oDoc, oDrawPage, x1, y1, x1+nDX, y1+nDY, nLineColor, nLineWidth )
End Function
'----------
' Draw a line from x1,y1 in the direction of nAngle, for
' a distance of nDistance.
' nAngle is measured clockwise from the 3 O'Clock (east) position,
' in degrees. Zero would be a line pointing east or right.
' A positive angle is measured clockwise from 3 O'Clock.
' This adds the line to the page.
' The line shape is returned as the function result.
'
Function DrawLineAngleDegrees( oDoc As Object, oDrawPage As Object,_
x1 As Long, y1 As Long, nAngle As Double, nDistance As Long,_
Optional nLineColor As Long,_
Optional nLineWidth As Long )
DrawLineAngleDegrees() = DrawLineAngleRadians( oDoc, oDrawPage,_
x1, y1, nAngle / 180 * PI, nDistance,_
nLineColor, nLineWidth )
End Function
'----------
' Draw an arc of a circle from a starting position and direction.
' The arc turns either left or right.
' The arc has a certian radius and arc angle.
' Parameters:
' Current turtle position...
' nStartX, nStartY - position where the "turtle" currently is located.
' nStartDirectionAngle - turtle direction (in 100'ths of a degree).
' (both of the above parameters are updated to the new turtle location and
' direction at the end of the arc.)
'
' Arc which begins at current turtle position...
' nArcAngle - angle of the arc (in 1/100'ths of a degree).
' nArcRadius = radius of the arc.
'
' bTurnLeft - does the arc turn to the left (TRUE) or to the right (FALSE)?
'
Function DrawArcPath( oDoc As Object, oDrawPage As Object,_
nStartX As Long, nStartY As Long, nStartDirectionAngle As Long,_
ByVal nArcAngle As Long, ByVal nArcRadius As Long,_
ByVal bTurnLeft As Boolean )
'-----
' Figure out how big of a circle we need.
nArcDiameter = nArcRadius + nArcRadius
oCircleSize = MakeSize( nArcDiameter, nArcDiameter )
'-----
'-----
' Figure out the center point position of the circle (ellipse) shape object.
Dim nCenterPointAngle As Double
If bTurnLeft Then
nCenterPointAngle = nStartDirectionAngle + 9000
Else
nCenterPointAngle = nStartDirectionAngle - 9000
EndIf
' convert to radians
nCenterPointAngle = nCenterPointAngle / 18000 * PI
nCenterX = nStartX + (nArcRadius * cos( nCenterPointAngle ))
nCenterY = nStartY - (nArcRadius * sin( nCenterPointAngle ))
' Figure out the position of the circle (ellipse) shape object.
oCircleTopLeft = MakePoint( nCenterX - nArcRadius, nCenterY - nArcRadius )
'-----
'-----
' Figure out what arc portion of the circle needs to be drawn.
'Angles measured in 100ths of a degree.
If bTurnLeft Then
nCircleStartAngle = nStartDirectionAngle - 9000
nCircleEndAngle = nCircleStartAngle + nArcAngle
Else
nCircleEndAngle = nStartDirectionAngle + 9000
nCircleStartAngle = nCircleEndAngle - nArcAngle
EndIf
'-----
'-----
' Make the circle shape.
oCircle = MakeEllipseShape( oDoc, oCircleTopLeft, oCircleSize )
' Set it's properties.
oCircle.FillStyle = com.sun.star.drawing.FillStyle.NONE
oCircle.CircleKind = com.sun.star.drawing.CircleKind.ARC
oCircle.CircleStartAngle = nCircleStartAngle
oCircle.CircleEndAngle = nCircleEndAngle
' Put it on the drawing.
oDrawPage.Add( oCircle )
'-----
'-----
' Figure out the ending turtle direction and location.
If bTurnLeft Then
nEndPointAngle = nStartDirectionAngle - 9000 + nArcAngle
Else
nEndPointAngle = nStartDirectionAngle + 9000 - nArcAngle
EndIf
' convert to radians
nEndPointAngleRad = nEndPointAngle / 18000 * PI
nEndPointX = nCenterX + (nArcRadius * cos( nEndPointAngleRad ))
nEndPointY = nCenterY - (nArcRadius * sin( nEndPointAngleRad ))
' end point angle direction
If bTurnLeft Then
nEndPointAngle = NormalizeAngleOOo( nEndPointAngle + 9000 )
Else
nEndPointAngle = NormalizeAngleOOo( nEndPointAngle - 9000 )
EndIf
' Communicate the turtle location and angle out to the caller's parameters.
nStartDirectionAngle = nEndPointAngle
nStartX = nEndPointX
nStartY = nEndPointY
'-----
' Return the shape created
DrawArcPath() = oCircle
End Function
'----------
' Create a piece of text that will automatically resize its characters
' to the shape bounding rectangle.
' The text shape has a specified height.
' The width of the text shape is based on the natural character width of
' the actual text assigned to it.
' The initial position is -10000,-10000, so that the text is not visible.
' This function returns the text object, which has ALREADY been added to
' the drawing page, at coordinates that make it invisible.
' You must set the object's Position property to make the text visible.
' (Hint: You may look at the Size property to help you determine where
' you want the place the text, for instance if you are trying to center
' it, or place it relative to some other shape.)
' If you don't supply nExtraWidthPercent, then a default fudge factor is used.
' This is the percentage of the average character width, which is added to the
' shape's total width.
'
Function DrawAutoSizingText( oDoc As Object,_
oDrawPage As com.sun.star.drawing.GenericDrawPage,_
cText As String, nHeight As Long,_
Optional nExtraWidthPercent As Double )_
As com.sun.star.drawing.TextShape
' Make a text shape
Dim oShape As Object
oShape = MakeTextShape( oDoc, MakePoint( -10000, -10000 ), MakeSize( 1, 1 ) )
' put it on the page -- this must be done PRIOR altering other properties
oDrawPage.Add( oShape )
' Make text stick to upper left corner of the shape rather than centered.
oShape.TextHorizontalAdjust = com.sun.star.drawing.TextHorizontalAdjust.LEFT
oShape.TextVerticalAdjust = com.sun.star.drawing.TextVerticalAdjust.TOP
' Make the shape auto-grow in size, based on the text.
' Once we set the text, in the next step, the shape will grow to some
' unknown size, based on the current font in use.
' oShape.TextAutoGrowHeight = TRUE
oShape.TextAutoGrowWidth = TRUE
' Set the text of the text shape.
' Because of the TextAutoGrowWidth, the shape now occupies some unknown size.
oShape.SetString( cText )
' Get the shape's current size.
nSaveHeight = oShape.Size.Height
nSaveWidth = oShape.Size.Width
' Make the shape NOT auto-grow in size, based on the text.
' oShape.TextAutoGrowHeight = FALSE
oShape.TextAutoGrowWidth = FALSE
' This next setting causes the text shape to automatically resize its characters
' to fit the size of the text shape.
oShape.TextFitToSize = com.sun.star.drawing.TextFitToSizeType.PROPORTIONAL
' Calculate the new width, based on the desired height,
' and saved width/height ratio for the current font in use.
nWidth = nSaveWidth * (nHeight / nSaveHeight)
' Set up the fudge factor.
If IsMissing( nExtraWidthPercent ) Then
nExtraWidthPercent = 40 ' percent
EndIf
nAverageCharacterWidth = nWidth / Len( cText )
nExtraWidth = nAverageCharacterWidth * (nExtraWidthPercent / 100)
oShape.TextLeftDistance = nExtraWidth
oShape.TextRightDistance = nExtraWidth
nWidth = nWidth + 2 * nExtraWidth
' Now resize the text shape.
oShape.Size = MakeSize( nWidth, nHeight )
' Return the shape to the caller
DrawAutoSizingText() = oShape
End Function
'############################################################
' Complex Shape drawing utilities
'############################################################
'----------
' Draw a spiral from a starting position and direction.
' The spiral turns either left or right.
' Parameters:
' Current turtle position...
' nStartX, nStartY - position where the "turtle" currently is located.
' nStartDirectionAngle - turtle direction (in 100'ths of a degree).
' (both of the above parameters are updated to the new turtle location and
' direction at the end of the arc.)
'
' Arc which begins at current turtle position...
' nArcAngle - angle of the arc.
' nArcRadius = radius of the arc.
'
' bTurnLeft - does the arc turn to the left (TRUE) or to the right (FALSE)?
' nNumArcs - the number of arcs which will make up the spiral.
' This number times nArcAngle determines the entire angle of the spiral.
' nRadiusGrowthMultiplier - the radius is multiplied by this after each arc.
' Use a number such as 1.1 to cause the radius
' to grow geometrically as the spiral turns.
' nRadiusGrowthAddIn - this is added to the radius after each arc.
' Use a number, such as the original nArcRadius / number of arcs in
' a complete circle to cause the radius
' to grow arithmeteically as the spiral turns.
'
Function DrawSpiralOfArcs( oDoc As Object, oDrawPage As Object,_
nStartX As Long, nStartY As Long, nStartDirectionAngle As Long,_
ByVal nArcAngle As Long, ByVal nArcRadius As Long,_
ByVal bTurnLeft As Boolean,_
ByVal nNumArcs As Long,_
ByVal nRadiusGrowthMultiplier As Double, ByVal nRadiusGrowthAddIn As Long )
nX = nStartX
nY = nStartY
nAngle = nStartDirectionAngle
oShapesToGroup = createUnoService( "com.sun.star.drawing.ShapeCollection" )
For i = 1 To nNumArcs
oArcShape = DrawArcPath( oDoc, oDrawPage, nX, nY, nAngle,_
nArcAngle, nArcRadius, bTurnLeft )
nArcRadius = nArcRadius * nRadiusGrowthMultiplier + nRadiusGrowthAddIn
oShapesToGroup.add( oArcShape )
Next
oSpiralShape = oDrawPage.Group( oShapesToGroup )
nStartX = nX
nStartY = nY
nStartDirectionAngle = nAngle
DrawSpiralOfArcs() = oSpiralShape
End Function
'----------
' Draw a "sun" whose rays or spokes are wavy curved lines.
' Parameters:
' nCenterX,nCenterY - center position
' nNumRays - number of rays or spokes
' nRaySegments - the number of arcs that each spoke is made from
' nArcAngle - angle of the first arc.
' nArcRadius = radius of the first arc.
' bTurnLeft - does the first arc turn to the left (TRUE) or to the right (FALSE)?
' nRadiusGrowthMultiplier - the arc radius is multiplied by this after each arc.
' Use a number such as 1.1 to cause the radius
' to grow geometrically as the ray moves outward from center.
' nRadiusGrowthAddIn - this is added to the arc radius after each arc.
' Use a number, such as a fraction of the original nArcRadius
' to grow the arc arithmeteically as the ray moves outward from center.
' nCenterMargin - A gap between the center point and the start of the wavy curve spoke.
'
Function DrawFlowerOfArcs( oDoc As Object, oDrawPage As Object,_
ByVal nCenterX As Long, ByVal nCenterY As Long,_
ByVal nNumRays As Long,_
ByVal nRaySegments As Long,_
ByVal nArcAngle As Long, ByVal nArcRadius, ByVal bTurnLeft As Boolean,_
ByVal nRadiusMultiplier As Double, ByVal nRadiusAddIn As Long,_
ByVal nCenterMargin As Long )
oShapesToGroup = createUnoService( "com.sun.star.drawing.ShapeCollection" )
For i = 0 To nNumRays
nAngle = 36000 * (i / nNumRays)
nAngleRadians = nAngle / 18000 * PI
nPosX = nCenterX
nPosY = nCenterY
If nCenterMargin > 0 Then
nPosX = nPosX + cos( nAngleRadians ) * nCenterMargin
nPosY = nPosY - sin( nAngleRadians ) * nCenterMargin
EndIf
nRadius = nArcRadius
bTurnLeft2 = bTurnLeft
For j = 1 To nRaySegments
oArcShape = DrawArcPath( oDoc, oDrawPage, nPosX, nPosY, nAngle, nArcAngle, nRadius, bTurnLeft2 )
oShapesToGroup.add( oArcShape )
nRadius = (nRadius * nRadiusMultiplier) + nRadiusAddIn
bTurnLeft2 = Not bTurnLeft2
Next
Next
oFlowerShape = oDrawPage.Group( oShapesToGroup )
DrawFlowerOfArcs() = oFlowerShape
End Function
'----------
' Utility to draw crosshairs at a selected point.
' More useful for debugging drawing code than anything.
'
Sub DrawCrosshairs( oDoc As Object, oDrawPage As Object, oPoint As Object,_
Optional nCrossHairRadius, Optional nCrossHairColor )
If IsMissing( nCrossHairRadius ) Then
nCrossHairRadius = 400
EndIf
nCrossHairDiameter = nCrossHairRadius + nCrossHairRadius
If IsMissing( nCrossHairColor ) Then
nCrossHairColor = 0 ' Black
EndIf
oShape = MakeLineShape( oDoc, MakePoint( oPoint.X - nCrossHairRadius, oPoint.Y ),_
MakeSize( nCrossHairDiameter, 0 ) )
oDrawPage.add( oShape )
oShape.LineColor = nCrossHairColor
oShape = MakeLineShape( oDoc, MakePoint( oPoint.X, oPoint.Y - nCrossHairRadius ),_
MakeSize( 0, nCrossHairDiameter ) )
oDrawPage.add( oShape )
oShape.LineColor = nCrossHairColor
End Sub
'############################################################
' Selection manipulation
'############################################################
' NOTE: older but more generic example...
' ...current document's controller
' oDocCtrl = oDoc.getCurrentController()
' Select nothing -- i.e. an empty collection of shapes.
' oDocCtrl.select( createUnoService( "com.sun.star.drawing.ShapeCollection" ) )
' Select nothing on a drawing document.
' Parameters:
' oDocCtrl
' - The document controller.
' Note: is okay if you pass in either the
' document model or frame instead of a controller.
Sub DrawingSelectNothing( ByVal oDocCtrl )
' Select nothing -- i.e. an empty collection of shapes.
DrawingSelectShapes( oDocCtrl, createUnoService( "com.sun.star.drawing.ShapeCollection" ) )
End Sub
' Select some shapes on a drawing document.
' Parameters:
' oDocCtrl
' - The document controller.
' Note: is okay if you pass in either the
' document model or frame instead of a controller.
' oShapes
' - A collection of shapes implementing com.sun.star.drawing.ShapeCollection.
' As a convenience, if you pass in a *single* shape object,
' this routine will encapsulate it into a shape collection
' of just the single shape. So you can easily call this
' to just select one shape.
Sub DrawingSelectShapes( ByVal oDocCtrl, ByVal oShapes )
' If they gave us the incorrect parameter...
If Not HasUnoInterfaces( oDocCtrl, "com.sun.star.frame.XController" ) Then
' Be sure that we've got the document frame.
' Someone might have passed us the document model or one of
' its controller's.
oDocCtrl = GetDocumentController( oDocCtrl )
EndIf
' If they gave us a shape instead of a shape group...
If oShapes.SupportsService( "com.sun.star.drawing.Shape" ) Then
' ...then create a shape collection
oShapeCollection = createUnoService( "com.sun.star.drawing.ShapeCollection" )
' and add the one shape they gave us to it.
oShapeCollection.add( oShapes ) ' add the one shape to the collection
' If they gave us a shape collection, as they were supposed to...
' ElseIf oShapes.supportsService( "com.sun.star.drawing.ShapeCollection" ) Then
ElseIf HasUnoInterfaces( oShapes, "com.sun.star.drawing.XShapes" ) Then
' Then they gave us what we need.
oShapeCollection = oShapes
' If they didn't give us either a shape or shape collection...
Else
' Just create an empty shape collection of no shapes.
' Thus, nothing will be selected on the drawing.
oShapeCollection = createUnoService( "com.sun.star.drawing.ShapeCollection" )
EndIf
' Select the shapes.
oDocCtrl.select( oShapeCollection )
End Sub
' Get the collection of shapes on a drawing.
' This returns a com.sun.star.drawing.ShapeCollection,
' whose getCount() may be zero thus indicating that
' there are no shapes to getByIndex(), and thus nothing selected.
' Parameters:
' oDocCtrl
' - The document controller.
' Note: is okay if you pass in either the
' document model or frame instead of a controller.
Function DrawingGetSelection( ByVal oDocCtrl )
' If they gave us the incorrect parameter...
If Not HasUnoInterfaces( oDocCtrl, "com.sun.star.frame.XController" ) Then
' Be sure that we've got the document frame.
' Someone might have passed us the document model or one of
' its controller's.
oDocCtrl = GetDocumentController( oDocCtrl )
EndIf
oSelectedShapes = oDocCtrl.getSelection()
' If nothing was returned...
If IsEmpty( oSelectedShapes ) Then
' Then for the convenience of the caller,
' return an empty collection of shapes.
oSelectedShapes = createUnoService( "com.sun.star.drawing.ShapeCollection" )
EndIf
DrawingGetSelection() = oSelectedShapes
End Function
'############################################################
' Drawing utilities via. the Dispatcher
'############################################################
' Using the clipboard, make a duplicate of any shape which
' is passed in as a parameter.
' How this macro works.
' 1. Select the shape we want to duplicate.
' 2. Copy selected shape to clipboard.
' 3. Deselect everything.
' 4. Paste shape back to drawing. (No objects overwritten
' because nothing is currently selected.)
' 5. Find currently selected shape. (The one just pasted.)
' 6. Return the currently selected shape.
' The parameter oDrawDoc can be any of the document model, one of
' the document's controllers, or frames.
Function DrawingDuplicateShapeViaClipboard( oDrawDoc, oShape )
' Make the original shape be the only thing selected.
DrawingSelectShapes( oDrawDoc, oShape )
' Copy the shape.
ClipboardCopy( oDrawDoc )
' Make sure nothing is currently selected.
' (So that pasting doesn't paste over the currently selected shape.)
DrawingSelectNothing( oDrawDoc )
' Paste the shape copied earlier.
ClipboardPaste( oDrawDoc )
' Get the currently selected shapes on the drawing.
' The only thing selected is the shape we just pasted.
oSelectedShapes = DrawingGetSelection( oDrawDoc )
' Blindly assume that there is one shape selected
' and retrieve it.
oNewShape = oSelectedShapes.getByIndex( 0 )
DrawingDuplicateShapeViaClipboard() = oNewShape
End Function
|
_________________
Want to make OOo Drawings like the colored flower design to the left? |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:33 pm Post subject: |
|
|
| Code: | '**********************************************************************
' DocWriter module
'
' Module of routines to create and manipulate
' OpenOffice.org Writer documents.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-06-26-01
'
'**********************************************************************
Sub Main
WriterTest()
End Sub
'############################################################
' Utilities to create, initialize and return common
' structs or services.
'############################################################
'----------
' Create and return a tab stop.
' An array of what this function returns, is used
' to set the tab stops of a paragraph.
'
' Parameters....
' nPosition - position in tab stop, in 1000'th of cm.
' nAlign - optional, if specified, must be one of...
' com.sun.star.style.TabAlign.LEFT = 0
' com.sun.star.style.TabAlign.CENTER = 1
' com.sun.star.style.TabAlign.RIGHT = 2
' com.sun.star.style.TabAlign.DECIMAL = 3
' com.sun.star.style.TabAlign.DEFAULT = 4
' cDecimalChar - optional, if specified, only applies to a DECIMAL tab stop,
' and specified the character which is recognized as
' the decimal point separator.
' cFillChar - optional, if specified, specifies the char that fills the space
' between tab stops.
Function MakeTabStop( ByVal nPosition As Long,_
Optional nAlign,_
Optional cDecimalChar,_
Optional cFillChar _
) As com.sun.star.style.TabStop
If IsMissing( nAlign ) Then
nAlign = com.sun.star.style.TabAlign.LEFT
EndIf
oTabStop = createUnoStruct( "com.sun.star.style.TabStop" )
oTabStop.Position = nPosition
oTabStop.Alignment = nAlign
If Not IsMissing( cDecimalChar ) Then
oTabStop.DecimalChar = cDecimalChar
EndIf
If Not IsMissing( cFillChar ) Then
oTabStop.FillChar = cFillChar
EndIf
MakeTabStop() = oTabStop
End Function
' Set tab stops every nIncrementCm up to nMaxCm.
Sub SetTabStops( oWriterCursor, nIncrementCm, nMaxCm, Optional nMinCm )
If IsMissing( nMinCm ) Then
nMinCm = nIncrementCm
EndIf
oTabStops = Array()
For nTabCm = nMinCm To nMaxCm Step nIncrementCm
Array1_AppendElement( oTabStops, MakeTabStop( nTabCm ) )
Next
oWriterCursor.ParaTabStops = oTabStops
End Sub
'############################################################
' Convenience routines.
'############################################################
Sub InsertString( oCursor, cString )
oText = oCursor.getText()
oText.insertString( oCursor, cString, False )
End Sub
Sub InsertLineBreak( oCursor )
oText = oCursor.getText()
oText.insertControlCharacter( oCursor, com.sun.star.text.ControlCharacter.LINE_BREAK, False )
End Sub
Sub InsertParaBreak( oCursor )
oText = oCursor.getText()
oText.insertControlCharacter( oCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False )
End Sub
Sub InsertPageBreak( oCursor )
oText = oCursor.getText()
oText.insertControlCharacter( oCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False )
oCursor.BreakType = com.sun.star.style.BreakType.PAGE_BEFORE
End Sub
Sub InsertColumnBreak( oCursor )
oText = oCursor.getText()
oText.insertControlCharacter( oCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False )
oCursor.BreakType = com.sun.star.style.BreakType.COLUMN_BEFORE
End Sub
'############################################################
' Routines to make it easy to
' generate lots of text output into a new Writer document.
'############################################################
' NOTE:
' How to create a writer document.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/swriter", "_blank", 0, Array() )
' Sugar Coated way to Print into a Writer document.
' The oOutput parameter can be any of....
' com.sun.star.text.TextDocument
' com.sun.star.drawing.Text
' com.sun.star.text.TextCursor
Sub Writer_Print( oOutput, cString )
If oOutput.SupportsService( "com.sun.star.text.TextDocument" ) Then
oText = oOutput.getText()
oCursor = oText.createTextCursor()
ElseIf oOutput.SupportsService( "com.sun.star.drawing.Text" ) Then
oText = oOutput
oCursor = oText.createTextCursor()
ElseIf oOutput.SupportsService( "com.sun.star.text.Text" ) Then
oText = oOutput
oCursor = oText.createTextCursor()
ElseIf oOutput.SupportsService( "com.sun.star.text.TextCursor" ) Then
oCursor = oOutput
oText = oCursor.getText()
Else
Exit Sub
EndIf
oCursor.gotoEnd( False )
nLen = Len( cString )
nStart = 1
Do
nPos = Instr( nStart, cString, Chr(13) )
bCRFound = (nPos > 0)
If Not bCRFound Then
nPos = nLen + 1
EndIf
cSegment = Mid( cString, nStart, nPos-nStart )
nStart = nPos + 1
oText.insertString( oCursor, cSegment, False )
If bCRFound Then
oText.insertControlCharacter( oCursor, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False )
EndIf
Loop While bCRFound
End Sub
' Same as Writer_Print(), just adds a line ending.
Sub Writer_PrintLn( oOutput, Optional cString )
If IsMissing( cString ) Then
cString = ""
EndIf
Writer_Print( oOutput, cString + Chr(13) )
End Sub
'############################################################
' Styles
'############################################################
'----------
' Add a new style to the style catalog if it is not already present.
' This returns the style object so that you can alter its properties.
'
Function DefineParagraphStyle( oDoc As Object, cStyleName As String, Optional cParentStyleName As String )
If IsMissing( cParentStyleName ) Then
cParentStyleName = ""
EndIf
oStyleFamily = oDoc.getStyleFamilies().getByName( "ParagraphStyles" )
' Does the style already exist?
If oStyleFamily.hasByName( cStyleName ) Then
' Then get it so we can return it.
oStyle = oStyleFamily.getByName( cStyleName )
Else
' Create new style object.
oStyle = oDoc.createInstance( "com.sun.star.style.ParagraphStyle" )
' Set its parent style, if one is specified.
If Not IsMissing( cParentStyleName ) And Len( cParentStyleName ) > 0 Then
oStyle.setParentStyle( cParentStyleName )
EndIf
' Add the new style to the style family.
oStyleFamily.insertByName( cStyleName, oStyle )
EndIf
' Return the new style
DefineParagraphStyle() = oStyle
End Function
'############################################################
' Sugar coated Dispatch routiens
'############################################################
' Turn on or off the Online Layout view of a Writer document.
' Similar to manually picking... View --> Online Layout
' Parameters:
' oDocumentFrame
' - the document frame.
' (Actually, it is okay if you pass either the
' document model or the document controller.)
' Optional parameters:
' bOnlineView
' - whether to put the Writer document into Online view
' or normal view. (default is online view)
'
Sub WriterOnlineLayout( ByVal oDocumentFrame As Object, Optional bOnlineView )
If IsMissing( bOnlineView ) Then
bOnlineView = True
EndIf
DocumentDispatch( oDocumentFrame, ".uno:BrowseView", "", 0,_
Array( MakePropertyValue( "BrowseView", bOnlineView ) ) )
End Sub
'############################################################
' Test program
'############################################################
Sub WriterTest()
' Create a Writer doc
oDoc = StarDesktop.loadComponentFromURL( "private:factory/swriter", "_blank", 0, Array() )
oText = oDoc.getText()
oCursor = oText.createTextCursor()
oCursor.gotoEnd( False )
oText.insertString( oCursor, "Some text in Heading 1 style.", False )
oCursor.ParaStyleName = "Heading 1"
InsertParaBreak( oCursor )
oCursor.ParaStyleName = "Default"
InsertParaBreak( oCursor )
' Tab stops at:
' 2.00 inch (2.54 cm x 2.00)
' 4.00 inch (2.54 cm x 4.00)
oCursor.ParaTabStops = _
Array(_
MakeTabStop( 2540 * 2.00 ),_
MakeTabStop( 2540 * 4.00 ) )
' Set tab stops every 0.25 inch up to 5.00 inches.
' (Note the measurements are in 1/1000 cm, and there are 2.54 cm/inch.)
' SetTabStops( oCursor, 0.25*2540, 5.00*2540 )
' Now here is the example of how we print out some stuff.
Writer_PrintLn( oDoc, "Here is a list of random numbers, in two columns." )
For i = 1 To 50
Writer_PrintLn( oDoc, CSTR(i) + Chr(9) + CSTR(RND()) + CHR(9) + CSTR(RND()) )
Next
InsertParaBreak( oCursor )
End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left? |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:33 pm Post subject: |
|
|
UtilAPI module
Code in this module was previously published in a more primitive form here....
Making the Dispatcher easier to use
http://www.oooforum.org/forum/viewtopic.phtml?t=5058
Document model, controller and frame
http://www.oooforum.org/forum/viewtopic.phtml?t=5057
| Code: | '**********************************************************************
' UtilAPI module
'
' Module of utility routines for working with the OOo API.
' These utilities are not specific to Draw, or Writer,
' or Calc, for instance.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-10-25-01
'
'**********************************************************************
Sub Main
' TestBase64()
' TestNavAPI()
End Sub
'------------------------------------------------------------
' Notes
'------------------------------------------------------------
' One Liners to create documents....
'
' ' Create a new drawing.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/sdraw", "_blank", 0, Array() )
'
' ' Create a new text document.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/swriter", "_blank", 0, Array() )
'
' ' Create a new presentation document.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/simpress", "_blank", 0, Array() )
'
' ' Create a new spreadsheet document.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/scalc", "_blank", 0, Array() )
'
' ' Create a new math document.
' oDoc = StarDesktop.loadComponentFromURL( "private:factory/smath", "_blank", 0, Array() )
'
'
' One liners to open documents...
'
' ' Open a drawing document on the Windows desktop.
' oDoc = StarDesktop.loadComponentFromURL( ConvertToURL( "c:\Documents and Settings\dbrewer\Desktop\UglyMonkeys.sxd" ), "_blank", 0, Array() )
'
' ' Open a drawing document on a Linux /tmp directory
' oDoc = StarDesktop.loadComponentFromURL( ConvertToURL( "/tmp/DogNFireHydrant.sxd" ), "_blank", 0, Array() )
'
' ' Open a document which is on a web server.
' oDoc = StarDesktop.loadComponentFromURL( "http://somewhere.com/docs/UglyMonkeys.sxd", "_blank", 0, Array() )
'
' ' Open a document which is on an ftp server.
' oDoc = StarDesktop.loadComponentFromURL( "ftp://username:password@somewhere.com/docs/UglyMonkeys.sxd", "_blank", 0, Array() )
' '....or leave off password to be prompted for password...
' oDoc = StarDesktop.loadComponentFromURL( "ftp://username@somewhere.com/docs/UglyMonkeys.sxd", "_blank", 0, Array() )
'
' ' The following items are described in the Developer's Guide, under section 6.1.5, under Loading Documents.
' ' http://api.openoffice.org/docs/DevelopersGuide/OfficeDev/OfficeDev.htm#1+1+5+1+Loading+Documents
'
' Misc...
'
' ' This opens a Data Sources View window. Useful.
' oDoc = StarDesktop.loadComponentFromURL( ".component:DB/DataSourceBrowser", "_blank", 0, Array() )
'
'
' To get a page from a drawing...
'
' oDrawPage = oDrawDoc.getDrawPages().getByIndex( 0 )
'############################################################
' Utilities to create, initialize and return common
' structs or services.
'############################################################
'----------
' Create and return a new com.sun.star.awt.Rectangle.
'
Function MakeRectangle( ByVal nX As Long, ByVal nY As Long,_
ByVal nWidth As Long, ByVal nHeight As Long ) As com.sun.star.awt.Rectangle
oRectangle = createUnoStruct( "com.sun.star.awt.Rectangle" )
With oRectangle
.X = nX
.Y = nY
.Width = nWidth
.Height = nHeight
End With
MakeRectangle() = oRectangle
End Function
'############################################################
' Styles
'############################################################
' Here is how to see the style families that a document supports...
' Print Join( oDoc.getStyleFamilies().getElementNames() )
'----------
' Add a new style to the style catalog if it is not already present.
' This returns the style object so that you can alter its properties.
'
' The oDoc parameter can be any one of...
' * the document's model (subclass of com.sun.star.document.OfficeDocument)
' * the document's controller
' * the document's frame
'
Function DefineStyle( oDoc As Object, cStyleFamily As String, cStyleName As String, Optional cParentStyleName As String )
' Make sure we've got the document model.
oDoc = GetDocumentModel( oDoc )
oStyleFamily = oDoc.getStyleFamilies().getByName( cStyleFamily )
' Does the style already exist?
If oStyleFamily.hasByName( cStyleName ) Then
' Then get it so we can return it.
oStyle = oStyleFamily.getByName( cStyleName )
Else
' Create new style object.
oStyle = oDoc.createInstance( "com.sun.star.style.Style" )
' Set its parent style, if one is specified.
If Not IsMissing( cParentStyleName ) And Len( cParentStyleName ) > 0 Then
oStyle.setParentStyle( cParentStyleName )
EndIf
' Add the new style to the style family.
oStyleFamily.insertByName( cStyleName, oStyle )
EndIf
' Return the new style
DefineStyle() = oStyle
End Function
'----------
' Lookup and return a style from the document.
'
' The oDoc parameter can be any one of...
' * the document's model (subclass of com.sun.star.document.OfficeDocument)
' * the document's controller
' * the document's frame
'
Function GetStyle( oDoc As Object, cStyleFamily As String, cStyleName As String )
' Make sure we've got the document model.
oDoc = GetDocumentModel( oDoc )
GetStyle() = oDoc.getStyleFamilies().getByName( cStyleFamily ).getByName( cStyleName )
End Function
'############################################################
' API navigation convenience
'############################################################
'----------
' This will always return the document's controller.
' Pass in any one of...
' * the document's model (subclass of com.sun.star.document.OfficeDocument)
' * the document's controller
' * the document's frame
Function GetDocumentController( oDoc As Object ) As Object
Dim oCtrl As Object
' If the caller gave us the document model...
If oDoc.supportsService( "com.sun.star.document.OfficeDocument" ) Then
' ...then get the controller from that.
oCtrl = oDoc.getCurrentController()
' If the caller gave us a document controller...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XController" ) Then
' ...thanks! That's just what we wanted!
oCtrl = oDoc
' If the caller gave us the document frame...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XFrame" ) Then
oFrame = oDoc
' ...then get the controller from the frame.
oCtrl = oFrame.getController()
Else
' The caller did not give us what we expected!
MsgBox( "GetDocController called with incorrect parameter." )
EndIf
GetDocumentController() = oCtrl
End Function
'----------
' This will always return the document's frame.
' Pass in any one of...
' * the document's model (subclass of com.sun.star.document.OfficeDocument)
' * the document's controller
' * the document's frame
Function GetDocumentFrame( oDoc As Object ) As Object
Dim oFrame As Object
' If the caller gave us the document model...
If oDoc.supportsService( "com.sun.star.document.OfficeDocument" ) Then
' ...then get the controller from that.
oCtrl = oDoc.getCurrentController()
' ...then get the frame from the controller.
oFrame = oCtrl.getFrame()
' If the caller gave us a document controller...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XController" ) Then
oCtrl = oDoc
' ...then get the frame from the controller.
oFrame = oCtrl.getFrame()
' If the caller gave us the document frame...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XFrame" ) Then
' ...thanks! That's just what we wanted!
oFrame = oDoc
Else
' The caller did not give us what we expected!
MsgBox( "GetDocumentFrame called with incorrect parameter." )
EndIf
GetDocumentFrame() = oFrame
End Function
'----------
' This will always return the document's model.
' Pass in any one of...
' * the document's model (subclass of com.sun.star.document.OfficeDocument)
' * the document's controller
' * the document's frame
Function GetDocumentModel( oDoc As Object ) As Object
Dim oDocModel As Object
' If the caller gave us the document model...
If oDoc.supportsService( "com.sun.star.document.OfficeDocument" ) Then
' ...thanks! That's just what we wanted!
oDocModel = oDoc
' If the caller gave us a document controller...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XController" ) Then
oCtrl = oDoc
' ...then get the model from the controller.
oDocModel = oCtrl.getModel()
' If the caller gave us the document frame...
ElseIf HasUnoInterfaces( oDoc, "com.sun.star.frame.XFrame" ) Then
oFrame = oDoc
' ...then get the controller from the frame.
oCtrl = oFrame.getController()
' ...then get the model from the controller.
oDocModel = oCtrl.getModel()
Else
' The caller did not give us what we expected!
MsgBox( "GetDocumentModel called with incorrect parameter." )
EndIf
GetDocumentModel() = oDocModel
End Function
'Sub TestNavAPI()
' oDrawDoc = StarDesktop.loadComponentFromURL( "private:factory/sdraw", "_blank", 0, Array() )
'
' oDrawPage = oDrawDoc.getDrawPages().getByIndex( 0 )
' oShape = MakeEllipseShape( oDrawDoc, MakePoint( 10000, 10000 ), MakeSize( 5000, 5000 ) )
' oDrawPage.add( oShape )
'
' oDrawDocCtrl = oDrawDoc.getCurrentController()
' oDrawDocFrame = oDrawDocCtrl.getFrame()
'
' oD = oDrawDoc
'' oD = oDrawDocCtrl
'' oD = oDrawDocFrame
'
' DrawingSelectShapes( oD, oShape )
' ClipboardCopy( oD )
'' ClipboardCut( oD )
' ClipboardPaste( oD )
'
' oShape = DrawingGetSelection( oD ).getByIndex( 0 )
'
' oShape.Position = MakePoint( oShape.Position.X - 3000, oShape.Position.Y + 6000 )
'End Sub
'############################################################
' Dispatch help
'############################################################
'----------
' A super easy to use Dispatch on an office document.
' Arguments are similar to the args for the com.sun.star.frame.XDispatchHelper
' interface of com.sun.star.frame.DispatchHelper.
' What makes this so easy to use are two things:
' 1. The fact that the oDocumentFrame parameter can actually accept
' either the document model or one of its controllers.
' 2. The optional parameters.
' For an example of how simple this routine is to use, see
' routines below such as ClipboardCopy().
'
' Parameters:
' oDocumentFrame - An office document frame.
' But wait! It could be the document controller
' or the document model. This routine will find
' the document frame from either of these.
' cURL - The dispatch URL.
' Optional:
' cTargetFrameName - Defaults to blank.
' nSearchFlags - Defaults to zero.
' aDispatchArgs - Defaults an an empty sequence.
'
Sub DocumentDispatch( ByVal oDocumentFrame As Object,_
ByVal cURL As String,_
Optional cTargetFrameName,_
Optional nSearchFlags,_
Optional aDispatchArgs )
' If they gave us the wrong parameter...
If Not IsNull( oDocumentFrame ) Then
If Not HasUnoInterfaces( oDocumentFrame, "com.sun.star.frame.XFrame" ) Then
' Be sure that we've got the document frame.
' Someone might have passed us the document model or one of
' its controller's.
oDocumentFrame = GetDocumentFrame( oDocumentFrame )
EndIf
EndIf
If IsMissing( cTargetFrameName ) Then
cTargetFrameName = ""
EndIf
If IsMissing( nSearchFlags ) Then
nSearchFlags = 0
EndIf
If IsMissing( aDispatchArgs ) Then
aDispatchArgs = Array()
EndIf
oDispatchHelper = createUnoService( "com.sun.star.frame.DispatchHelper" )
oDispatchHelper.executeDispatch( oDocumentFrame, cURL, cTargetFrameName, nSearchFlags, aDispatchArgs )
End Sub
'############################################################
' Clipboard manipulation
'############################################################
Sub ClipboardPaste( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:Paste" )
' DocumentDispatch( oDocumentFrame, "slot:5712" )
End Sub
Sub ClipboardCopy( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:Copy" )
' DocumentDispatch( oDocumentFrame, "slot:5711" )
End Sub
Sub ClipboardCut( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:Cut" )
' DocumentDispatch( oDocumentFrame, "slot:5710" )
End Sub
' Given a string of text, put that text into the clipboard.
' This works by...
' 1. Invisibly create a new Writer document
' 2. Insert text into that document.
' 3. Select All
' 4. Copy
' 5. Close the invisible writer document.
' So what ends up in the clipboard can be pasted to an external
' program as Text. But the clipboard contains additional information
' about the text, such as whatever default font and style it had in
' the temporary Writer document.
'
Sub TextToClipboard( ByVal cText As String )
oDoc = StarDesktop.loadComponentFromURL( "private:factory/swriter", "_blank", 0,_
Array( MakePropertyValue( "Hidden", True ) ) )
' Get the text of the document.
oText = oDoc.getText()
' Get a cursor that can move over or to any part of the text.
oCursor = oText.createTextCursor()
' Insert text and paragraph breaks into the text, at the cursor position.
oText.insertString( oCursor, cText, False )
SelectAll( oDoc )
ClipboardCopy( oDoc )
oDoc.close( True )
End Sub
'############################################################
' Misc. other Dispatch utilities
'############################################################
Sub SelectAll( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:SelectAll" )
' DocumentDispatch( oDocumentFrame, "slot:5723" )
End Sub
Sub DrawFlipVertical( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:MirrorVert" )
End Sub
Sub DrawFlipHorizontal( oDocumentFrame )
DocumentDispatch( oDocumentFrame, ".uno:MirrorHorz" )
End Sub
'############################################################
' Compare operators for com.sun.star.util.DateTime
'############################################################
' Return True if oDateTime1 is equal to oDateTime2.
Function DateTimeEqual( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeEqual = False
If oDateTime1.HundredthSeconds = oDateTime2.HundredthSeconds _
And oDateTime1.Seconds = oDateTime2.Seconds _
And oDateTime1.Minutes = oDateTime2.Minutes _
And oDateTime1.Hours = oDateTime2.Hours _
And oDateTime1.Day = oDateTime2.Day _
And oDateTime1.Month = oDateTime2.Month _
And oDateTime1.Year = oDateTime2.Year _
Then
DateTimeEqual = True
EndIf
End Function
' Return True if oDateTime1 is greater than oDateTime2.
Function DateTimeGreater( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeGreater = False
If oDateTime1.Year > oDateTime2.Year Then
DateTimeGreater = True
ElseIf oDateTime1.Year = oDateTime2.Year Then
If oDateTime1.Month > oDateTime2.Month Then
DateTimeGreater = True
ElseIf oDateTime1.Month = oDateTime2.Month Then
If oDateTime1.Day > oDateTime2.Day Then
DateTimeGreater = True
ElseIf oDateTime1.Day = oDateTime2.Day Then
If oDateTime1.Hours > oDateTime2.Hours Then
DateTimeGreater = True
ElseIf oDateTime1.Hours = oDateTime2.Hours Then
If oDateTime1.Minutes > oDateTime2.Minutes Then
DateTimeGreater = True
ElseIf oDateTime1.Minutes = oDateTime2.Minutes Then
If oDateTime1.Seconds > oDateTime2.Seconds Then
DateTimeGreater = True
ElseIf oDateTime1.Seconds = oDateTime2.Seconds Then
If oDateTime1.HundredthSeconds > oDateTime2.HundredthSeconds Then
DateTimeGreater = True
EndIf
EndIf
EndIf
EndIf
EndIf
EndIf
EndIf
End Function
' Return True if oDateTime1 is less than oDateTime2.
Function DateTimeLess( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeLess = DateTimeGreater( oDateTime2, oDateTime1 )
End Function
' Return True if oDateTime1 is greater than or equal to oDateTime2.
Function DateTimeGreaterOrEqual( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeGreaterOrEqual = Not DateTimeLess( oDateTime1, oDateTime2 )
End Function
' Return True if oDateTime1 is less than or equal to oDateTime2.
Function DateTimeLessOrEqual( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeLessOrEqual = Not DateTimeGreater( oDateTime1, oDateTime2 )
End Function
' Return True if oDateTime1 is not equal to oDateTime2.
Function DateTimeNotEqual( ByVal oDateTime1 As com.sun.star.util.DateTime, _
ByVal oDateTime2 As com.sun.star.util.DateTime ) As Boolean
DateTimeNotEqual = Not DateTimeEqual( oDateTime1, oDateTime2 )
End Function
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:21 pm; edited 2 times in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:33 pm Post subject: |
|
|
UtilBasic module
Several other threads previously published earlier versions of this code....
Bit manipulation utility functions
http://www.oooforum.org/forum/viewtopic.phtml?t=9636
Hex utility functions
http://www.oooforum.org/forum/viewtopic.phtml?t=6934
EncodeFile and EncodeIcon
http://www.oooforum.org/forum/viewtopic.phtml?t=6910
arcsin in draw macros
http://www.oooforum.org/forum/viewtopic.phtml?p=68139#68139
| Code: | '**********************************************************************
' UtilBasic module
'
' Module of utility routines to make OOo Basic easier to use.
' Various type conversions, convenience routines, etc.
' These utilities are not specific to Draw, or Writer,
' or Calc, for instance.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2005-04-02-01
'
'
'**********************************************************************
Sub Main
End Sub
'############################################################
' Silly StarBasic doesn't include the classic ASIN() and ACOS() functions.
'############################################################
Function ArcSin( x )
ArcSin = Atn( x / Sqr(-x * x + 1) )
End Function
Function ArcCos( x )
ArcCos = ArcSin( Sqr( 1 - x^2 ) )
End Function
'############################################################
' Silly StarBasic doesn't even include the classic MIN() and MAX() functions.
' These functions are untyped so that you can pass values of any type, such
' as an Integer, Long or Double.
'############################################################
Function Min2( p1, p2 )
If p1 < p2 Then
Min2() = p1
Else
Min2() = p2
EndIf
End Function
Function Max2( p1, p2 )
If p1 > p2 Then
Max2() = p1
Else
Max2() = p2
EndIf
End Function
Function Min3( p1, p2, p3 )
Min3() = Min2( p1, Min2( p2, p3 ) )
End Function
Function Max3( p1, p2, p3 )
Max3() = Max2( p1, Max2( p2, p3 ) )
End Function
'############################################################
' Angular mesaurement conversion
'############################################################
Function DegToRad( nDegrees )
DegToRad = nDegrees * PI / 180
End Function
Function RadToDeg( nRadians )
RadToDeg = nRadians * 180 / PI
End Function
'############################################################
' Signed and Unsigned Byte conversion.
'############################################################
' Convert a byte value from the range -128 to +127 into
' an integer in the range 0 to 255.
' This function is the opposite of IntegerToByte().
Function ByteToInteger( ByVal nByte As Integer ) As Integer
If nByte < 0 Then
nByte = nByte + 256
EndIf
ByteToInteger() = nByte
End Function
' This function is the opposite of ByteToInteger().
Function IntegerToByte( ByVal nByte As Integer ) As Integer
If nByte > 127 Then
nByte = nByte - 256
EndIf
IntegerToByte() = nByte
End Function
'############################################################
' Random number functions.
'############################################################
' Return a random floating point from nMin to nMax.
Function RandomFrac( ByVal nMin As Double, ByVal nMax As Double ) As Double
RandomFrac() = nMin + RND() * (nMax - nMin)
End Function
' Return a random Long integer from nMin to nMax.
Function RandomInt( ByVal nMin As Long, ByVal nMax As Long ) As Long
RandomInt() = Int( RandomFrac( nMin, nMax ) )
End Function
'############################################################
' Hex utilities.
'############################################################
'----------
' Pass in a string of Hex digits, and this returns their decimal value.
' Example of how to call...
'
' Print HexDigitsToIntValue( "FFFF" ), "Expected: 65535"
' Print HexDigitsToIntValue( "100" ), "Expected: 256"
' Print HexDigitsToIntValue( "FE" ), "Expected: 254"
' Print HexDigitsToIntValue( "FF" ), "Expected: 255"
' Print HexDigitsToIntValue( "7F" ), "Expected: 127"
'
Function HexDigitsToIntValue( ByVal cHexDigits As String ) As Long
nValue = 0
nNumHexDigits = Len( cHexDigits )
For i = 1 To nNumHexDigits
c = Mid( cHexDigits, i, 1 )
nValue = (nValue * 16) + _ValueOfHexDigit( c )
Next
HexDigitsToIntValue() = nValue
End Function
' Pass in a single hex digit, and this returns it's value from 0-15.
Function _ValueOfHexDigit( ByVal cHexDigit As String ) As Long
cHexDigit = UCase( cHexDigit )
nPos = Instr( 1, "0123456789ABCDEF", cHexDigit, 0 )
If nPos > 0 Then
nPos = nPos - 1
EndIf
_ValueOfHexDigit() = nPos
End Function
'----------
' Pass in an integer value, and this returns a string of hex digits.
' The 2nd optional parameter allows you to specify how wide of a string
' of hex digits to return.
' Example of how to call...
'
' Print IntValueToHexDigits( 65535 ), "Expected: FFFF"
' Print IntValueToHexDigits( 256 ), "Expected: 100"
' Print IntValueToHexDigits( 256, 6 ), "Expected: 000100" ' note 2nd parameter!
' Print IntValueToHexDigits( 254 ), "Expected: FE"
' Print IntValueToHexDigits( 255 ), "Expected: FF"
'
Function IntValueToHexDigits( ByVal nValue As Long, Optional nHexWidth ) As String
cHexDigits = ""
Do
nOneDigitValue = nValue Mod 16
nValue = Int( nValue / 16 )
cHexDigits = _ValueToHexDigit( nOneDigitValue ) + cHexDigits
Loop While nValue > 0
' Do we need to left zero fill?
If Not IsMissing( nHexWidth ) Then
Do While Len( cHexDigits ) < nHexWidth
cHexDigits = "0" + cHexDigits
Loop
EndIf
IntValueToHexDigits = cHexDigits
End Function
' Pass in a value from 0-15, and out comes an uppercase hex digit.
Function _ValueToHexDigit( ByVal nValue As Long )
IF nValue < 0 Then
_ValueToHexDigit() = "0"
ElseIf nValue < 10 Then
_ValueToHexDigit() = CHR(ASC("0")+nValue)
ElseIf nValue < 16 Then
_ValueToHexDigit() = CHR(ASC("A")+nValue-10)
Else
_ValueToHexDigit() = "0"
EndIf
End Function
'----------
' Pass in a string, and this returns a string twice as long of hex digits.
' Each character in the string is converted into a pair of hex digits.
'
Function StringToHexDigits( ByVal cString As String ) As String
cResult = ""
nLen = Len( cString )
For i = 1 To nLen
c = Mid( cString, i, 1 )
cResult = cResult + IntValueToHexDigits( Asc( c ) )
Next
StringToHexDigits() = cResult
End Function
' This is the oppoisite of StringToHexDigits().
Function HexDigitsToString( ByVal cHexString As String ) As String
cResult = ""
nLen = Int( Len( cHexString ) / 2 )
For i = 1 To nLen
cHexPair = Mid( cHexString, (i-1)*2+1, 2 )
cResult = cResult + Chr( HexDigitsToIntValue( cHexPair ) )
Next
HexDigitsToString() = cResult
End Function
'############################################################
' Bit manipulation functions.
'############################################################
' Return True if a particular bit in nBits is set.
' Bit 0 is the least significant bit.
Function IsBitSet( ByVal nBits As Long, ByVal nBitNum As Integer ) As Boolean
IsBitSet = GetBitNum( nBits, nBitNum ) > 0
End Function
' Return a particular bit from nBits.
' Bit 0 is the least significant bit.
Function GetBitNum( ByVal nBits As Long, ByVal nBitNum As Integer ) As Long
Do While nBitNum > 0
nBitNum = nBitNum - 1
nBits = Int( nBits / 2 ) ' shift right
Loop
GetBitNum = nBits Mod 2
End Function
' Set a particular bit in nBits.
' It does not matter what the previous status of the bit was,
' end ends up as a 1 bit.
' Bit 0 is the least significant bit.
Function SetBit( ByVal nBits As Long, ByVal nBitNum As Integer ) As Long
nBit = 1
Do While nBitNum > 0
nBitNum = nBitNum - 1
nBit = nBit * 2 ' shift left
Loop
SetBit = nBits Or nBit
End Function
' Clear a particular bit in nBits.
' It does not matter what the previous status of the bit was,
' end ends up as a 0 bit.
' Bit 0 is the least significant bit.
Function ClearBit( ByVal nBits As Long, ByVal nBitNum As Integer ) As Long
Dim nBit As Long
nBit = 1
Do While nBitNum > 0
nBitNum = nBitNum - 1
nBit = nBit * 2 ' shift left
Loop
ClearBit = nBits And (Not nBit)
End Function
'############################################################
' Base64 encode and decode.
' See RFC 1521.
'############################################################
Const BASE64_ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
'----------
' This function is the opposite of Base64Decode().
' Pass in a string of raw binary bytes.
' Out comes a printable string of characters from
' the base64 alphabet.
' The output string is always a multiple of 4 bytes.
' trailing equal signs are added to ensure this.
' This does not break the output into lines of 76 characters.
' See RFC 1521 for details of base64 encoding.
'
Function Base64Encode( cBytes )
cOutput = ""
nLen = Len( cBytes )
i = 1
' do while there's 3 or more characters to process
Do While nLen - i >= 2
cThreeChars = Mid( cBytes, i, 3 )
cOutput = cOutput + Base64Encode3to4( cThreeChars )
i = i + 3
Loop
If i <= nLen Then
cThreeChars = PadR( Mid( cBytes, i ), 3, Chr(0) )
cEncoded = Base64Encode3to4( cThreeChars )
cOutput = cOutput + PadR( Left( cEncoded, 2 + (nLen - i) ), 4, "=" )
EndIf
Base64Encode() = cOutput
End Function
' Convert 3 bytes into 4 printable base64 encoded chars.
' This uses a 64 character alphabet to represents the 6-bits
' pre printable character.
Function Base64Encode3to4( cThreeChars )
nInByte1 = Asc( Mid( cThreeChars, 1, 1 ) )
nInByte2 = Asc( Mid( cThreeChars, 2, 1 ) )
nInByte3 = Asc( Mid( cThreeChars, 3, 1 ) )
nOutByte1 = Int( nInByte1 / 4 )
nOutByte2 = (nInByte1 Mod 4) * 16 + Int( nInByte2 / 16 )
nOutByte3 = (nInByte2 Mod 16) * 4 + Int( nInByte3 / 64 )
nOutByte4 = nInByte3 Mod 64
cOutChar1 = Mid( BASE64_ALPHABET, nOutByte1 + 1, 1 )
cOutChar2 = Mid( BASE64_ALPHABET, nOutByte2 + 1, 1 )
cOutChar3 = Mid( BASE64_ALPHABET, nOutByte3 + 1, 1 )
cOutChar4 = Mid( BASE64_ALPHABET, nOutByte4 + 1, 1 )
cOut4Chars = cOutChar1 & cOutChar2 & cOutChar3 & cOutChar4
Base64Encode3to4() = cOut4Chars
End Function
'----------
' This function is the opposite of Base64Encode().
' Pass in a string of printable characters from
' the base64 alphabet.
' Input should be multiple of 4 characters in length.
' Out comes a string of raw binary bytes.
' This does not handle whitespace in the input.
' See RFC 1521 for details of base64 encoding.
'
Function Base64Decode( cBase64Text )
cOutput = ""
nLen = Len( cBase64Text )
i = 1
' do while there's 4 or more characters to process
Do While nLen - i >= 3
cFourChars = Mid( cBase64Text, i, 4 )
' An equal sign means fewer than 3 output bytes,
' we're at the end of the input stream.
If Right( cFourChars, 1 ) = "=" Then
If Right( cFourChars, 2 ) = "==" Then
' Only 1 output byte instead of 3.
cFourChars = Left( cFourChars, 2 ) + "AA"
cOutput = cOutput + Left( Base64Decode4to3( cFourChars ), 1 )
Else
' Only 2 output bytes instead of 3.
cFourChars = Left( cFourChars, 3 ) + "A"
cOutput = cOutput + Left( Base64Decode4to3( cFourChars ), 2 )
EndIf
Exit Do
EndIf
' Convet 4 chars to 3 binary bytes.
cOutput = cOutput + Base64Decode4to3( cFourChars )
i = i + 4
Loop
Base64Decode() = cOutput
End Function
' Convert 4 base64 encoded printable characters into 3 binary bytes.
Function Base64Decode4to3( cFourChars )
nInChar1 = Instr( 1, BASE64_ALPHABET, Mid( cFourChars, 1, 1 ), 0 ) - 1
nInChar2 = Instr( 1, BASE64_ALPHABET, Mid( cFourChars, 2, 1 ), 0 ) - 1
nInChar3 = Instr( 1, BASE64_ALPHABET, Mid( cFourChars, 3, 1 ), 0 ) - 1
nInChar4 = Instr( 1, BASE64_ALPHABET, Mid( cFourChars, 4, 1 ), 0 ) - 1
nOutByte1 = nInChar1 * 4 + Int( nInChar2 / 16 )
nOutByte2 = (nInChar2 Mod 16) * 16 + Int( nInChar3 / 4 )
nOutByte3 = (nInChar3 Mod 4) * 64 + nInChar4
cThreeBytes = Chr( nOutByte1 ) + Chr( nOutByte2 ) + Chr( nOutByte3 )
Base64Decode4to3() = cThreeBytes
End Function
'Sub TestBase64()
' x = "This is a test."
' y = Base64Encode( x )
' z = Base64Decode( y )
' Print x; Chr(13); y; Chr(13); z; Chr(13); (x = z)
'End Sub
'############################################################
' Convert value to string.
'############################################################
'-----
' Danny's improved version of CSTR().
' For instance, if you pass in a string, you get back
' the original string.
' If you pass in a number, then this function is if you had
' called CSTR().
' For all scalar values, this function is if you had called CSTR().
'
Function CStr2( ByVal uValue ) As String
nVarType = VarType( uValue )
If nVarType = 8 Then
' String
cValueStr = uValue
ElseIf nVarType = 3 Then
' Long
cValueStr = CSTR( uValue )
ElseIf nVarType = 2 Then
' Integer
cValueStr = CSTR( uValue )
ElseIf nVarType = 11 Then
' Boolean
cValueStr = CSTR( uValue )
ElseIf nVarType = 4 Then
' Single
cValueStr = CSTR( uValue )
ElseIf nVarType = 7 Then
' Date
cValueStr = CSTR( uValue )
ElseIf nVarType = 9 Then
' Object
cValueStr = "< object >"
ElseIf nVarType = 1 Then
' Null
cValueStr = "< null >"
ElseIf nVarType = 0 Then
' Empty
cValueStr = "< empty >"
Else
cValueStr = "???-vartype-" & CSTR( nVarType ) & "-???"
EndIf
CStr2 = cValueStr
End Function
'-----
' Given any arbitrary value, return a string which is the
' closest Basic syntax to recreate the value.
' For instance, if you pass in a string, you get back
' a string that has your original string enclosed in double quotes,
' that is, the returned string is two characters longer.
' If you pass in a number, then this function is if you had
' called CSTR().
' For all scalar values, this function is if you had called CSTR().
'
Function BasicSyntaxOfValue( ByVal uValue ) As String
nVarType = VarType( uValue )
' Is the value a string?
If nVarType = 8 Then
' String
' Enclose in quotes, process unprintable
' characters into Chr() functions.
cValueStr = BasicSyntaxOfString( uValue )
ElseIf nVarType = 3 Then
' Long
cValueStr = CSTR( uValue )
ElseIf nVarType = 2 Then
' Integer
cValueStr = CSTR( uValue )
ElseIf nVarType = 11 Then
' Boolean
cValueStr = CSTR( uValue )
ElseIf nVarType = 4 Then
' Single
cValueStr = CSTR( uValue )
ElseIf nVarType = 7 Then
' Date
cValueStr = CSTR( uValue )
' *** This is probably NOT the correct way to create
' *** the syntax for a date value!
Else
cValueStr = "???-vartype-" & CSTR( nVarType ) & "-???"
EndIf
BasicSyntaxOfValue() = cValueStr
End Function
'-----
' Pass in a string, this returns a string which is the necessary'
' Basic syntax to recreate the string.
' For most strings, the returned string is simply your original string
' enclosed in double quotes. That is, the returned string has two
' more characters than you passed in.
' If your original string contains unprintable characters, this will
' return the correct Basic syntax, including Chr() functions, that
' will recreate your string.
'
Function BasicSyntaxOfString( ByVal cString As String ) As String
bInQuotes = False
cDoubleQuote = Chr(34)
cResult = ""
nLen = Len( cString )
For i = 1 To nLen
cChar = Mid( cString, i, 1 )
nChar = Asc( cChar )
If nChar < 32 Or nChar > 127 Then
' This character is unprintable.
' If we were in a quoted string...
If bInQuotes Then
' ...close the quotes.
cResult = cResult & cDoubleQuote
bInQuotes = False
EndIf
' If this is not the first char, then we are concatenating.
If i > 1 Then
cResult = cResult & "&"
EndIf
cResult = cResult & "Chr(" & CSTR( nChar ) & ")"
Else
' This character is printable.
' If we are NOT in a quoted string...
If Not bInQuotes Then
' If this is not the first char, then we are concatenating.
If i > 1 Then
cResult = cResult & "&"
EndIf
' ...open quotes.
cResult = cResult & cDoubleQuote
bInQuotes = True
EndIf
cResult = cResult & cChar
EndIf
Next
If bInQuotes Then
cResult = cResult & cDoubleQuote
EndIf
BasicSyntaxOfString() = cResult
End Function
'############################################################
' Working with Arrays
'############################################################
'--------------------
' Return the number of elements in a single dimensional array.
' Typically this array was created by calling Array().
Function Array1_Size( aArray ) As Long
On Error GoTo ErrorHandler
nNumElements = UBound( aArray ) + 1
Array1_Size() = nNumElements
Exit Function
ErrorHandler:
Array1_Size() = 0
End Function
'--------------------
' Append a new element onto the end of a single dimensional array.
' Typically this array was created by calling Array().
' Example:
' aArray = Array()
' Array1_AppendElement( aArray, "Red" )
' Array1_AppendElement( aArray, "Orange" )
' Array1_AppendElement( aArray, "Yellow" )
' is the same as writing...
' aArray = Array( "Red", "Orange", "Yellow" )
' is the same as writing...
' Dim aArray( 2 )
' aArray( 0 ) = "Red"
' aArray( 1 ) = "Orange"
' aArray( 2 ) = "Yellow"
' except in the last example, aArray is statically known by the
' compiler to be an array, so you must always use parenthesis
' when passing the array to a function.
'
Sub Array1_AppendElement( aArray, uNewElement )
nNumElements = Array1_Size( aArray )
If nNumElements = 0 Then
aArray = Array( uNewElement )
Else
Redim Preserve aArray( nNumElements )
aArray( nNumElements ) = uNewElement
EndIf
End Sub
'--------------------
' IsInArray() function based upon idea from Iannz in this thread...
' http://www.oooforum.org/forum/viewtopic.php?p=29096#29096
' You can use IsInArray() as follows....
'
' If IsInArray( 23, Array(1,12,14,23,45,87) ) Then ...
' If IsInArray( cName, Array("Joe","John","Frank") ) Then ...
'
Function IsInArray( uValue, aArrayOfValues ) As Boolean
IsInArray = (ArrayIndexOf( uValue, aArrayOfValues ) >= 0)
End Function
'
' Similar to IsInArray(), but returns the array index,
' or -1 if not found.
'
Function ArrayIndexOf( uValue, aArrayOfValues ) As Long
ArrayIndexOf = -1
For i = LBound( aArrayOfValues ) To UBound( aArrayOfValues )
If uValue = aArrayOfValues( i ) Then
ArrayIndexOf = i
Exit Function
EndIf
Next
End Function
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:33 pm; edited 3 times in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:34 pm Post subject: |
|
|
UtilColor module
This code was previously published in a more primitive form in this thread....
Color conversions: HSB to RGB and back again
http://www.oooforum.org/forum/viewtopic.phtml?t=4945
You might want to read that article. It is an explanation of the theory behidn these colorspace conversion functions.
| Code: | '**********************************************************************
' UtilColor module
'
' Routines to make it easy to work with colors.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-01-30-01
'
'**********************************************************************
Sub Main()
' Test program for this module.
ColorUtilsTest()
End Sub
'----------
' Pass in a hex string representing colors, and this returns the color value,
' sort of like calling the built in RGB() function.
' Convert a hex string of colors, such as E0E0FF, to a long integer.
' Examples of how to call...
'
' Print HexRGB( "FFFFFF" ), "Expected: "; RGB( 255, 255, 255 )
' Print HexRGB( "E0E0FF" ), "Expected: "; RGB( 224, 224, 255 )
'
' To do the opposite, turn a color number into a string of hex digits,
' use the IntValueToHexDigits() function located in another module...
'
' Print IntValueToHexDigits( RGB( 224, 224, 255 ), 6 )
' would print: E0E0FF
'
'----------
' See simpler implementation of function below.
'----------
'Function HexRGB( cHexString )
' ' Adjust these three lines to taste -- depending on which
' ' hex digits make up each part of the color.
' cRedHex = Mid( cHexString, 1, 2 ) ' chars 1-2 are the RED hex digits
' cGrnHex = Mid( cHexString, 3, 2 ) ' chars 3-4 are the GREEN hex digits
' cBluHex = Mid( cHexString, 5, 2 ) ' chars 5-6 are the BLUE hex digits
'
' nRedValue = HexDigitsToIntValue( cRedHex )
' nGrnValue = HexDigitsToIntValue( cGrnHex )
' nBluValue = HexDigitsToIntValue( cBluHex )
'
' nColor = RGB( nRedValue, nGrnValue, nBluValue )
' HexRGB() = nColor
'End Function
'
' If your hex digits are strung together with the first pair being red,
' the second pair green, and the third pair blue, as in the function
' HexRGB() above, then this function is equivalent to HexRGB().
Function HexRGB( cHexString )
HexRGB() = HexDigitsToIntValue( cHexString )
End Function
'----------------------------------------
' Some background information about Color
'
' Draw objects can have their fill color or outline color adjusted to any color.
' A color is just a long integer value.
' Typically, you create a color value by calling the built in RGB() function.
' RGB is a notation that means Red, Green, Blue. You specify a red value, a
' green value, and a blue value, all as a number from 0 to 255.
' These three numbers represent the amount of red light, green light, and blue
' light to combine to light up a pixel in that particular color. (Or the amount
' of red,green and blue energy of the three electron guns in a CRT.)
' Problem: RGB is not a notation that is easy for humans to work in.
' RGB is great for computers, since it maps directly to the underlying hardware.
' But RGB is not a good way for humans to *think* about color.
' Quick! Right off the top of your head, what is the RGB value for light
' brown? Hot pink? Pastel pink?
' Solution: Use HSB notation for colors instead.
' HSB is great for humans, since it maps easily into how we can think about colors.
' But HSB is not an efficient way for computers to work with color, since conversion
' routines must be used.
' This module contains the various conversion functions to make it as easy to program
' with HSB notation as it is to work with RGB notation.
' StarBasic provides the following built in functions for working with RGB notation:
' RGB( r, g, b ) -> returns a color from the r,g,b values.
' Red( color ) -> returns the red component from rgb value
' Green( color ) -> returns the green component from rgb value
' Blue( color ) -> returns the blue component from rgb value
' This module provides the following very similar routines for working with HSB notation:
' HSB( hue, saturation, brightness ) -> returns a color from h,s,b values.
' Hue( color ) -> returns the hue component from a color (where color is just an integer)
' Saturation( color ) -> returns the saturation component from a color.
' Brightness( color ) -> returns the brightness component from a color.
' In the above functions, when a "color" is a parameter, this is simply a large integer number
' that could have been returned by EITHER the RGB() or HSB() function.
'
' Understand that HSB and RGB are just two different notations for describing the same
' color. Just as polar and rectangular coordinates are two notations for describing
' a coordinate in two dimensional space. Or as inches and centimeters are two different
' ways of measuring the same distance.
'
' Calling HSB( 0.0, 1.0, 1.0 ) will return the same integer, which means the same color,
' as calling RGB( 255, 0, 0 ). That is, pure red. Once you have the Long integer that
' represents a color, it doesn't really matte whether that number was hardcoded into
' your program, or whether you got that number by calling either RGB() or HSB().
'
' How HSB notation works
' ----------------------
'
' The way you think about HSB notation is that H stands for Hue, S for Saturation, an B
' for Brightness.
' The Hue is a number from 0.0 to 1.0. Think of a rainbow of color. At the left end,
' it starts out bright red, a hue of 0.0. As you move along the rainbow towards the
' right end, the hue gradually increases towards 1.0, as the hue changes appearance to
' orange, yellow, green, cyan, blue, magenta, and then finally back to pure red again
' as the hue becomes 1.0.
' This hue rainbow is not quite like a true rainbow of course, because it is pure red
' at both ends (hue of 0.0 is red, and hue of 1.0 is red).
' Since both ends of the hue rainbow are red, you can stack the rainbow infinitely end to end
' so that a hue of 1.3333 is exactly the same color as a hue of 0.3333. Or a hue of -0.75
' is the same as a hue of 0.25.
' The saturation is also a number from 0.0 to 1.0. A saturation of 1.0 means the color is
' fully saturated. A saturation of 0.0 means the color has no saturation at all, and is
' therefore, pure white (actually grayscale as you'll see in a minute). When the saturation
' is zero, the hue is irrelevant, because no matter what hue you have, the color is completely
' de-saturated of any hue.
' You can now see that a color like Pink would be a low-saturation Red. So you might have a
' hue of 0.0 (or 1.0) and a saturation of, say 0.6. This is easy and straightforward.
' Suppose you need a very light color pastel green. Use a hue of 0.3333 and a saturation, of
' say about 0.5.
' Similarly, sky blue would be a medium saturation blue.
' As the saturation gets closer to 0.0, the color is closer to white, with only a hint of
' the hue remaining.
' The Brightness is also a number from 0.0 (completely black) to 1.0 (completely lit up).
' So far, the discussion of Hue and Saturation has been assuming a brightness of 1.0.
' But as you lower the brightness from 1.0 to 0.0, the color gets darker and darker (less
' and less light behind it) until at 0.0, the light behind the color has turned off.
' When brightness is 0.0, niether the hue nor saturation matter, because no light is emitted,
' and so the color is pure black.
' A color like brown would be a low-brightness orange.
'
'----------------------------------------
'----------
' This function is similar to the built in RGB() function, in that
' you pass it parameters and it returns a color.
' As with the RGB() function, the color returned by this function is
' just a Long integer, so you can do anything with it that you could have
' done with a color that you get from the RGB() function.
'
Function HSB( nHue As Double, nSaturation As Double, nBrightness As Double ) As Long
nRed = 0
nGreen = 0
nBlue = 0
' Convert from HSB notation into RGB notation
__HSBtoRGB( nHue, nSaturation, nBrightness, nRed, nGreen, nBlue )
' Turn the RGB values into a single number
nRGB = RGB( nRed, nGreen, nBlue )
HSB() = nRGB
End Function
'----------
' Extract the Hue component from a color.
' The color parameter is a Long integer that represents a color value.
' The color value could have come from either the RGB() or HSB() function.
'
Function Hue( nColor As Long ) As Double
' Isolate the RGB color components
nRed = Red( nColor )
nGreen = Green( nColor )
nBlue = Blue( nColor )
' Create variables that receive the results.
nHue = 0
nSaturation = 0
nBrightness = 0
' Convert from RGB notation into HSB notation
__RGBtoHSB( nRed, nGreen, nBlue, nHue, nSaturation, nBrightness )
' Return result
Hue() = nHue
End Function
'----------
' Extract the Saturation component from a color.
' The color parameter is a Long integer that represents a color value.
' The color value could have come from either the RGB() or HSB() function.
'
Function Saturation( nColor As Long ) As Double
' Isolate the RGB color components
nRed = Red( nColor )
nGreen = Green( nColor )
nBlue = Blue( nColor )
' Create variables that receive the results.
nHue = 0
nSaturation = 0
nBrightness = 0
' Convert from RGB notation into HSB notation
__RGBtoHSB( nRed, nGreen, nBlue, nHue, nSaturation, nBrightness )
' Return result
Saturation() = nSaturation
End Function
'----------
' Extract the Brightness component from a color.
' The color parameter is a Long integer that represents a color value.
' The color value could have come from either the RGB() or HSB() function.
'
Function Brightness( nColor As Long ) As Double
' Isolate the RGB color components
nRed = Red( nColor )
nGreen = Green( nColor )
nBlue = Blue( nColor )
' Create variables that receive the results.
nHue = 0
nSaturation = 0
nBrightness = 0
' Convert from RGB notation into HSB notation
__RGBtoHSB( nRed, nGreen, nBlue, nHue, nSaturation, nBrightness )
' Return result
Brightness() = nBrightness
End Function
'----------
' This is the low level routine to convert from RGB into HSB notation.
' Pass in red, green and blue.
' This returns back hue, saturation, and brightness.
'
Sub __RGBtoHSB( nRed As Integer, nGreen As Integer, nBlue As Integer,_
nHue As Double, nSaturation As Double, nBrightness As Double )
nMin = Min3( nRed, nGreen, nBlue )
nMax = Max3( nRed, nGreen, nBlue )
If nMin = nMax Then
' Grayscale
nHue = 0.0
nSaturation = 0.0
nBrightness = nMax
Else
If nRed = nMin Then
d = nGreen - nBlue
h = 3.0
ElseIf nGreen = nMin Then
d = nBlue - nRed
h = 5.0
Else
d = nRed - nGreen
h = 1.0
EndIf
nHue = ( h - ( d / (nMax - nMin) ) ) / 6.0
nSaturation = (nMax - nMin) / nMax
nBrightness = nMax / 255.0
EndIf
End Sub
'----------
' This is the low level routine to convert from HSB notation into RGB notation.
' Pass in hue, saturation and brightness.
' This returns back the red, green and blue.
'
Sub __HSBtoRGB( nHue As Double, nSaturation As Double, nBrightness As Double,_
nRed As Integer, nGreen As Integer, nBlue As Integer )
' Scale the brightness from a range of 0.0 thru 1.0
' to a range of 0.0 thru 255.0
' Then truncate to integer.
' Store it into a local variable, so we don't affect
' the value back in the caller.
nBrightness2 = Int( Min2( nBrightness * 256.0, 255.0 ) )
If nSaturation = 0.0 Then
' Grayscale because there is no saturation
nRed = nBrightness2
nGreen = nBrightness2
nBlue = nBrightness2
Else
' Make hue angle be within a single rotation.
' If the hue is > 1.0 or < 0.0, then it has
' "gone around the color wheel" too many times.
' For example, a value of 1.2 means that it has
' gone around the wheel 1.2 times, which is really
' the same ending angle as 0.2 trips around the wheel.
' Scale it back into the 0.0 to 1.0 range.
nHue2 = nHue
If nHue2 > 1.0 Then
nHue2 = nHue2 - Int( nHue2 )
ElseIf nHue2 < 0.0 Then
nHue2 = Abs( nHue2 )
If nHue2 > 1.0 Then
nHue2 = nHue2 - Int( nHue2 )
EndIf
nHue2 = 1.0 - nHue2
EndIf
' Rescale hue to a range of 0.0 to 6.0.
nHue2 = nHue2 * 6.0
' Separate hue into int and fractional parts
iHue = Int( nHue2 )
fHue = nHue2 - iHue
' If Hue is even
If iHue Mod 2 = 0 Then
fHue = 1.0 - fHue
EndIf
m = nBrightness2 * (1.0 - nSaturation)
n = nBrightness2 * (1.0 - (nSaturation * fHue))
Select Case iHue
Case 1
nRed = n
nGreen = nBrightness2
nBlue = m
Case 2
nRed = m
nGreen = nBrightness2
nBlue = n
Case 3
nRed = m
nGreen = n
nBlue = nBrightness2
Case 4
nRed = n
nGreen = m
nBlue = nBrightness2
Case 5
nRed = nBrightness2
nGreen = m
nBlue = n
Case Else
nRed = nBrightness2
nGreen = n
nBlue = m
End Select
EndIf
End Sub
'------------------------------------------------------------
' Test program for ColorUtils.
'------------------------------------------------------------
Sub ColorUtilsTest()
' Make sure DannysOOoLib library of modules are loaded.
' You only need this line if your module is NOT
' a module in the DannysOOoLib library.
' This line is actually not needed here, since this
' module is part of the DannysOOoLib library.
' You would, of course, need this line in your own code.
BasicLibraries.LoadLibrary( "DannysOOoLib" )
' Create a new Draw document
oDrawDoc = StarDesktop.loadComponentFromURL( "private:factory/sdraw", "_blank", 0, Array() )
' Get the first page
oPage = oDrawDoc.drawPages( 0 )
' The size and spacing between each individual block in a group.
Const nBlockWidth = 700
Const nBlockHeight = 700
Const nBlockHMargin = 80
Const nBlockVMargin = 80
' Make size object for the size of each block.
oSize = MakeSize( nBlockWidth, nBlockHeight )
' Number blocks across and down
Const nNumBlocksAcross = 10
Const nNumBlocksDown = 10
'----------------------------------------
' Draw a group of blocks.
' The saturation increases from 0.0 to 1.0 as the blocks go down.
' The hue changes from 0.0 to 1.0 as the blocks go across.
' The brightness remains constant on all blocks -- full brightness.
'
' Since hue 0.0 and 1.0 are both red, the leftmost and rightmost
' blocks will be red.
' Since the first (top) row has saturation zero, the entire top
' row of blocks will be white.
' Location of the *group* of color blocks
nBlockFirstX = 1000
nBlockFirstY = 1000
nBrightness = 1.0
For row = 0 To nNumBlocksDown-1
nSaturation = row / (nNumBlocksDown-1)
For col = 0 To nNumBlocksAcross-1
nHue = col / (nNumBlocksAcross-1)
' Calculate Position of next rectangle to create
nX = nBlockFirstX + (col * (nBlockWidth + nBlockHMargin))
nY = nBlockFirstY + (row * (nBlockHeight + nBlockVMargin))
' Create next rectangle shape, set its color.
oShape = MakeRectangleShape( oDrawDoc, MakePoint( nX, nY ), oSize )
oShape.FillColor = HSB( nHue, nSaturation, nBrightness )
oPage.add( oShape )
Next
Next
'
'----------------------------------------
'----------------------------------------
' Draw a group of blocks.
' The brightness increases from 0.0 to 1.0 as the blocks go down.
' The hue changes from 0.0 to 1.0 as the blocks go across.
' The saturation remains constant on all blocks -- fully saturated colors.
'
' Since hue 0.0 and 1.0 are both red, the leftmost and rightmost
' blocks will be red.
' Since the first (top) row has brightness zero, the entire top
' row of blocks will be black.
' Location of the *group* of color blocks
nBlockFirstX = 10000
nBlockFirstY = 1000
nSaturation = 1.0
For row = 0 To nNumBlocksDown-1
nBrightness = row / (nNumBlocksDown-1)
For col = 0 To nNumBlocksAcross-1
nHue = col / (nNumBlocksAcross-1)
' Calculate Position of next rectangle to create
nX = nBlockFirstX + (col * (nBlockWidth + nBlockHMargin))
nY = nBlockFirstY + (row * (nBlockHeight + nBlockVMargin))
' Create next rectangle shape, set its color.
oShape = MakeRectangleShape( oDrawDoc, MakePoint( nX, nY ), oSize )
oShape.FillColor = HSB( nHue, nSaturation, nBrightness )
oPage.add( oShape )
Next
Next
'
'----------------------------------------
'----------------------------------------
' Draw a group of blocks.
' The brightness increases from 0.0 to 1.0 as the blocks go down.
' The saturation increases from 0.0 to 1.0 as the blocks go across.
' The hue remains constant on all blocks -- yellow color.
' Location of the *group* of color blocks
nBlockFirstX = 1000
nBlockFirstY = 10000
nHue = 0.166666666 ' Yellow
For row = 0 To nNumBlocksDown-1
nBrightness = row / (nNumBlocksDown-1)
For col = 0 To nNumBlocksAcross-1
nSaturation = col / (nNumBlocksAcross-1)
' Calculate Position of next rectangle to create
nX = nBlockFirstX + (col * (nBlockWidth + nBlockHMargin))
nY = nBlockFirstY + (row * (nBlockHeight + nBlockVMargin))
' Create next rectangle shape, set its color.
oShape = MakeRectangleShape( oDrawDoc, MakePoint( nX, nY ), oSize )
oShape.FillColor = HSB( nHue, nSaturation, nBrightness )
oPage.add( oShape )
Next
Next
'
'----------------------------------------
'----------------------------------------
' Draw a group of blocks.
' The hue changes from 0.0 to 1.0 as the blocks go down.
' The brightness increases from 0.0 to 1.0 as the blocks go across.
' The saturation remains constant on all blocks -- low saturation, i.e. "pastels".
'
' Since hue 0.0 and 1.0 are both red, the topmost and bottommost
' blocks will be red.
' The brightness varies from 0.4 to 1.0.
' Location of the *group* of color blocks
nBlockFirstX = 10000
nBlockFirstY = 10000
nSaturation = 0.4
For row = 0 To nNumBlocksDown-1
nHue = row / (nNumBlocksAcross-1)
For col = 0 To nNumBlocksAcross-1
nBrightness = (col / (nNumBlocksDown-1)) * 0.6 + 0.4 ' vary brightness from 0.4 to 1.0
' Calculate Position of next rectangle to create
nX = nBlockFirstX + (col * (nBlockWidth + nBlockHMargin))
nY = nBlockFirstY + (row * (nBlockHeight + nBlockVMargin))
' Create next rectangle shape, set its color.
oShape = MakeRectangleShape( oDrawDoc, MakePoint( nX, nY ), oSize )
oShape.FillColor = HSB( nHue, nSaturation, nBrightness )
oPage.add( oShape )
Next
Next
'
'----------------------------------------
End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:40 pm; edited 2 times in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:34 pm Post subject: |
|
|
| Code: | '**********************************************************************
' UtilConfig module
'
' Routines to make it easy to work with OOo Configuration Manager.
'
'**********************************************************************
' Copyright (c) 2003 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2003-12-17-01
'
'**********************************************************************
Function GetConfigAccess( ByVal cNodePath As String,_
ByVal bWriteAccess As Boolean,_
Optional bEnableSync,_
Optional bLazyWrite ) As Object
If IsMissing( bEnableSync ) Then
bEnableSync = True
EndIf
If IsMissing( bLazyWrite ) Then
bLazyWrite = False
EndIf
' If bWriteAccess And bEnableSync Then
oConfigProvider = GetProcessServiceManager().createInstanceWithArguments(_
"com.sun.star.configuration.ConfigurationProvider",_
Array( MakePropertyValue( "enableasync", bEnableSync ) ) )
' Else
' oConfigProvider = createUnoService( "com.sun.star.configuration.ConfigurationProvider" )
' EndIf
If bWriteAccess Then
cServiceName = "com.sun.star.configuration.ConfigurationUpdateAccess"
Else
cServiceName = "com.sun.star.configuration.ConfigurationAccess"
EndIf
oConfigAccess = oConfigProvider.createInstanceWithArguments( cServiceName,_
Array( MakePropertyValue( "nodepath", cNodePath ),_
MakePropertyValue( "lazywrite", bLazyWrite ) ) )
GetConfigAccess() = oConfigAccess
End Function
Function MakeMenuItem( oParentContainer, cTitle, cConfigName, Optional cURL )
oMenuItem = oParentContainer.createInstance
oMenuItem.Title = cTitle
If Not IsMissing( cURL ) Then
oMenuItem.URL = cURL
EndIf
oParentContainer.insertByName( cConfigName, oMenuItem )
MakeMenuItem() = oMenuItem
End Function
|
_________________
Want to make OOo Drawings like the colored flower design to the left? |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:34 pm Post subject: |
|
|
| Code: | '**********************************************************************
' UtilFile module
'
' File and pathname manipulation routines.
'
'**********************************************************************
' Copyright (c) 2003 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2003-12-17-01
'
'**********************************************************************
Sub Main
' TestFileFolderFunctions_Linux()
' TestFileFolderFunctions_Windows()
End Sub
'############################################################
' Tests to see if a file or folder exists.
'############################################################
'----------
' This function checks whether a pathname is a valid
' pathname of a folder, and not of a file.
' Pass in a native os pathname, not a URL.
Function IsFolder( cPathname )
IsFolder() = False
If Len( cPathname ) = 0 Then
Exit Function
EndIf
oSimpleFileAccess = createUnoService( "com.sun.star.ucb.SimpleFileAccess" )
cURL = ConvertToURL( cPathname )
IsFolder() = oSimpleFileAccess.isFolder( cURL )
End Function
'----------
' This function checks whether a pathname is a valid
' pathname of a file, and not of a folder.
' Pass in a native os pathname, not a URL.
Function IsFile( cPathname )
IsFile() = False
cPathname = RemoveTrailingSlash( cPathname )
If Len( cPathname ) = 0 Then
Exit Function
EndIf
If Not FileExists( cPathname ) Then
Exit Function
EndIf
If IsFolder( cPathname ) Then
Exit Function
EndIf
IsFile() = True
End Function
''----------
'' This function checks whether a pathname is a valid
'' pathname of a folder, and not of a file.
'' Pass in a native os pathname, not a URL.
'Function IsFolder( cPathname )
' IsFolder() = False
'
' If Len( cPathname ) = 0 Then
' Exit Function
' EndIf
'
' cPathname = RemoveTrailingSlash( cPathname )
'
' If Not FileExists( cPathname ) Then
' Exit Function
' EndIf
'
' nAttr = GetAttr( cPathname )
' nBit4 = Int(nAttr / 16) Mod 2
' If nBit4 = 0 Then
' Exit Function
' EndIf
'
' IsFolder() = True
'End Function
''----------
'' This function checks whether a pathname is a valid
'' pathname of a file, and not of a folder.
'' Pass in a native os pathname, not a URL.
'Function IsFile( cPathname )
' IsFile() = False
'
' cPathname = RemoveTrailingSlash( cPathname )
'
' If Len( cPathname ) = 0 Then
' Exit Function
' EndIf
'
' If Not FileExists( cPathname ) Then
' Exit Function
' EndIf
'
' nAttr = GetAttr( cPathname )
' nBit4 = Int(nAttr / 16) Mod 2
' If nBit4 = 1 Then
' Exit Function
' EndIf
'
' IsFile() = True
'End Function
'Sub TestFileFolderFunctions_Linux()
' ' Test some known cases on Danny's Linux system
' ' to see if the IsFolder and IsFile functions work.
'
'' MsgBox( "f1: " + GetAttr( "/home/danny/Desktop/f1" ) )
'' MsgBox( "f2: " + GetAttr( "/home/danny/Desktop/f2" ) )
'' MsgBox( "Test File: " + GetAttr( "/home/danny/Desktop/f2/Test File" ) )
'
' If Not IsFolder( "/home/danny/Desktop/f1" ) Then
' MsgBox( "f1 not detected as folder." )
' Exit Sub
' EndIf
'
' If IsFile( "/home/danny/Desktop/f1" ) Then
' MsgBox( "f1 detected as file." )
' Exit Sub
' EndIf
'
' If Not IsFolder( "/home/danny/Desktop/f2" ) Then
' MsgBox( "f2 not detected as folder." )
' Exit Sub
' EndIf
'
' If IsFile( "/home/danny/Desktop/f2" ) Then
' MsgBox( "f2 detected as file." )
' Exit Sub
' EndIf
'
' If IsFolder( "/home/danny/Desktop/f2/Test File" ) Then
' MsgBox( "f2/Test File detected as folder." )
' Exit Sub
' EndIf
'
' If Not IsFile( "/home/danny/Desktop/f2/Test File" ) Then
' MsgBox( "f2/Test File not detected as file." )
' Exit Sub
' EndIf
'End Sub
'Sub TestFileFolderFunctions_Windows()
' ' Test some known cases on Danny's Windows system
' ' to see if the IsFolder and IsFile functions work.
'
'' MsgBox( "f1: " + GetAttr( "C:\Documents and Settings\dbrewer\Desktop\shortcuts" ) )
'' MsgBox( "f2: " + GetAttr( "C:\Documents and Settings\dbrewer\Desktop\emptyfolder" ) )
'' MsgBox( "Test File: " + GetAttr( "C:\Documents and Settings\dbrewer\Desktop\FA tables.html" ) )
'
' If Not IsFolder( "C:\Documents and Settings\dbrewer\Desktop\shortcuts" ) Then
' MsgBox( "shortcuts not detected as folder." )
' Exit Sub
' EndIf
'
' If IsFile( "C:\Documents and Settings\dbrewer\Desktop\shortcuts" ) Then
' MsgBox( "shortcuts detected as file." )
' Exit Sub
' EndIf
'
' If Not IsFolder( "C:\Documents and Settings\dbrewer\Desktop\emptyfolder" ) Then
' MsgBox( "emptyfolder not detected as folder." )
' Exit Sub
' EndIf
'
' If IsFile( "C:\Documents and Settings\dbrewer\Desktop\emptyfolder" ) Then
' MsgBox( "emptyfolder detected as file." )
' Exit Sub
' EndIf
'
' If IsFolder( "C:\Documents and Settings\dbrewer\Desktop\FA tables.html" ) Then
' MsgBox( "FA tables detected as folder." )
' Exit Sub
' EndIf
'
' If Not IsFile( "C:\Documents and Settings\dbrewer\Desktop\FA tables.html" ) Then
' MsgBox( "FA tables not detected as file." )
' Exit Sub
' EndIf
'End Sub
'############################################################
'----------
' Remove the trailing slash from a pathname.
'
Function RemoveTrailingSlash( cPathname )
cRight1 = Right( cPathname, 1 )
If cRight1 = "/" Or cRight1 = "\" Then
cPathname = Left( cPathname, Len( cPathname ) - 1 )
EndIf
RemoveTrailingSlash() = cPathname
End Function
'----------
' Ensure the trailing slash on a pathname.
'
Function EnsureTrailingSlash( cPathname )
cRight1 = Right( cPathname, 1 )
If (cRight1 <> "/") And (cRight1 <> "\") Then
cPathname = cPathname + "/"
EndIf
EnsureTrailingSlash() = cPathname
End Function
'############################################################
' Convenience routines for working with
' com.sun.star.io.XInputStream
' com.sun.star.io.XOutputStream
'############################################################
' Convert an array of bytes to a string.
' Pass in an array of bytes.
' Each "byte" in the array is an integer value from -128 to +127.
' The array of bytes could have come from reading
' from a com.sun.star.io.XInputStream.
' This function returns a string.
' This function is the opposite of StringToByteArray().
Function ByteArrayToString( aByteArray )
cBytes = ""
For i = LBound( aByteArray ) To UBound( aByteArray )
nByte = aByteArray(i)
nByte = ByteToInteger( nByte )
cBytes = cBytes + Chr( nByte )
Next i
ByteArrayToString() = cBytes
End Function
' Convert a string into an array of bytes.
' Pass a string value to the cString parameter.
' The function returns an array of bytes, suitable
' for writing to a com.sun.star.io.XOutputStream.
' Each "byte" in the array is an integer value from -128 to +127.
' This function is the opposite of ByteArrayToString().
Function StringToByteArray( ByVal cString As String )
nNumBytes = Len( cString )
Dim aBytes(nNumBytes-1) As Integer
For i = 1 To nNumBytes
cChar = Mid( cString, i, 1 )
nByte = Asc( cChar )
nByte = IntegerToByte( nByte )
aBytes(i-1) = nByte
Next
StringToByteArray() = aBytes()
End Function
' This is pure syntax sugar.
' Just a convenient way of writing a string value
' to a com.sun.star.io.XOutputStream.
Sub FileWriteString( oOutputStream As com.sun.star.io.XOutputStream,_
ByVal cString As String )
' Convert the string into an array of bytes.
aBytesToWrite = StringToByteArray( cString )
' Write the bytes to the output file.
oOutputStream.writeBytes( aBytesToWrite )
End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left? |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:35 pm Post subject: |
|
|
UtilForm module
This module was previously published in a more primitive form over in this thread....
Creating Forms on the fly
http://www.oooforum.org/forum/viewtopic.phtml?t=10265
| Code: | '**********************************************************************
' UtilForm module
'
' Utility functions for working with document Forms.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-08-16-02
'
'**********************************************************************
'----------
' Get the Forms collection from a certian page of a document.
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
' Once you have the collection of Forms, you can do the following things...
' from XNameContainer....
' oForms.insertByName( "FormName", oForm )
' oForms.removeByName( "FormName" )
' oForms.replaceByName( "FormName", oForm )
' aNames = oForms.getElementNames()
' oForm = oForms.getByName( "FormName )
' If oForms.hasByName( "FormName" ) Then...
' from XIndexAccess...
' oForms.insertByIndex( 0, oForm )
' oForms.removeByIndex( 0 )
' oForms.replaceByIndex( 0, oForm )
' nNumForms = oForms.getCount()
' oForm = oForms.getByIndex( 0 )
' from XEnumerationAccess...
' oEnumeration = oForms.createEnumeration()
' ...then use hasMoreElements() and nextElement()
'
' Examples....
' Create new form, and give it the name MyForm...
' oForm = createUnoService( "com.sun.star.form.component.Form" )
' oForms.insertByName( "MyForm", oForm )
' Get the form named MyForm
' oForm = oForms.getByName( "MyForm" )
'
Function FormGetForms( Optional nPage, Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oDrawPage = GetDrawPage( nPage, oDoc )
oForms = oDrawPage.getForms()
FormGetForms = oForms
End Function
'----------
' Get the DrawPage of a document.
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function GetDrawPage( Optional nPage, Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
oDocModel = oDoc
Else
oDocModel = GetDocumentModel( oDoc )
EndIf
' If the document is a spreadsheet...
If oDocModel.supportsService( "com.sun.star.sheet.SpreadsheetDocument" ) Then
oSheet = oDocModel.getSheets().getByIndex( nPage )
oDrawPage = oSheet.getDrawPage()
ElseIf oDocModel.supportsService( "com.sun.star.text.TextDocument" ) Then
' Ignore the nPage parameter for Writer documents.
oDrawPage = oDocModel.getDrawPage()
' If no draw page number specified, then assume
' there is only one draw page, via. an XDrawPageSupplier interface,
' instead of multiple pages via. an XDrawPagesSupplier interface.
ElseIf IsMissing( nPage ) Or (nPage = -1) Then
oDrawPage = oDocModel.getDrawPage()
Else
oDrawPage = oDocModel.getDrawPages().getByIndex( nPage )
EndIf
GetDrawPage = oDrawPage
End Function
'----------
' Create a new Form, or return the existing form of the same name.
' This returns the form.
' Parameters:
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormCreateForm( ByVal cFormName As String, Optional nPage, Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oForms = FormGetForms( nPage, oDoc )
If oForms.hasByName( cFormName ) Then
' Get existing form.
oForm = oForms.getByname( cFormName )
Else
' Create new form.
oForm = createUnoService( "com.sun.star.form.component.Form" )
oForms.insertByName( cFormName, oForm )
EndIf
FormCreateForm = oForm
End Function
'----------
' Create a Button control.
' This returns the control model. (Not the control.)
' Parameters:
' x, y, width, height - the control's location and size.
' cControlCaption - The name that is displayed to the user.
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormCreateControl_Button( _
ByVal x As Long, ByVal y As Long,_
ByVal width As Long, ByVal height As Long,_
ByVal cControlCaption As String,_
ByVal cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlShape = FormCreateControlShape( "com.sun.star.form.component.CommandButton",_
cControlName, cFormName, nPage, oDoc )
oControlModel = oControlShape.getControl()
oControlShape.Position = MakePoint( x, y )
oControlShape.Size = MakeSize( width, height )
oControlModel.Label = cControlCaption
FormCreateControl_Button = oControlModel
End Function
'----------
' Create a new control.
' This returns the control model. (Not the control.)
' Parameters:
' cControlServiceName
' - something like... "com.sun.star.form.component.CommandButton"
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormCreateControl( ByVal cControlServiceName As String,_
ByVal cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlShape = FormCreateControlShape( cControlServiceName,_
cControlName, cFormName, nPage, oDoc )
oControlModel = oControlShape.getControl()
FormCreateControl = oControlModel
End Function
'----------
' Create a new control -- return its shape.
' This is very similar to CreateControl(), but returns the control shape.
' This returns the control shape.
' Parameters:
' cControlServiceName
' - something like... "com.sun.star.form.component.CommandButton"
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormCreateControlShape( ByVal cControlServiceName As String,_
ByVal cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oDrawPage = GetDrawPage( nPage, oDoc )
oForms = oDrawPage.getForms()
If oForms.hasByName( cFormName ) Then
' Get existing form.
oForm = oForms.getByName( cFormName )
Else
' Create new form.
oForm = createUnoService( "com.sun.star.form.component.Form" )
oForms.insertByName( cFormName, oForm )
EndIf
' Create the control shape for the draw page.
oControlShape = MakeControlShape( oDoc, MakePoint( 1000, 2000 ), MakeSize( 4000, 1000 ) )
' Create the control model.
oControlModel = createUnoService( cControlServiceName )
' Introduce the control model to the control shape.
oControlShape.setControl( oControlModel )
' Note that both the control model and control shape are still disembodied.
' That is, they are not contained in any hierarchy.
' Now insert the control model into the form.
oForm.insertByName( cControlName, oControlModel )
' Insert the control shape into the draw page.
oDrawPage.add( oControlShape )
' Special behavior for Writer.
' Anchor the control to a paragraph. (Default is draw page.)
oDocModel = GetDocumentModel( oDoc )
If oDocModel.supportsService( "com.sun.star.text.TextDocument" ) Then
oControlShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PARAGRAPH
' oCtrlShape.AnchorType = com.sun.star.text.TextContentAnchorType.AT_PAGE
EndIf
FormCreateControlShape = oControlShape
End Function
'----------
' Get a control model from a form of a document.
' This returns the control model. (Not the control.)
' Parameters:
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormGetControlModel( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oForms = FormGetForms( nPage, oDoc )
oForm = oForms.getByName( cFormName )
oControlModel = oForm.getByName( cControlName )
FormGetControlModel = oControlModel
End Function
'----------
' Get a control from a form of a document.
' This returns the control. (Not the model.)
' Parameters:
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormGetControl( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
oDocCtrl = GetDocumentController( oDoc )
oControl = oDocCtrl.getControl( oControlModel )
FormGetControl = oControl
End Function
'----------
' Search the draw page for a particular control shape.
' This returns the control shape.
' Parameters:
' cControlName - The control's name.
' cFormName - The form's name. (Usually: "Standard")
' Optional Parameters:
' nPage - The page number of a document that has multiple
' draw pages, such as Draw, Impress or Calc.
' Passing -1 is the same as omitting this argument.
' oDoc - The document model. If not supplied, then ThisComponent is used.
' It is okay to pass one of the document's controllers or frame instead.
'
Function FormFindControlShape( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oDrawPage = GetDrawPage( nPage, oDoc )
oForms = oDrawPage.getForms()
oForm = oForms.getByName( cFormName )
nNumShapes = oDrawPage.getCount()
For i = 0 To nNumShapes - 1
oShape = oDrawPage.getByIndex( i )
If HasUnoInterfaces( oShape, "com.sun.star.drawing.XControlShape" ) Then
oControlModel = oShape.getControl()
If oControlModel.getName() = cControlName Then
FormFindControlShape = oShape
Exit Function
EndIf
EndIf
Next
End Function
Function FormGetControlValue( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Double
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
nValue = oControlModel.Value
FormGetControlValue = nValue
End Function
Sub FormSetControlValue( cControlName As String,_
ByVal nValue As Double,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc )
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
oControlModel.Value = nValue
End Sub
Function FormGetControlText( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As String
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
cText = oControlModel.Text
FormGetControlText = cText
End Function
Sub FormSetControlText( cControlName As String,_
ByVal cText As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc )
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
oControlModel.Text = cText
End Sub
Function FormGetControlState( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Boolean
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
bState = oControlModel.State
FormGetControlState = bState
End Function
Sub FormSetControlState( cControlName As String,_
ByVal bState As Boolean,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc )
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
oControlModel.State = bState
End Sub
Function FormGetControlEnabled( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Boolean
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
bEnabled = oControlModel.Enabled
FormGetControlEnabled = bEnabled
End Function
Sub FormSetControlEnabled( cControlName As String,_
ByVal bEnabled As Boolean,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc )
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControlModel = FormGetControlModel( cControlName, cFormName, nPage, oDoc )
oControlModel.Enabled = bEnabled
End Sub
' Note that the control is visible in Form Design Mode.
' To toggle design mode do this....
' DocumentDispatch( oDoc, ".uno:SwitchControlDesignMode" )
'
Sub FormSetControlVisible( cControlName As String,_
ByVal bVisible As Boolean,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc )
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oControl = FormGetControl( cControlName, cFormName, nPage, oDoc )
oControl.setVisible( bVisible )
End Sub
Sub FormGetControlPosition( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oShape = FormFindControlShape( cControlName, cFormName, nPage, oDoc )
oPosition = oShape.Position
FormGetControlPosition = oPosition
End Sub
Sub FormSetControlPosition( cControlName As String,_
oPosition As com.sun.star.awt.Point,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oShape = FormFindControlShape( cControlName, cFormName, nPage, oDoc )
oShape.Position = oPosition
End Sub
Sub FormGetControlSize( cControlName As String,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oShape = FormFindControlShape( cControlName, cFormName, nPage, oDoc )
oSize = oShape.Size
FormGetControlSize = oSize
End Sub
Sub FormSetControlSize( cControlName As String,_
oSize As com.sun.star.awt.Size,_
ByVal cFormName As String,_
Optional nPage,_
Optional oDoc ) As Object
' If no document specified, then use this document.
If IsMissing( oDoc ) Then
oDoc = ThisComponent
EndIf
' If no page number specified, then pass -1.
If IsMissing( nPage ) Then
nPage = -1
EndIf
oShape = FormFindControlShape( cControlName, cFormName, nPage, oDoc )
oShape.Size = oSize
End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:36 pm; edited 1 time in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:35 pm Post subject: |
|
|
UtilProperty module
A more primitive form of this code was previously published here....
Manipulating PropertyValue's
http://www.oooforum.org/forum/viewtopic.phtml?t=5301
See also....
MakePropertyValue function
http://www.oooforum.org/forum/viewtopic.phtml?t=5108
| Code: | '**********************************************************************
' UtilProperty module
'
' Module of utilities to manipulate arrays of PropertyValue's.
'
' An array of property values is a one dimensional array
' of structs of type com.sun.star.beans.PropertyValue.
' http://api.openoffice.org/docs/common/ref/com/sun/star/beans/PropertyValue.html
'
' These routines make it easy to create and manipulate such arrays.
' Even without using the API, these routines give you a form
' of data structures in Basic.
'
' Some API routines return such an array. (See examples below.)
'
' Here is a simple technique that I've long used to create
' an array of property values to pass as an argument to
' functions such as loadComponentFromURL().
'
' Array(_
' MakePropertyValue( "Property1", value1 ),_
' MakePropertyValue( "Property2", value2 ) )
'
' You can create an empty array by just calling Array().
'
'
' Here are some examples of where arrays of PropertyValues' are
' used in the API, other than the simple case of loadComponentFromURL
' or the dispatcher where you pass in an array of PropertyValues.
'
' OfficeDocument implements, XPrintable, which provides getPrinter()
' that returns an array of PropertyValue's that describe the printer.
'
' If you have a TextCursor (from Writer?)
' http://api.openoffice.org/docs/common/ref/com/sun/star/text/TextCursor.html
' and access its NumberingRules property, you get an
' http://api.openoffice.org/docs/common/ref/com/sun/star/text/NumberingRules.html
' By calling getByIndex() on this, you can get any of the numbering rules for
' the document. Each call to getByIndex() returns an array of PropertyValue's
' for that numbering level.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-02-25-01
'
'**********************************************************************
Sub Main
' TestPropertyList()
' MsgBox PropValuesToStr( ThisComponent.getArgs() )
MsgBox GetPropertyValue( ThisComponent.getArgs(), "FilterName" )
End Sub
'############################################################
' Routines to manipulate arrays of PropertyValue's.
'############################################################
'----------
' Create and return a new com.sun.star.beans.PropertyValue.
'
Function MakePropertyValue( Optional cName As String, Optional uValue ) As com.sun.star.beans.PropertyValue
oPropertyValue = createUnoStruct( "com.sun.star.beans.PropertyValue" )
If Not IsMissing( cName ) Then
oPropertyValue.Name = cName
EndIf
If Not IsMissing( uValue ) Then
oPropertyValue.Value = uValue
EndIf
MakePropertyValue() = oPropertyValue
End Function
'-----
' Return the number of PropertyValue's in an array.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
'
' Returns zero if the array contains no elements.
'
Function NumPropertyValues( aPropertyValuesArray )
On Error GoTo ErrorHandler
nNumProperties = UBound( aPropertyValuesArray ) + 1
NumPropertyValues() = nNumProperties
Exit Function
ErrorHandler:
NumPropertyValues() = 0
End Function
'-----
' Find a particular named property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' cPropName - the name of a particular property you want.
'
' This finds the index in the array of PropertyValue's and returns it,
' or returns -1 if it was not found.
'
Function FindPropertyIndex( aPropertyValuesArray, ByVal cPropName As String ) As Long
nNumProperties = NumPropertyValues( aPropertyValuesArray )
For i = 0 To nNumProperties - 1
oProp = aPropertyValuesArray(i)
If oProp.Name = cPropName Then
FindPropertyIndex() = i
Exit Function
EndIf
Next
FindPropertyIndex() = -1
End Function
'-----
' Find a particular named property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' cPropName - the name of a particular property you want.
'
' This finds the PropertyValue and returns it, or returns Null if not found.
'
Function FindProperty( aPropertyValuesArray, ByVal cPropName As String ) As com.sun.star.beans.PropertyValue
nPropIndex = FindPropertyIndex( aPropertyValuesArray, cPropName )
If nPropIndex >= 0 Then
oProp = aPropertyValuesArray(nPropIndex) ' access array subscript
FindProperty() = oProp
EndIf
End Function
'-----
' Get the value of a particular named property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' cPropName - the name of a particular property you want.
' uDefaultValue - This value is returned if the property is not found
' in the array.
'
Function GetPropertyValue( aPropertyValuesArray, ByVal cPropName As String, Optional uDefaultValue )
nPropIndex = FindPropertyIndex( aPropertyValuesArray, cPropName )
If nPropIndex >= 0 Then
oProp = aPropertyValuesArray(nPropIndex) ' access array subscript
uValue = oProp.Value ' get the value from the PropertyValue
GetPropertyValue() = uValue
Else
GetPropertyValue() = uDefaultValue
EndIf
End Function
'-----
' Set the value of a particular named property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' cPropName - the name of a particular property you want.
' uValue - the value of the property to set.
'
Sub SetPropertyValue( aPropertyValuesArray, ByVal cPropName As String, ByVal uValue )
nPropIndex = FindPropertyIndex( aPropertyValuesArray, cPropName )
' Did we find it?
If nPropIndex >= 0 Then
' Found, the PropertyValue is already in the array.
' Just modify its value.
oProp = aPropertyValuesArray(nPropIndex) ' access array subscript
oProp.Value = uValue ' set the property value.
aPropertyValuesArray(nPropIndex) = oProp ' put it back into array
Else
' Not found, the array contains no PropertyValue with this name.
' Append new element to array.
nNumProperties = NumPropertyValues( aPropertyValuesArray )
If nNumProperties = 0 Then
aPropertyValuesArray = Array( MakePropertyValue( cPropName, uValue ) )
Else
' Make array larger.
Redim Preserve aPropertyValuesArray(nNumProperties)
' Assign new PropertyValue
aPropertyValuesArray(nNumProperties) = MakePropertyValue( cPropName, uValue )
EndIf
EndIf
End Sub
'-----
' Delete a particular named property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' cPropName - the name of a particular property you want.
'
Sub DeleteProperty( aPropertyValuesArray, ByVal cPropName As String )
nPropIndex = FindPropertyIndex( aPropertyValuesArray, cPropName )
DeleteIndexedProperty( aPropertyValuesArray, nPropIndex )
End Sub
'-----
' Delete a particular indexed property from an array of PropertyValue's.
' Parameters:
' aPropertyValuesArray - an array of PropertyValue's, that is an array of
' com.sun.star.beans.PropertyValue.
' nPropIndex - the name of a particular property you want.
'
Sub DeleteIndexedProperty( aPropertyValuesArray, ByVal nPropIndex As Long )
nNumProperties = NumPropertyValues( aPropertyValuesArray )
' Did we find it?
If nPropIndex < 0 Then
' Did not find it.
' We're done.
ElseIf nNumProperties = 1 Then
' We found it.
' It is the ONLY item in the array.
' Just return a new empty array.
aPropertyValuesArray = Array()
Else
' We found it.
' If it is NOT the last item in the array,
' then shift other elements down into it's position.
If nPropIndex < nNumProperties - 1 Then
' Bump items down lower in the array.
For i = nPropIndex To nNumProperties - 2
aPropertyValuesArray(i) = aPropertyValuesArray(i+1)
Next
EndIf
' Redimension the array to have one feweer element.
Redim Preserve aPropertyValuesArray(nNumProperties-2)
EndIf
End Sub
'-----
' Convenience function to return a string which explains what
' PropertyValue's are in the array of PropertyValue's.
'
Function PropValuesToStr( aPropertyValuesArray )
nNumProperties = NumPropertyValues( aPropertyValuesArray )
cResult = CSTR( nNumProperties ) & " Properties."
For i = 0 To nNumProperties-1
oProp = aPropertyValuesArray(i)
cName = oProp.Name
uValue = oProp.Value
cResult = cResult & Chr(13) & " " & cName & " = " & CStr2( uValue )
Next
PropValuesToStr() = cResult
End Function
'-----
' Return a string, which is a single BASIC expression
' that when evaluated, would re-construct the array
' of PropertyValue's.
'
Function PropValuesToBASIC( aPropertyValuesArray, Optional cIndent )
If IsMissing( cIndent ) Then
cIndent = ""
EndIf
nNumProperties = NumPropertyValues( aPropertyValuesArray )
If nNumProperties = 0 Then
cExpr = cIndent & "Array()"
Else
cExpr = cIndent & "Array( _"
For i = 0 To nNumProperties-1
oProp = aPropertyValuesArray(i)
cName = oProp.Name
uValue = oProp.Value
cExpr = cExpr & Chr(13) & cIndent & " MakePropertyValue(" & BasicSyntaxOfValue( cName )_
& ", " & BasicSyntaxOfValue( uValue )
If i = nNumProperties-1 Then
cExpr = cExpr & ") )"
Else
cExpr = cExpr & "),_"
EndIf
Next
EndIf
PropValuesToBASIC() = cExpr
End Function
'Sub TestPropertyList()
'' MsgBox PropValuesToStr( Array() )
'
'' MsgBox PropValuesToStr( Array( MakePropertyValue( "Color", "Red" ) ) )
'
'' MsgBox PropValuesToStr( Array(_
'' MakePropertyValue( "Color", "Red" ),_
'' MakePropertyValue( "Weight", "5000 lbs" ),_
'' MakePropertyValue( "Length", "2 light minutes" ) _
'' ) )
'
' ' Create an empty array of PropertyValues.
' x = Array()
' ' Display it.
' MsgBox PropValuesToStr( x )
'
' ' Now set a property.
' SetPropertyValue( x, "Color", "Red" )
' ' Display the new list.
' MsgBox PropValuesToStr( x )
'
' SetPropertyValue( x, "IsVisible", True )
' SetPropertyValue( x, "IsPrintable", False )
' SetPropertyValue( x, "Length", 200 )
' SetPropertyValue( x, "Width", 500 )
' SetPropertyValue( x, "Height", 700 )
' MsgBox PropValuesToStr( x )
'
' ' Now change a previously set property.
' SetPropertyValue( x, "Length", 400 )
' MsgBox PropValuesToStr( x )
'
' nHeight = GetPropertyValue( x, "Height", 0 )
' MsgBox "The Height is " & CSTR( nHeight )
'
' MsgBox "The Color is " & GetPropertyValue( x, "Color", "" )
'
' MsgBox "The Xyzzy is " & GetPropertyValue( x, "Xyzzy", "??" )
'
' DeleteProperty( x, "Height" )
' MsgBox PropValuesToStr( x )
'
' DeleteProperty( x, "IsVisible" )
' DeleteProperty( x, "IsPrintable" )
' MsgBox PropValuesToStr( x )
'
' DeleteProperty( x, "Color" )
' DeleteProperty( x, "Width" )
' DeleteProperty( x, "Xyzzy" )
' MsgBox PropValuesToStr( x )
'
' DeleteProperty( x, "Length" )
' MsgBox PropValuesToStr( x )
'
' SetPropertyValue( x, "Distance", "2 light years" )
' MsgBox PropValuesToStr( x )
'End Sub
|
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Apr 02, 2005 1:04 pm; edited 1 time in total |
|
| Back to top |
|
|
DannyB
Moderator
Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA
|
| Posted: Sat Apr 02, 2005 12:35 pm Post subject: |
|
|
UtilString module
This module was previously published here....
String utility functions for OOo Basic
http://www.oooforum.org/forum/viewtopic.phtml?t=5374
Instead of consulting that thread, you should always get the latest version of this UtilString module from this thread.
Similarly, I posted a set of closely related functions here....
String Utility functions for Python
http://www.oooforum.org/forum/viewtopic.phtml?t=10974
| Code: | '**********************************************************************
' UtilString module
'
' String manipulation utility functions.
'
' Author's note...
' These functions have the same names and semantics as
' functions I have used for years and years in various
' programming languages.
' I tend to port a common set of functions to whatever new
' language I am working in so that I have well known common
' semantics. If a particular function does not behave as
' it does in every other language, then it has a bug.
'
'**********************************************************************
' Copyright (c) 2003-2004 Danny Brewer
' d29583@groovegarden.com
'
' This library is free software; you can redistribute it and/or
' modify it under the terms of the GNU Lesser General Public
' License as published by the Free Software Foundation; either
' version 2.1 of the License, or (at your option) any later version.
'
' This library is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
' Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public
' License along with this library; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
'
' See: http://www.gnu.org/licenses/lgpl.html
'
'**********************************************************************
' If you make changes, please append to the change log below.
'
' Change Log
' Danny Brewer Revised 2004-12-21-01
'
'**********************************************************************
Sub Main
Print RemTrailing( " " )
Print StrRot13( "Hello Zare" ), StrRot13( StrRot13( "Hello Zare" ) )
End Sub
Const cUpperCaseLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const cLowerCaseLetters = "abcdefghijklmnopqrstuvwxyz"
Const cDigits = "0123456789"
' Returns true if every char in cChars is a digit.
Function IsDigit( ByVal cChars As String ) As Boolean
IsDigit() = AllCharsInSet( cChars, cDigits )
End Function
' Returns true if every char in cChars is a letter.
Function IsAlpha( ByVal cChars As String ) As Boolean
IsAlpha() = AllCharsInSet( cChars, cUpperCaseLetters & cLowerCaseLetters )
End Function
' Returns true if every char in cChars is a letter or digit.
Function IsAlphaNumeric( ByVal cChars As String ) As Boolean
IsAlpha() = AllCharsInSet( cChars, cUpperCaseLetters & cLowerCaseLetters & cDigits )
End Function
' Returns true if every char in cChars is a upper case letter.
Function IsUCaseAlpha( ByVal cChars As String ) As Boolean
IsUCaseAlpha() = AllCharsInSet( cChars, cUpperCaseLetters )
End Function
' Returns true if every char in cChars is a lower case letter.
Function IsLCaseAlpha( ByVal cChars As String ) As Boolean
IsLCaseAlpha() = AllCharsInSet( cChars, cLowerCaseLetters )
End Function
' Returns true if EVERY char of cChars is in the set cSet.
' The string cSet is considered to be a SET of characters.
' The function returns true if EVERY character of cChars is
' in the SET cSet.
Function AllCharsInSet( ByVal cChars As String, ByVal cSet As String ) As Boolean
AllCharsInSet() = False
For i = 1 To Len( cChars )
c = Mid( cChars, i, 1 )
If Instr( 1, cSet, c, 0 ) = 0 Then
Exit Function
EndIf
Next
AllCharsInSet() = True
End Function
' Returns true if EVERY char of cChars are NOT in the set cSet.
' The string cSet is considered to be a SET of characters.
' The function returns true if EVERY character of cChars is
' NOT in the SET cSet.
Function AllCharsNotInSet( ByVal cChars As String, ByVal cSet As String ) As Boolean
AllCharsNotInSet() = False
For i = 1 To Len( cChars )
c = Mid( cChars, i, 1 )
If Instr( 1, cSet, c, 0 ) > 0 Then
Exit Function
EndIf
Next
AllCharsNotInSet() = True
End Function
' Returns true if ANY char of cChars is in the set cSet.
Function AnyCharsInSet( ByVal cChars As String, ByVal cSet As String ) As Boolean
bNoneInSet = AllCharsNotInSet( cChars, cSet )
AnyCharsInSet() = Not bNoneInSet
End Function
' Returns true if ANY char of cChars are NOT in the set cSet.
Function AnyCharsNotInSet( ByVal cChars As String, ByVal cSet As String ) As Boolean
bAllInSet = AllCharsInSet( cChars, cSet )
AnyCharsNotInSet() = Not bAllInSet
End Function
' Build up a string of chars from nFirstChar to nLastChar.
' Both nFirstChar and nLastChar are the ASCII character numbers.
' Examples:
' To build string of all printable characters....
' x = BuildStringRange( 32, 127 )
' To build string of all uppercase characters, that is equal
' to the constant cUpperCaseLetters...
' x = BuildStringRange( 65, 65+26-1 )
' x = BuildStringRange( ASC("A"), ASC("Z") )
' This function is useful to build up sets of characters for
' AllCharsInSet() and AllCharsNotInSet().
Function BuildStringRange( ByVal nFirstChar As Long, ByVal nLastChar As Long ) As String
cResult = ""
For i = nFirstChar To nLastChar
cResult = cResult & Chr( i )
Next
BuildStringRange() = cResult
End Function
' Return string with proper capitalization.
' For example, if you pass in "joHN smITH" you get back "John Smith".
' You may optionally specify cWordChars, which characters are to
' be considered as part of a word.
' If you do not specify cWordChars, then a word is considered to be
' a string made up of any combination of...
' 1. uppercase chars
' 2. lowercase chars
' 3. digits
'
Function ProperName( ByVal cName As String, Optional cWordChars ) As String
If IsMissing( cWordChars ) Then
cWordChars = cUpperCaseLetters & cLowerCaseLetters & cDigits
EndIf
bInWord = False
cResult = ""
For i = 1 To Len( cName )
c = Mid( cName, i, 1 )
If bInWord Then
If AllCharsInSet( c, cWordChars ) Then
c = LCase( c )
Else
bInWord = False
EndIf
Else
If AllCharsInSet( c, cWordChars ) Then
c = UCase( c )
bInWord = True
Else
c = LCase( c )
EndIf
EndIf
cResult = cResult + c
Next
ProperName() = cResult
End Function
' If cString is longer than nLen, then truncate SUFFIX characters (from the right)
' to make cString's length exactly nLen.
' If cString is shorter than nLen, then pad it on the right with cPadChar.
' If cPadChar is not specified, then it is a blank.
Function PadR( ByVal cString As String, ByVal nLen As Long, Optional cPadChar ) As String
nStrLen = Len( cString )
If nStrLen > nLen Then
cString = Left( cString, nLen )
ElseIf nStrLen < nLen Then
If IsMissing( cPadChar ) Then
cPadChar = " "
EndIf
Do
cString = cString + cPadChar
Loop While Len( cString ) < nLen
EndIf
PadR() = cString
End Function
' If cString is longer than nLen, then truncate SUFFIX characters (from the right)
' to make cString's length exactly nLen.
' If cString is shorter than nLen, then pad it on the left with cPadChar.
' If cPadChar is not specified, then it is a blank.
Function PadL( ByVal cString As String, ByVal nLen As Long, Optional cPadChar ) As String
nStrLen = Len( cString )
If nStrLen > nLen Then
cString = Left( cString, nLen )
ElseIf nStrLen < nLen Then
If IsMissing( cPadChar ) Then
cPadChar = " "
EndIf
Do
cString = cPadChar + cString
Loop While Len( cString ) < nLen
EndIf
PadL() = cString
End Function
' Return True if cPrefixString matches the beginning of cString.
' The following would return true...
' IsPrefixString( "Jo", "John" )
' IsPrefixString( "Jo", "Joseph" )
' IsPrefixString( "Jo", "Jolly" )
Function IsPrefixString( ByVal cPrefixString As String, ByVal cString As String ) As Boolean
IsPrefixString() = (Left( cString, Len( cPrefixString ) ) = cPrefixString )
End Function
' Return True if cPrefixString matches the beginning of cString,
' but ignoring case.
Function IsPrefixStringNC( ByVal cPrefixString As String, ByVal cString As String ) As Boolean
IsPrefixStringNC() = (UCase( Left( cString, Len( cPrefixString ) ) ) = UCase( cPrefixString ) )
End Function
' Return True if cSuffixString matches the ending of cString.
' The following would return true...
' IsSuffixString( "ing", "Walking" )
' IsSuffixString( "ing", "Running" )
' IsSuffixString( "ing", "Programming" )
Function IsSuffixString( ByVal cSuffixString As String, ByVal cString As String ) As Boolean
IsSuffixString() = (Right( cString, Len( cSuffixString ) ) = cSuffixString )
End Function
' Return True if cSuffixString matches the ending of cString,
' but ignoring case.
Function IsSuffixStringNC( ByVal cSuffixString As String, ByVal cString As String ) As Boolean
IsSuffixStringNC() = (UCase( Right( cString, Len( cSuffixString ) ) ) = UCase( cSuffixString ) )
End Function
' Return the common prefix, if any, of both strings.
Function CommonPrefixString( ByVal cStr1 As String, ByVal cStr2 As String ) As String
nLen = Min2( Len( cStr1 ), Len( cStr2 ) )
cPrefix = ""
For i = 1 To nLen
c1 = Mid( cStr1, i, 1 )
c2 = Mid( cStr2, i, 1 )
If c1 = c2 Then
cPrefix = cPrefix & c1
Else
Exit For
EndIf
Next
CommonPrefixString() = cPrefix
End Function
' Return the common suffix, if any, of both strings.
Function CommonSuffixString( ByVal cStr1 As String, ByVal cStr2 As String ) As String
nLen = Min2( Len( cStr1 ), Len( cStr2 ) )
cSuffix = ""
For i = nLen To 1 Step -1
c1 = Mid( cStr1, i, 1 )
c2 = Mid( cStr2, i, 1 )
If c1 = c2 Then
cSuffix = c1 & cSuffix
Else
Exit For
EndIf
Next
CommonSuffixString() = cSuffix
End Function
' Remove trailing characters from a string.
' The default is to remove trailing blanks, if you don't specify the cSetOfCharsToRemove.
' The cSetOfCharsToRemove specifies a SET of characters you want removed from the end
' of the string.
' For example, specify " 0" to remove trailing blanks and zeros.
' For example, specify " "&Chr(9) to remove trailing blanks and tab characters.
Function RemTrailing( ByVal cString As String, Optional cSetOfCharsToRemove ) As String
If IsMissing( cSetOfCharsToRemove ) Then
cSetOfCharsToRemove = " "
EndIf
nLen = Len( cString )
i = nLen
Do While (i > 0)
If Not AllCharsInSet( Mid( cString,i,1 ), cSetOfCharsToRemove ) Then
Exit Do
EndIf
i = i - 1
Loop
RemTrailing() = Left( cString, i )
End Function
' Remove leading characters from a string.
' The default is to remove leading blanks, if you don't specify the cSetOfCharsToRemove.
' The cSetOfCharsToRemove specifies a SET of characters you want removed from the beginning
' of the string.
' For example, specify " 0" to remove leading blanks and zeros.
' For example, specify " "&Chr(9) to remove leading blanks and tab characters.
Function RemLeading( ByVal cString As String, Optional cSetOfCharsToRemove ) As String
If IsMissing( cSetOfCharsToRemove ) Then
cSetOfCharsToRemove = " "
EndIf
nLen = Len( cString )
i = 1
Do While (i <= nLen)
If Not AllCharsInSet( Mid( cString,i,1 ), cSetOfCharsToRemove ) Then
Exit Do
EndIf
i = i + 1
Loop
RemLeading() = Right( cString, nLen+1-i )
End Function
' Remove leading and trailing characters from a string.
' The default is to remove leading and trailing blanks,
' if you don't specify the cSetOfCharsToRemove.
Function RemLeadingAndTrailing( ByVal cString As String, Optional cSetOfCharsToRemove ) As String
If IsMissing( cSetOfCharsToRemove ) Then
cSetOfCharsToRemove = " "
EndIf
RemLeadingAndTrailing() = RemLeading( RemTrailing( cString, cSetOfCharsToRemove ), cSetOfCharsToRemove )
End Function
' Convert runs of multiple spaces into a single space.
' Thus "John Smith" becomes "John Smith".
Function CoalesceMultipleBlanks( ByVal cString As String ) As String
CoalesceMultipleBlanks() = CoalesceMultipleChars( cString, " " )
End Function
' Whenever there are runs of multiple chars, of any char in the set cSetToCoalesce,
' then convert that run of chars into a single char.
' For example...
' If cSetToCoalesce was "AB",
' then the string "AAABBBCCCAAABBBCCC" would become "ABCCCABCCC".
Function CoalesceMultipleChars( ByVal cString As String, ByVal cSetToCoalesce As String ) As String
i = 1
' Note that length of cString can change during the loop!
Do While i <= Len( cString )
c = Mid( cString, i, 1 )
If AllCharsInSet( c, cSetToCoalesce ) Then
cString = Left( cString, i ) & RemLeading( Mid( cString, i+1 ), c )
EndIf
i = i + 1
Loop
CoalesceMultipleChars() = cString
End Function
' Remove from cString, all characters in the SET of cSetOfUnwantedChars.
Function RemoveCharsInSet( ByVal cString As String, ByVal cSetOfUnwantedChars As String ) As String
cResult = ""
For i = 1 To Len( cString )
c = Mid( cString, i, 1 )
If AllCharsNotInSet( c, cSetOfUnwantedChars ) Then
cResult = cResult & c
EndIf
Next
RemoveCharsInSet() = cResult
End Function
' Remove from cString, all characters NOT in the SET of cSetOfWantedChars.
Function RemoveCharsNotInSet( ByVal cString As String, ByVal cSetOfWantedChars As String ) As String
cResult = ""
For i = 1 To Len( cString )
c = Mid( cString, i, 1 )
If AllCharsInSet( c, cSetOfWantedChars ) Then
cResult = cResult & c
EndIf
Next
RemoveCharsNotInSet() = cResult
End Function
' The original string, cString, is modified by this function and then returned.
' All occurences of cFindStr are replaced by cReplaceStr.
' cFindStr and cReplaceStr do not need to be the same length.
Function StrSubstitute( ByVal cString As String,_
ByVal cFindStr As String, ByVal cReplaceStr As String ) As String
cResult = ""
If Len( cFindStr ) > 0 Then
Do
nPos = Instr( 1, cString, cFindStr, 0 )
If nPos > 0 Then
cResult = cResult & Left( cString, nPos-1 )
cResult = cResult & cReplaceStr
cString = Mid( cString, nPos+Len(cFindStr) )
Else
' Append the rest of the original string.
cResult = cResult & cString
EndIf
Loop Until nPos = 0
EndIf
StrSubstitute() = cResult
End Function
' The original string, cString, is modified by this function and then returned.
' Any character of cString that is in cFromChars, is replaced by the character
' at the corresponding position in cToChars.
' If cToChars is shorter than cFromChars, then characters in cFromChars which
' have no counterpart in cToChars are removed from the string.
' To remove all dollar signs from a string, you could write...
' cString = CharTranslate( cString, "$", "" )
' To change all semicolons into commas, and all underscores into dashes...
' cString = CharTranslate( cString, ";_", ",-" )
Function CharTranslate( ByVal cString As String,_
ByVal cFromChars As String, ByVal cToChars As String ) As String
cResult = ""
For i = 1 To Len( cString )
c = Mid( cString, i, 1 )
nPos = Instr( 1, cFromChars, c, 0 )
If nPos > 0 Then
' The char was found in cFromChars.
' Find the counterpart in cToChars.
' If no counterpart, then nothing gets appended to the result!
If nPos <= Len( cToChars ) Then
c = Mid( cToChars, nPos, 1 )
cResult = cResult & c
EndIf
Else
' The char not found in cFromChars, so don't translate it.
' Just append it as is.
cResult = cResult & c
EndIf
Next
CharTranslate() = cResult
End Function
' Given a url, escape whatever characters are in the cEscapeSet.
' By default: cEscapeSet is the set of
' 1. space
' 2. forward-slash
' For example, if cUrl were: http://cnn.com
' and eEscapeSet were the default, then this would return...
' http:%2F%2Fcnn.com
' where the forward slashes were escaped into %2F.
Function EscapeUrlChars( ByVal cUrl As String, Optional cEscapeSet ) As String
If IsMissing( cEscapeSet ) Then
cEscapeSet = " /"
EndIf
For i = 1 To Len( cEscapeSet )
c = Mid( cEscapeSet, i, 1 )
cEscaped = "%" & IntValueToHexDigits( Asc(c), 2 )
cUrl = StrSubstitute( cUrl, c, cEscaped )
Next
EscapeUrlChars() = cUrl
End Function
' Translate an english phrase into the grammer spoken by script kiddies on Slashdot.
' The statement: Print TranslateToL33tSp3ak( "Test to see if you are owned by elite hackers." )
' will print: 7357 70 533 if J00 ar3 0wn3d 8y 1337 4aX0r5.
Function TranslateToL33tSp3ak( ByVal cEnglish As String ) As String
cL33t = cEnglish
cL33t = StrSubstitute( cL33t, UCase("you"), "Joo" )
cL33t = StrSubstitute( cL33t, "elite", "leet" )
cL33t = StrSubstitute( cL33t, "acker", "aXor" )
cL33t = CharTranslate( cL33t, "oO1lZzEeHhSsGTtB", "0011223344556778" )
TranslateToL33tSp3ak() = cL33t
End Function
' Convert a name or id into a form that makes it likely to match
' a similar name or id.
' That way if two different operators type in variations of "JoHn , SmITh; "
' you are likely to get the same record in the database.
' 1. Trim leading trailing blanks.
' 2. Remove punctuation. (prior to coalescing blanks!)
' 3. Coalesce multiple blanks.
' 4. Convert to Proper case.
' Of course, you could build your own normalization function,
' using the primitives from this library,
' and using this function as a model.
Function StrNormalize( ByVal cString As String ) As String
cString = RemLeadingAndTrailing( cString )
cString = RemoveCharsInSet( cString, ".,;:-'" )
cString = CoalesceMultipleBlanks( cString )
cString = ProperName( cString )
StrNormalize() = cString
End Function
' The common Usenet Rot13 function.
Function StrRot13( ByVal cString As String, Optional nRotate ) As String
If IsMissing( nRotate ) Then
nRotate = 13
EndIf
cResult = ""
nLen = Len( cString )
For i = 1 To nLen
c = Mid( cString, i, 1 )
If IsUCaseAlpha( c ) Then
n = Asc( c ) - Asc("A")
n = (n + nRotate) Mod 26
c = Chr( n + Asc("A") )
ElseIf IsLCaseAlpha( c ) Then
n = Asc( c ) - Asc("a")
n = (n + nRotate) Mod 26
c = Chr( n + Asc("a") )
EndIf
cResult = cResult + c
Next
StrRot13 = cResult
End Function
' The common Wikipedia Rot47 function.
Function StrRot47( cString )
cResult = ""
' Iterate over characters.
nLen = Len( cString )
For i = 1 To nLen
' Get current character.
c = Mid( cString, i, 1 )
' Do Rot47
If c >= "!" And c <= "~" Then
c = Chr( (( Asc( c ) - Asc("!") + 47 ) Mod 94) + Asc("!") )
EndIf
' Add to result.
cResult = cResult + c
Next
StrRot47 = cResult
End Function
|
See this for Ian's novel implementation of StrSubstitute....
http://www.oooforum.org/forum/viewtopic.phtml?p=79867#79867
_________________
Want to make OOo Drawings like the colored flower design to the left?
Last edited by DannyB on Sat Jun 04, 2005 8:54 am; edited 1 time in total |
|
| Back to top |
|
|
JohnV
Administrator
Joined: 07 Mar 2003
Posts: 8982
Location: Lexinton, Kentucky, USA
|
| Posted: Sun Apr 03, 2005 9:33 am Post subject: |
|
|
Thanks Danny! It is really nice to have this all in one place.
I have copied and pasted your original message and all code into an OOo Writer document to be able the have all this available locally on my machine. For any others interested, you can get a copy here: http://home.earthlink.net/~jcvigor/DannysBasicLibrary.sxw
Notes about this document. All line breaks created with the copy and paste have been converted to paragraph breaks. All non-breaking spaces have been replaced with normal ones. All spaces following "_" have been removed. After these edits I was able to copy & paste the entire section on string manipulation into the Basic IDE and run the first subroutine without errors. I have done no other testing.
Last edited by JohnV on Mon Jun 20, 2005 6:09 am; edited 1 time in total |
|
| Back to top |
|
|
urke
General User
Joined: 19 Jan 2005
Posts: 21
Location: Kragujevac, Srbija
|
| Posted: Thu Apr 14, 2005 2:23 am Post subject: |
|
|
| Code: |
Sub Array1_AppendElement( aArray, uNewElement )
nNumElements = Array1_Size( aArray )
If nNumElements = 0 Then
aArray = Array( uNewElement )
Else
If isArray(uNewElement) then
For n = LBound(uNewElement) To UBound(uNewElement)
Redim Preserve aArray( nNumElements + n )
aArray( nNumElements + n ) = uNewElement(n)
Next
Else
Redim Preserve aArray( nNumElements )
aArray( nNumElements ) = uNewElement
EndIf
EndIf
End Sub
|
I made small improvement to Array1_AppendElement function, if we appending another Array instead of single element. I need this solution so I add it, and if someone else need to join two arrays, there is solution  |
|
| Back to top |
|
|
|
|
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum
|
Powered by phpBB © 2001, 2005 phpBB Group
|
