Quelle  Soft.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<!--
 * This file is part of the LibreOffice project.
 *
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 *
 * This file incorporates work covered by the following license notice:
 *
 *   Licensed to the Apache Software Foundation (ASF) under one or more
 *   contributor license agreements. See the NOTICE file distributed
 *   with this work for additional information regarding copyright
 *   ownership. The ASF licenses this file to you under the Apache
 *   License, Version 2.0 (the "License"); you may not use this file
 *   except in compliance with the License. You may obtain a copy of
 *   the License at http://www.apache.org/licenses/LICENSE-2.0 .
-->
<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
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
 SetStatusLineText(sStsRELRANGES)
 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    


' deletes a styletemplate from the Collection that selects the ranges
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


' creates a sheet object from an according sectionname
Function RetrieveSheetoutofRangeName(TableText as String)   
Dim DescriptionList() as String
Dim SheetName as String
Dim MaxIndex as integer
 ' find out in which sheet the range is
 DescriptionList() = ArrayOutofString(TableText,".",MaxIndex)
 SheetName = DescriptionList(0)
 SheetName = DeleteStr(SheetName,"'")
 ' set the viewcursor on this sheet
 RetrieveSheetoutofRangeName = oSheets.GetbyName(SheetName)
End Function


' creates a rangeobject from an according rangename
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 is hard formatted
    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)
  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>