Option Explicit Public sProductname as String ' 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 Function ArrayfromMultiArray(MultiArray as String, iDim as Integer) Dim MaxIndex as Integer Dim i as Integer MaxIndex = Ubound(MultiArray()) Dim ResultArray(MaxIndex) as String For i = 0 To MaxIndex ResultArray(i) = MultiArray(i,iDim) Next i ArrayfromMultiArray() = ResultArray() 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