home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DOS/V Power Report 2004 April
/
VPR0404.ISO
/
OPENOFFICE
/
INSTALL
/
f_0318
/
Hard.xba
< prev
next >
Wrap
Extensible Markup Language
|
2002-09-17
|
7KB
|
229 lines
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Hard" script:language="StarBasic">REM ***** BASIC *****
Option Explicit
Sub CreateRangeList()
Dim MaxIndex as Integer
MaxIndex = -1
EnableStep1DialogControls(False, False, False)
EmptySelection()
DialogModel.lblSelection.Label = sCURRRANGES
EmptyListbox(DialogModel.lstSelection)
oDocument.CurrentController.Select(oSelRanges)
If (DialogModel.optSheetRanges.State = 1) AND (DialogModel.chkComplete.State <> 1) Then
' Conversion on a sheet?
SetStatusLineText(sStsRELRANGES)
osheet = oDocument.CurrentController.GetActiveSheet
oRanges = osheet.CellFormatRanges.createEnumeration()
MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, False)
If MaxIndex > -1 Then
ReDim Preserve RangeList(MaxIndex)
End If
Else
CreateRangeEnumeration(False)
bRangeListDefined = True
End If
EnableStep1DialogControls(True, True, True)
SetStatusLineText("")
End Sub
Sub CreateRangeEnumeration(bAutopilot as Boolean)
Dim i as Integer
Dim MaxIndex as integer
Dim sStatustext as String
MaxIndex = -1
If Not bRangeListDefined Then
' Cellranges are not yet defined
oSheets = oDocument.Sheets
For i = 0 To oSheets.Count-1
oSheet = oSheets.GetbyIndex(i)
If bAutopilot Then
IncreaseStatusValue(SBRELGET/osheets.Count)
Else
sStatustext = ReplaceString(sStsRELSHEETRANGES,Str(i+1),"%1Number%1")
sStatustext = ReplaceString(sStatusText,oSheets.Count,"%2TotPageCount%2")
SetStatusLineText(sStatusText)
End If
oRanges = osheet.CellFormatRanges.createEnumeration
MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, bAutopilot)
Next i
Else
If Not bAutoPilot Then
SetStatusLineText(sStsRELRANGES)
' cellranges already defined
For i = 0 To Ubound(RangeList())
If RangeList(i) <> "" Then
AddSingleItemToListBox(DialogModel.lstSelection, RangeList(i))
End If
Next
End If
End If
If MaxIndex > -1 Then
ReDim Preserve RangeList(MaxIndex)
Else
ReDim RangeList()
End If
Rangeindex = MaxIndex
End Sub
Function AddSheetRanges(oRanges as Object, r as Integer, oSheet as Object, bAutopilot)
Dim RangeName as String
Dim AddtoList as Boolean
Dim iCurStep as Integer
Dim MaxIndex as Integer
iCurStep = DialogModel.Step
While oRanges.hasMoreElements
oRange = oRanges.NextElement
AddToList = CheckFormatType(oRange)
If AddToList Then
RangeName = RetrieveRangeNamefromAddress(oRange)
TotCellCount = TotCellCount + CountRangeCells(oRange)
If Not bAutoPilot Then
AddSingleItemToListbox(DialogModel.lstSelection, RangeName)
End If
' The Ranges are only passed to an Array when the whole Document is the basis
' Redimension the RangeList Array if necessary
MaxIndex = Ubound(RangeList())
r = r + 1
If r > MaxIndex Then
MaxIndex = MaxIndex + SBRANGEUBOUND
ReDim Preserve RangeList(MaxIndex)
End If
RangeList(r) = RangeName
End If
Wend
AddSheetRanges = r
End Function
' adds a section to the collection
Sub SelectRange()
Dim i as Integer
Dim RangeName as String
Dim SelItem as String
Dim CurRange as String
Dim SheetRangeName as String
Dim DescriptionList() as String
Dim MaxRangeIndex as Integer
Dim StatusValue as Integer
StatusValue = 0
MaxRangeIndex = Ubound(SelRangeList())
CurSheetName = oSheet.Name
For i = 0 To MaxRangeIndex
SelItem = SelRangeList(i)
' Is the Range already included in the collection?
oRange = RetrieveRangeoutOfRangename(SelItem)
TotCellCount = TotCellCount + CountRangeCells(oRange)
DescriptionList() = ArrayOutofString(SelItem,".",1)
SheetRangeName = DeleteStr(DescriptionList(0),"'")
If SheetRangeName = CurSheetName Then
oSelRanges.InsertbyName("",oRange)
End If
IncreaseStatusValue(SBRELGET/MaxRangeIndex)
Next i
End Sub
Sub ConvertThehardWay(ListboxList(), SwitchFormat as Boolean, bRemove as Boolean)
Dim i as Integer
Dim AddCells as Long
Dim OldStatusValue as Single
Dim RangeName as String
Dim LastIndex as Integer
Dim oSelListbox as Object
oSelListbox = DialogConvert.GetControl("lstSelection")
Lastindex = Ubound(ListboxList())
If TotCellCount > 0 Then
OldStatusValue = StatusValue
' hard format
For i = 0 To LastIndex
RangeName = ListboxList(i)
oRange = RetrieveRangeoutofRangeName(RangeName)
ConvertCellCurrencies(oRange)
If bRemove Then
If oSelRanges.HasbyName(RangeName) Then
oSelRanges.RemovebyName(RangeName)
oDocument.CurrentController.Select(oSelRanges)
End If
End If
If SwitchFormat Then
If oRange.getPropertyState("NumberFormat") <> 1 Then
' Range is hard formatted
SwitchNumberFormat(oRange, oFormats, sEuroSign)
End If
Else
SwitchNumberFormat(oRange, oFormats, sEuroSign)
End If
AddCells = CountRangeCells(oRange)
CurCellCount = AddCells
IncreaseStatusValue((CurCellCount/TotCellCount)*(100-OldStatusValue))
If bRemove Then
RemoveListBoxItemByName(oSelListbox.Model,Rangename)
End If
Next
End If
End Sub
Sub ConvertCellCurrencies(oRange as Object)
Dim oValues as Object
Dim oCells as Object
Dim oCell as Object
oValues = oRange.queryContentCells(com.sun.star.sheet.CellFlags.VALUE)
If (oValues.Count > 0) Then
oCells = oValues.Cells.createEnumeration
While oCells.hasMoreElements
oCell = oCells.nextElement
ModifyObjectValuewithCurrFactor(oCell)
Wend
End If
End Sub
Sub ModifyObjectValuewithCurrFactor(oDocObject as Object)
Dim oDocObjectValue as double
oDocObjectValue = oDocObject.Value
oDocObject.Value = Round(oDocObjectValue/CurrFactor, 2)
End Sub
Function CheckIfRangeisCurrency(FormatObject as Object)
Dim oFormatofObject() as Object
' Retrieve the Format of the Object
On Local Error GoTo NOKEY
oFormatofObject() = oFormats.getByKey(FormatObject.NumberFormat)
On Local Error GoTo 0
CheckIfRangeIsCurrency = INT(oFormatofObject.Type) AND com.sun.star.util.NumberFormat.CURRENCY
Exit Function
NOKEY:
CheckIfRangeisCurrency = False
Resume CLERROR
CLERROR:
End Function
Function CountColumnsForRow(IndexArray() as String, Row as Integer)
Dim i as Integer
Dim NoNulls as Boolean
For i = 1 To Ubound(IndexArray,2)
If IndexArray(Row,i)= "" Then
NoNulls = False
Exit For
End If
Next
CountColumnsForRow = i
End Function
Function CountRangeCells(oRange as Object) As Long
Dim oRangeAddress as Object
Dim LocCellCount as Long
oRangeAddress = oRange.RangeAddress
LocCellCount = (oRangeAddress.EndColumn - oRangeAddress.StartColumn + 1) * (oRangeAddress.EndRow - oRangeAddress.StartRow + 1)
CountRangeCells = LocCellCount
End Function</script:module>