PC World 2002 May/PCWorld_2002-05_cd.bin/Akce/install/f_0266/Soft.xba

Extensible Markup Language | 2002-02-19 | 9.2 KB | 240 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="Soft" script:language="StarBasic">Option Explicit
REM  *****  BASIC  *****


Sub CreateStyleEnumeration()
    EmptySelection()
    EmptyListbox(DialogModel.lstSelection)
    CurSheetName = oDocument.CurrentController.GetActiveSheet.Name
    MakeStyleEnumeration(False)
    DialogModel.lblSelection.Label = sTEMPLATES                ' "Vorlagen:"
End Sub


Sub MakeStyleEnumeration(bAddToListbox as Boolean)
Dim m as integer
Dim aStyleFormat as Object
Dim Stylename as String
     StyleIndex = -1
    oStyles = oDocument.StyleFamilies.GetbyIndex(0)
    For m = 0 To oStyles.count-1
        oStyle = oStyles.GetbyIndex(m)
        StyleName = oStyle.Name
        If CheckFormatType(oStyle) Then
            If Not bAddToListBox Then
                AddSingleItemToListbox(DialogModel.lstSelection, Stylename)
            Else
                SwitchNumberFormat(ostyle, oFormats, sEuroSign)
            End If
            StyleIndex = StyleIndex + 1
            If StyleIndex > Ubound(StyleRangeAssignMentList()) Then
                Redim Preserve StyleRangeAssignmentList(StyleIndex)
            End If
            StyleRangeAssignmentList(StyleIndex) =     "<STYLENAME>" & Stylename & "</STYLENAME>" & _
                                                    "<DEFINED>FALSE</DEFINED>" & "<RANGES></RANGES>" &_
                                                    "<CELLCOUNT>0</CELLCOUNT>" &_
                                                    "<SELECTED>FALSE</SELECTED>"
        End If
    Next m
    If StyleIndex > -1 Then
        Redim Preserve StyleRangeAssignmentList(StyleIndex)
    Else
        ReDim StyleRangeAssignmentList()
    End If
End Sub


Sub AssignRangestoStyle(StyleList(), SelList())
Dim i as Integer
Dim n as integer
Dim LastIndex as Integer
Dim CurStyleName as String
Dim AssignString as String
    LastIndex = Ubound(StyleList())
    StatusValue = 0
    oStatusLine.SetText(sStsRELRANGES)       '"Erfassung der relevanten Bereiche..."
    For i = 0 To LastIndex
        CurStyleName = StyleList(i)
        n = PartStringInArray(StyleRangeAssignmentList(), CurStyleName, 0)
        AssignString = StyleRangeAssignmentlist(n)
        If IndexInArray(CurStyleName, SelList()) <> -1 Then
            ' Style is selected
            If FindPartString(AssignString, "<DEFINED>", "</DEFINED>", 1) = "FALSE" Then
                AssignString = ReplaceString(AssignString, "<SELECTED>TRUE</SELECTED>", "<SELECTED>FALSE</SELECTED>")
                AssignCellFormatRanges(n, AssignString, CurStyleName)
            End If
        Else
            ' Style is not selected
            If FindPartString(AssignString, "<SELECTED>", "</SELECTED>", 1) = "FALSE" Then
                DeselectStyle(CurStyleName, n)
            End If
        End If
        IncreaseStatusvalue(SBRELGET/(LastIndex+1))
    Next i
End Sub


Sub AssignCellFormatRanges(n as Integer, AssignString as String, CurStyleName as String)
Dim oRanges() as Object
Dim oRange as Object
Dim oRangeAddress
Dim oSheet as Object
Dim StyleCellCount as Long
Dim i as Integer
Dim MaxIndex as Integer
Dim RangeString as String
Dim SheetName as String
Dim RangeName as String
Dim CellCountString as String
    StyleCellCount = 0
    RangeString = "<RANGES>"
    MaxIndex = oSheets.Count-1
    For i = 0 To MaxIndex
        oSheet = oSheets(i)
        SheetName = oSheet.Name
        oRanges = osheet.CellFormatRanges.CreateEnumeration
        While oRanges.hasMoreElements
            oRange = oRanges.NextElement
            If oRange.getPropertyState("NumberFormat") = 1 Then
                If oRange.CellStyle = CurStyleName Then
                    oRangeAddress = oRange.RangeAddress
                    RangeName = RetrieveRangeNamefromAddress(oRange)
                    RangeString = RangeString & RangeName & ","
                    StyleCellCount = StyleCellCount + CountRangeCells(oRange)
                End If
            End If
        Wend
    Next i
    If StyleCellCount > 0 Then
        TotCellCount = TotCellCount + StyleCellCount
        RangeString = RTrimStr(RangeString,",")
        RangeString = RangeString & "</RANGES>"
        CellCountString = "<CELLCOUNT>" & StyleCellCount & "</CELLCOUNT"
        AssignString = ReplaceString(AssignString, RangeString,"<RANGES></RANGES>")
        AssignString = ReplaceString(AssignString, CellCountString,"<CELLCOUNT>0</CELLCOUNT>")
    End If
    AssignString = ReplaceString(AssignString, "<DEFINED>TRUE</DEFINED>", "<DEFINED>FALSE</DEFINED>")
    StyleRangeAssignmentList(n)    = AssignString
