PC World 2003 March/PCWorld_2003-03_cd.bin/Software/Vyzkuste/openoffice/f_0078/Strings.xba

Extensible Markup Language | 2001-12-18 | 14KB | 469 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="Strings" script:language="StarBasic">Option Explicit
Public sProductname as String


Sub Main()
    Msgbox Round(0.1223,2)
End Sub


' Deletes out of a String 'BigString' all possible PartStrings, that are summed up
' in the Array 'ElimArray'
Function ElimChar(ByVal BigString as String, ElimArray() as String)
Dim i% ,n%
    For i = 0 to Ubound(ElimArray)
        BigString = DeleteStr(BigString,ElimArray(i)
    Next
    ElimChar = BigString
End Function


' Deletes out of a String 'BigString' a possible Partstring 'CompString'
Function DeleteStr(ByVal BigString,CompString as String) as String
Dim i%, CompLen%, BigLen%
    CompLen = Len(CompString)
    i = 1
    While i <> 0
        i = Instr(i, BigString,CompString)
        If i <> 0 then
            BigLen = Len(BigString)
            BigString = Mid(BigString,1,i-1) + Mid(BigString,i+CompLen,BigLen-i+1-CompLen)
        End If
    Wend
    DeleteStr = BigString
End Function


' Finds a PartString, that is framed by the Strings 'Prestring' and 'PostString'
Function FindPartString(BigString, PreString, PostString as String, SearchPos as Integer) as String
Dim StartPos%, EndPos%
Dim BigLen%, PreLen%, PostLen%
    StartPos = Instr(SearchPos,BigString,PreString)
    If StartPos <> 0 Then
        PreLen = Len(PreString)
        EndPos = Instr(StartPos + PreLen,BigString,PostString)
        If EndPos <> 0 Then
            BigLen = Len(BigString)
            PostLen = Len(PostString)
            FindPartString = Mid(BigString,StartPos + PreLen, EndPos - (StartPos + PreLen))
            ' Da diese Funktion daf├╝r programmiert wurde, in einer Schleife abgearbeitet zu werden
            ' muss die initiale Suchposition hinter die Position des gefundenen Teilstrings gesetzt werden.
            SearchPos = EndPos + PostLen
        Else
            Msgbox("No final tag for '" & PreString & "' existing", 16, GetProductName())
            FindPartString = ""
        End If
    Else
        FindPartString = ""
    End If
End Function


' Note iCompare = 0 (Binary comparison)
'        iCompare = 1 (Text comparison)
Function PartStringInArray(BigArray(), SearchString as String, iCompare as Integer) as Integer
Dim MaxIndex as Integer
Dim i as Integer
    MaxIndex = Ubound(BigArray())
    For i = 0 To MaxIndex
        If Instr(1, BigArray(i), SearchString, iCompare) <> 0 Then
            PartStringInArray() = i
            Exit Function
        End If
    Next i
    PartStringInArray() = -1
End Function


' Deletes the String 'SmallString' out of the String 'BigString'
' in case SmallString's Position in BigString is right at the end
Function RTrimStr(ByVal BigString, SmallString as String) as String
Dim SmallLen as Integer
Dim BigLen as Integer
    SmallLen = Len(SmallString)
    BigLen = Len(BigString)
    If Instr(1,BigString, SmallString) <> 0 Then
        If Mid(BigString,BigLen + 1 - SmallLen, SmallLen) = SmallString Then
            RTrimStr = Mid(BigString,1,BigLen - SmallLen)
        Else
            RTrimStr = BigString
        End If
    Else
        RTrimStr = BigString
    End If
End Function


' Deletes the Char 'CompChar' out of the String 'BigString'
' in case CompChar's Position in BigString is right at the beginning
Function LTRimChar(ByVal BigString as String,CompChar as String) as String
Dim BigLen as integer
    BigLen = Len(BigString)
    If BigLen > 1 Then
        If Left(BigString,1) = CompChar then
             BigString = Mid(BigString,2,BigLen-1)
         End If
    ElseIf BigLen = 1 Then
         BigString = ""
    End If
    LTrimChar = BigString
End Function


' Retrieves an Array out of a String.
' The fields of the Array are separated by the parameter 'Separator', that is contained
' in the Array
' The Array MaxLocindex delivers the highest Index of this Array
Function ArrayOutOfString(BigString, Separator as String, Optional MaxIndex as integer)
Dim i%, OldPos%, Pos%, SepLen%, BigLen%
Dim CurUbound as Integer
Dim StartUbound as Integer
    StartUbound = 50
    Dim LocList(StartUbound) as String
    CurUbound = StartUbound
    OldPos = 1
    i = -1
    SepLen = Len(Separator)
    BigLen = Len(BigString)
    Do
        Pos = Instr(OldPos,BigString, Separator)
        i = i + 1
        If Pos = 0 Then
            LocList(i) = Mid(BigString, OldPos, BigLen - OldPos + 1 )
        Else
            LocList(i) = Mid(BigString, OldPos, Pos-OldPos )
            OldPos = Pos + SepLen
        End If
        If i = CurUbound Then
            CurUbound = CurUbound + StartUbound
            ReDim Preserve LocList(CurUbound) as String
        End If
    Loop until Pos = 0
    If Not IsMissing(Maxindex) Then
        MaxIndex = i
    End If
    If i <> -1 Then
        ReDim Preserve LocList(i) as String
    Else
        ReDim LocList() as String
    End If
    ArrayOutofString = LocList()
End Function


' Deletes all fieldvalues in one-dimensional Array
Sub ClearArray(BigArray)
Dim i as integer
    For i = Lbound(BigArray()) to Ubound(BigArray())
        BigArray(i) = ""
    Next
End Sub


' Deletes all fieldvalues in a multidimensional Array
Sub ClearMultiDimArray(BigArray,DimCount as integer)
Dim n%, m%
    For n = Lbound(BigArray(),1) to Ubound(BigArray(),1)
        For m = 0 to Dimcount - 1
            BigArray(n,m) = ""
        Next m
    Next n
End Sub


' Checks if a Field (LocField) is already defined in an Array
' Returns 'True' or 'False'
Function FieldinArray(LocArray(), MaxIndex as integer, LocField as String) As Boolean
Dim i as integer
    For i = Lbound(LocArray()) to MaxIndex
        If Ucase(LocArray(i)) = Ucase(LocField) Then
            FieldInArray = True
            Exit Function
        End if
    Next
    FieldInArray = False
End Function


' Checks if a Field (LocField) is already defined in an Array
' Returns 'True' or 'False'
Function FieldinList(LocField, BigList()) As Boolean
Dim i as integer
    For i = Lbound(BigList()) to Ubound(BigList())
        If LocField = BigList(i) Then
            FieldInList = True
            Exit Function
        End if
    Next
    FieldInList = False
End Function


' Retrieves the Index of the delivered String 'SearchString' in
' the Array LocList()'
Function IndexinArray(SearchString as String, LocList()) as Integer
Dim i as integer
    For i = Lbound(LocList(),1) to Ubound(LocList(),1)
        If Ucase(LocList(i,0)) = Ucase(SearchString) Then
            IndexinArray = i
            Exit Function
        End if
    Next
    IndexinArray = -1
End Function


Sub MultiArrayInListbox(oDialog as Object, ListboxName as String, ValList(), iDim as Integer)
Dim oListbox as Object
Dim i as integer
Dim a as Integer
    a = 0
    oListbox = oDialog.GetControl(ListboxName)
    oListbox.RemoveItems(0, oListbox.GetItemCount)
    For i = 0 to Ubound(ValList(), 1)
        If ValList(i) <> "" Then
            oListbox.AddItem(ValList(i, iDim-1), a)
            a = a + 1
        End If
    Next
End Sub


' Searches for a String in a two-dimensional Array by querying all Searchindexex of the second dimension
' and delivers the specific String of the ReturnIndex in the second dimension of the Searchlist()
Function StringInMultiArray(SearchList(), SearchString as String, SearchIndex as Integer, ReturnIndex as Integer, Optional MaxIndex as Integer) as String
Dim i as integer
Dim CurFieldString as String
    If IsMissing(MaxIndex) Then
        MaxIndex = Ubound(SearchList(),1)
    End If
    For i = Lbound(SearchList()) to MaxIndex
        CurFieldString = SearchList(i,SearchIndex)
        If  Ucase(CurFieldString) = Ucase(SearchString) Then
            StringInMultiArray() = SearchList(i,ReturnIndex)
            Exit Function
        End if
    Next
    StringInMultiArray() = ""
End Function


' Searches for a Value in multidimensial Array by querying all Searchindices of the passed dimension
' and delivers the Index where it is found.
Function GetIndexInMultiArray(SearchList(), SearchValue, SearchIndex as Integer) as Integer
Dim i as integer
Dim MaxIndex as Integer
Dim CurFieldValue
    MaxIndex = Ubound(SearchList(),1)
    For i = Lbound(SearchList()) to MaxIndex
        CurFieldValue = SearchList(i,SearchIndex)
        If CurFieldValue = SearchValue Then
            GetIndexInMultiArray() = i
            Exit Function
        End if
    Next
    GetIndexInMultiArray() = -1
End Function


' Replaces the string "OldReplace" through the String "NewReplace" in the String
' 'BigString'
Function ReplaceString(ByVal Bigstring, NewReplace, OldReplace as String)  as String
Dim i%, OldReplLen%, BigLen%

    If NewReplace <> OldReplace Then
        OldReplLen = Len(OldReplace)
        i = 1
        Do
            Biglen = Len(BigString)
            i = Instr(i,BigString,OldReplace)
            If i <> 0 then
                BigString = Mid(BigString,1,i-1) & NewReplace & Mid(BigString,i + OldReplLen,BigLen  - i + 1 - OldReplLen
                i = i + Len(NewReplace)
            End If
        Loop until i = 0
    End If
    ReplaceString = BigString
End Function


' Retrieves the second value for a next to 'SearchString' in
' a two-dimensional string-Array
Function FindSecondValue(SearchString as String, TwoDimList() as String ) as String
Dim i as Integer
    For i = 0 To Ubound(TwoDimList,1)
        If Ucase(SearchString) = Ucase(TwoDimList(i,0)) Then
            FindSecondValue = TwoDimList(i,1)
            Exit For
        End If
    Next
End Function


' raises a base to a certain power
Function Power(Basis as Double, Exponent as Double) as Double
    Power = Exp(Exponent*Log(Basis))
End Function


' rounds a Real to a given Number of Decimals
Function Round(BaseValue as Double, Decimals as Integer) as Double
Dim Multiplicator as Long
Dim DblValue#, RoundValue#
    Multiplicator = Power(10,Decimals)
    RoundValue = Int(BaseValue * Multiplicator)
    Round = RoundValue/Multiplicator
End Function


'Retrieves the mere filename out of a whole path
Function FileNameoutofPath(ByVal Path as String, Optional Separator as String) as String
Dim i as Integer
Dim SepList() as String
    If IsMissing(Separator) Then
        Path = ConvertFromUrl(Path)
        Separator = GetPathSeparator()
    End If
    SepList() = ArrayoutofString(Path, Separator,i)
    FileNameoutofPath = SepList(i)
End Function


Function GetFileNameExtension(ByVal FileName as String)
Dim MaxIndex as Integer
Dim SepList() as String
    SepList() = ArrayoutofString(FileName,".", MaxIndex)
    GetFileNameExtension = SepList(MaxIndex)
End Function


Function GetFileNameWithoutExtension(ByVal FileName as String, Optional Separator as String)
Dim MaxIndex as Integer
Dim SepList() as String
    If not IsMissing(Separator) Then
        FileName = FileNameoutofPath(FileName, Separator)
    End If
    SepList() = ArrayoutofString(FileName,".", MaxIndex)
    GetFileNameWithoutExtension = RTrimStr(FileName, "." & SepList(MaxIndex)
End Function


Function DirectoryNameoutofPath(sPath as String, Separator as String) as String
Dim LocFileName as String
    LocFileName = FileNameoutofPath(sPath, Separator)
    DirectoryNameoutofPath = RTrimStr(sPath, Separator & LocFileName)
End Function


Function CountCharsinString(BigString, LocChar as String, ByVal StartPos as Integer) as Integer
Dim LocCount%, LocPos%
    LocCount = 0
    Do
        LocPos = Instr(StartPos,BigString,LocChar)
        If LocPos <> 0 Then
            LocCount = LocCount + 1
            StartPos = LocPos+1
        End If
    Loop until LocPos = 0
    CountCharsInString = LocCount
End Function


Function BubbleSortList(ByVal SortList(),optional sort2ndValue as Boolean)
'This function bubble sorts an array of maximum 2 dimensions.
'The default sorting order is the first dimension
'Only if sort2ndValue is True the second dimension is the relevant for the sorting order
    Dim s as Integer
    Dim t as Integer
    Dim i as Integer
    Dim k as Integer
    Dim dimensions as Integer
    Dim sortvalue as Integer
    Dim DisplayDummy
    dimensions = 2

On Local Error Goto No2ndDim
    k = Ubound(SortList(),2)
    No2ndDim:
    If Err <> 0 Then dimensions = 1

    i = Ubound(SortList(),1)
    If ismissing(sort2ndValue) then
        sortvalue = 0
    else
        sortvalue = 1
    end if

    For s = 1 to i - 1
        For t = 0 to i-s
            Select Case dimensions
            Case 1
                If SortList(t) > SortList(t+1) Then
                    DisplayDummy = SortList(t)
                    SortList(t) = SortList(t+1)
                    SortList(t+1) = DisplayDummy
                End If
            Case 2
                If SortList(t,sortvalue) > SortList(t+1,sortvalue) Then
                    For k = 0 to UBound(SortList(),2)
                            DisplayDummy = SortList(t,k)
                            SortList(t,k) = SortList(t+1,k)
                            SortList(t+1,k) = DisplayDummy
                    Next k
                End If
            End Select
        Next t
    Next s
    BubbleSortList = SortList()
End Function


Function GetValueoutofList(SearchValue, BigList(), iDim as Integer, Optional ValueIndex)
Dim i as Integer
Dim MaxIndex as Integer
    MaxIndex = Ubound(BigList(),1)
    For i = 0 To MaxIndex
        If BigList(i,0) = SearchValue Then
            If Not IsMissing(ValueIndex) Then
                ValueIndex = i
            End If
            GetValueOutOfList() = BigList(i,iDim)
        End If
    Next i
End Function


Function AddListtoList(ByVal FirstArray(), ByVal SecondArray(), Optional StartIndex)
Dim n as Integer
Dim m as Integer
Dim MaxIndex as Integer
    MaxIndex = Ubound(FirstArray()) + Ubound(SecondArray()) + 1
    If MaxIndex > -1 Then
        Dim ResultArray(MaxIndex)
        For m = 0 To Ubound(FirstArray())
            ResultArray(m) = FirstArray(m)
        Next m
        For n = 0 To Ubound(SecondArray())
            ResultArray(m) = SecondArray(n)
            m = m + 1
        Next n
        AddListToList() = ResultArray()
    Else
        Dim NullArray()
        AddListToList() = NullArray()
    End If
End Function


Function CheckDouble(DoubleString as String)
On Local Error Goto WRONGDATATYPE
    CheckDouble() = CDbl(DoubleString)
WRONGDATATYPE:
    If Err <> 0 Then
        CheckDouble() = 0
        Resume NoErr:
    End If
NOERR:
End Function</script:module>