OpenOffice.org Forum at OOoForum.orgThe OpenOffice.org Forum
 
 [Home]   [FAQ]   [Search]   [Memberlist]   [Usergroups]   [Register
 [Profile]   [Log in to check your private messages]   [Log in

Danny's Basic Library
Goto page 1, 2  Next
 
Post new topic   Reply to topic    OOoForum.org Forum Index -> OpenOffice.org Code Snippets
View previous topic :: View next topic  
Author Message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:32 pm    Post subject: Danny's Basic Library Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:32 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:32 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:33 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:33 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:33 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:33 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:34 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:34 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:34 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:35 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:35 pm    Post subject: Reply with quote

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
View user's profile Send private message
DannyB
Moderator
Moderator


Joined: 02 Apr 2003
Posts: 3991
Location: Lawrence, Kansas, USA

PostPosted: Sat Apr 02, 2005 12:35 pm    Post subject: Reply with quote

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
View user's profile Send private message
JohnV
Administrator
Administrator


Joined: 07 Mar 2003
Posts: 9183
Location: Lexinton, Kentucky, USA

PostPosted: Sun Apr 03, 2005 9:33 am    Post subject: Reply with quote

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
View user's profile Send private message
urke
General User
General User


Joined: 19 Jan 2005
Posts: 21
Location: Kragujevac, Srbija

PostPosted: Thu Apr 14, 2005 2:23 am    Post subject: Reply with quote

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 Smile
Back to top
View user's profile Send private message Visit poster's website
Display posts from previous:   
Post new topic   Reply to topic    OOoForum.org Forum Index -> OpenOffice.org Code Snippets All times are GMT - 8 Hours
Goto page 1, 2  Next
Page 1 of 2

 
Jump to:  
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