com!online 2001 December/COMCD1201.iso/openoffice/f_0259/Hard.xba

Extensible Markup Language | 2001-06-25 | 7.5 KB | 232 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
'ToDo: Währung wechseln und dann sehen, ob die Listbox mit den neuen Ranges aufgefrischt wird


Sub CreateRangeList()
Dim MaxIndex as Integer
    MaxIndex = -1
    EnableStep1DialogControls(False, False, False)
    EmptySelection()
    DialogModel.lblSelection.Label = sCURRRANGES      '"Währungsbereiche:"
    EmptyListbox(DialogModel.lstSelection)
    oDocument.CurrentController.Select(oSelRanges)
    If (DialogModel.optSheetRanges.State = 1) AND (DialogModel.chkComplete.State <> 1) Then
        ' Ist das Sheet Grundlage f├╝r die Bearbeitung?
        oStatusline.SetText(sStsRELRANGES)                '"Erfassung der relevanten Bereiche..."
        osheet = oDocument.CurrentController.GetActiveSheet
        oRanges = osheet.CellFormatRanges.createEnumeration()
        MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, False)
        ReDim Preserve RangeList(MaxIndex,1)
    Else
        CreateRangeEnumeration(False)
        bRangeListDefined = True
    End If
    EnableStep1DialogControls(True, True, True)
    oStatusline.SetText("")
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
        ' Die Ranges sind noch nicht definiert
        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")
                oStatusline.SetText(sStatusText)
            End If
            oRanges = osheet.CellFormatRanges.createEnumeration
            MaxIndex = AddSheetRanges(oRanges, MaxIndex, oSheet, bAutopilot)
        Next i
    Else
        If Not bAutoPilot Then
            oStatusline.SetText(sStsRELRANGES)      '"Erfassung der relevanten Bereiche..."
            ' Die Ranges sind schon definiert
            For i = 0 To Ubound(RangeList(),1)
                If RangeList(i,0) <> "" AND Rangelist(i,1) = True Then
                    AddSingleItemToListBox(DialogModel.lstSelection, RangeList(i))
                End If
            Next
        End If
    End If
    If MaxIndex > -1 Then
        ReDim Preserve RangeList(MaxIndex,1)
    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(),1)
            r = r + 1
            If r > MaxIndex Then
                MaxIndex = MaxIndex + SBRANGEUBOUND
                ReDim Preserve RangeList(MaxIndex,1)
            End If
            RangeList(r,0) = RangeName
            RangeList(r,1) = True
        End If
    Wend
    AddSheetRanges = r
End Function


' F├╝gt einen Bereich zur selektierten Kollektion hinzu
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 ' r, a
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
        ' Harte Formatierung
        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 Ist hart formatiert
                    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 = oDocObjectValue/CurrFactor
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

    ' Typ und Währungssymbol des Numberformats heraussuchen
    ' Todo: Überprüfe, ob diese beiden Zeilen nicht eleganter gehen
     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>