End Sub


' l├╢scht eine Stilvorlage aus der Kollektion, die die Ranges selektiert
Sub DeselectStyle(DeSelStyleName as String, n as Integer)
Dim i as Integer
Dim RangeName as String
Dim SelectString as String
Dim AssignString as String
Dim StyleRangeList() as String
Dim MaxIndex as Integer
    SelectString ="<SELECTED>FALSE</SELECTED>"
    AssignString = StyleRangeAssignmentList(n)
    RangeString = FindPartString(AssignString,"<RANGES>","</RANGES>",1)
    StyleRangeList() = ArrayoutofString(RangeString,",")
    MaxIndex = Ubound(StyleRangeList())
    For i = 0 To MaxIndex
        RangeName = StyleRangeList(i)
        If oSelRanges.HasbyName(RangeName) Then
            oSelRanges.RemovebyName(RangeName)
        End If
    Next i
    AssignString = ReplaceString(AssignString, "<SELECTED>FALSE</SELECTED>", "<SELECTED>TRUE</SELECTED>")
    StyleRangeAssignmentList(n) = AssignString
End Sub


Function RetrieveRangeNamefromAddress(oRange as Object) as String
Dim Rangename as String
Dim oAddressRanges as Object
    oAddressRanges = oDocument.createInstance("com.sun.star.sheet.SheetCellRanges")
    oAddressRanges.InsertbyName("",oRange)
    Rangename = oAddressRanges.RangeAddressesasString
'    Msgbox "Adresse: " & oRangeAddress.StartColumn & " ; " & oRangeAddress.EndColumn & " ; " & oRangeAddress.StartRow & " ; " & oRangeAddress.EndRow & chr(13) & RangeName
'    oAddressRanges.RemovebyName(RangeName)
    RetrieveRangeNamefromAddress = Rangename
End Function


' Erzeugt eine Sheetobjekt aus einem entsprechenden Bereichsnamen
Function RetrieveSheetoutofRangeName(TableText as String)
Dim DescriptionList() as String
Dim SheetName as String
Dim MaxIndex as integer
    ' Herausfinden, in welchem Sheet sich der Range befindet
    DescriptionList() = ArrayOutofString(TableText,".",MaxIndex)
    SheetName = DescriptionList(0)
    SheetName = DeleteStr(SheetName,"'")
    ' Und den ViewCursor auf dieses Sheet setzen
    RetrieveSheetoutofRangeName = oSheets.GetbyName(SheetName)
End Function


' Erzeugt eine Rangeobjekt aus einem entsprechenden Bereichsnamen
Function RetrieveRangeoutofRangeName(TableText as String)
    oSheet = RetrieveSheetoutofRangeName(TableText)
    oRange = oSheet.GetCellRangebyName(TableText)
    RetrieveRangeoutofRangeName = oRange
End Function


Sub ConvertTheSoftWay(StyleList(), bDeSelect as Boolean)
Dim i as Integer
Dim l as Integer
Dim s as Integer
Dim n as Integer
Dim CurStyleName as String
Dim RangeName as String
Dim OldStatusValue as Integer
Dim LastIndex as Integer
Dim oSelListbox as Object
Dim StyleRangeList() as String
Dim MaxIndex as Integer
    oSelListbox = DialogConvert.GetControl("lstSelection")
    LastIndex = Ubound(StyleList())
    OldStatusValue = StatusValue
    For i = 0 To LastIndex
        CurStyleName = StyleList(i)
        oStyle = oStyles.GetbyName(CurStyleName)
        StyleRangeList() = GetAssignedRanges(CurStyleName, n)
        MaxIndex = Ubound(StyleRangeList())
        For s = 0 To MaxIndex
            RangeName = StyleRangeList(s)
            oRange = RetrieveRangeoutofRangeName(RangeName)
            If oRange.getPropertyState("NumberFormat") = 1 Then
                ' Range Ist hart formatiert
                ConvertCellCurrencies(oRange)
                CurCellCount = CountRangeCells(oRange)
            End If
            IncreaseStatusvalue((CurCellCount/TotCellCount)*(95-OldStatusValue))
            If bDeSelect Then
                ' Note: On Problems see Bug #73157
                If oSelRanges.HasbyName(RangeName) Then
                    oSelRanges.RemovebyName(RangeName)
                    oDocument.CurrentController.Select(oSelRanges)
                End If
            End If
        Next s
        SwitchNumberFormat(ostyle, oFormats, sEuroSign)
'        oStatusline.SetValue(100)
        StyleRangeAssignmentList(n) = ""
        l = GetItemPos(oSelListBox.Model, CurStyleName)
        oSelListbox.RemoveItems(l,1)
    Next
End Sub


Function GetAssignedRanges(CurStyleName as String, n as Integer)
Dim StyleRangeList() as String
Dim RangeString as String
Dim AssignString as String
    n = PartStringInArray(StyleRangeAssignmentList(), CurStyleName, 0)
    If n <> -1 Then
        AssignString = StyleRangeAssignmentList(n)
        RangeString = FindPartString(AssignString,"<RANGES>", "</RANGES>",1)
        If RangeString <> "" Then
            StyleRangeList() = ArrayoutofString(RangeString,",")
        End If
    End If
    GetAssignedRanges() = StyleRangeList()
End Function</script:module>