home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Freelog 125
/
Freelog_MarsAvril2015_No125.iso
/
Bureautique
/
OpenOffice
/
Apache_OpenOffice_4.1.1_Win_x86_install_fr.exe
/
openoffice1.cab
/
Soft.xba
< prev
next >
Wrap
Extensible Markup Language
|
2014-02-25
|
10KB
|
260 lines
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<!--***********************************************************
*
* 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
*
* Unless required by applicable law or agreed to in writing,
* software distributed under the License is distributed on an
* "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
* KIND, either express or implied. See the License for the
* specific language governing permissions and limitations
* under the License.
*
***********************************************************-->
<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>