Hallo,
da ich hier immer mehr mitbekomme, das hier nach Funktionen gefragt wird die in VB6 vorhanden sind und in den Vorgaenger Versionen nicht, so poste ich hier mal die gaengigsten.
Am besten diese alle in ein Modul packen und dann nur das Modul einbinden und schon stehen einen die Funktionen auch zur Verfügung 
@ Rainer, hatte ich das nicht schon einmal gepostet *gruebel* ?
Option Explicit
Private Declare Function ArrPtr Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, source As Any, ByVal Bytes As Long)
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" (ByVal Addr As Long, Value As Long, Optional ByVal Bytes As Long = 4)
Public Const cLetters = "abcdefghijklmnopqrstuvwxyz"
Public Const cNumbers = "0123456789"
Public Const cWhiteSpaces = " " & vbCr & vbLf & vbTab
'Split Funktion, doppelt so schnell wie die unter VBB6
Public Function Split(ByRef Expression As String, Optional ByRef Delimiter As String = " ", Optional ByVal Count As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant 'VB6: As String()
Dim DelimiterLen As Long
Dim Index As Long
Dim Start As Long
Dim Strings() As String
Dim StringsCount As Long
Dim StringsUBound As Long
Dim StringsPtr As Long
If Count And Len(Expression) \> 0 Then
DelimiterLen = Len(Delimiter)
If DelimiterLen Then
If Count StringsUBound Then
StringsUBound = StringsCount \* 2
ReDim Preserve Strings(StringsUBound)
End If
Index = InStr(Start, Expression, Delimiter, Compare)
If Index = 0 Then Exit For
Strings(StringsCount) = \_
Mid$(Expression, Start, Index - Start)
Start = Index + DelimiterLen
Next StringsCount
Strings(StringsCount) = Mid$(Expression, Start)
If StringsCount FindAsc(i) Then Exit For
Next i
If i \> FindLen Then
StrCount = StrCount + 1
Start = Start + FindLen
End If
End If
End If
Next Start
End Select
RtlMoveMemory ByVal TextPtr, TextData, 4 'pvData
RtlMoveMemory ByVal TextPtr + 4, 1&, 4 'nElements
Else
FindLen = FindLen + FindLen
Start = InStrB(Start + FindLen, Text, Find)
Do While Start
StrCount = StrCount + 1
Start = InStrB(Start + FindLen, Text, Find)
Loop
End If
End If
End If
Else
StrCount = StrCount(LCase$(Text), LCase$(Find), Start)
End If
End Function
'Equal Funktion
Public Function StrEqual(ByRef s1 As String, ByRef s2 As String, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Boolean
If LenB(s1) = LenB(s2) Then
If Compare = vbBinaryCompare Then
If LenB(s1) Then
StrEqual = InStrB(1, s1, s2)
Else
StrEqual = True
End If
Else
StrEqual = StrComp(s1, s2, Compare) = 0
End If
End If
End Function
'Einen String auf (un)gültige Zeichen zu untersuchen
Public Function Filter(ByVal Text As String, ByVal Chars As String, Optional ByVal PassThru As Boolean = False, Optional ByVal Compare As VbCompareMethod = vbTextCompare) As String
Dim i As Long
If PassThru Then
For i = 1 To Len(Text)
If InStr(1, Chars, Mid$(Text, i, 1), Compare) Then
Filter = Filter & Mid$(Text, i, 1)
End If
Next i
Else
For i = 1 To Len(Text)
If InStr(1, Chars, Mid$(Text, i, 1), Compare) = 0 Then
Filter = Filter & Mid$(Text, i, 1)
End If
Next i
End If
End Function
'Instr mit Pattern
Public Function InStrLike(ByVal Text As String, ByVal Pattern As String, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
Dim Index As Long
If Len(Pattern) Then
If Compare = vbTextCompare Then
Text = LCase$(Text)
Pattern = LCase$(Pattern)
End If
Pattern = Pattern & "\*"
InStrLike = InStrLikeRev(Text, Pattern)
For Index = 1 To InStrLike - 1
If Mid$(Text, Index) Like Pattern Then
'Treffer:
InStrLike = Index
Exit Function
End If
Next Index
End If
End Function
'instr mit Pattern -\> Rueckwaerts
Public Function InStrLikeRev(ByVal Text As String, ByVal Pattern As String, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
Dim MinPos As Long
Dim MaxPos As Long
Dim Pivot As Long
If Len(Pattern) Then
If Compare = vbTextCompare Then
Text = LCase$(Text)
Pattern = LCase$(Pattern)
End If
Pattern = "\*" & Pattern & "\*"
MinPos = 1
MaxPos = Len(Text)
Do Until MinPos \> MaxPos
Pivot = (MinPos + MaxPos) \ 2
If Mid$(Text, Pivot) Like Pattern Then
InStrLikeRev = Pivot
MinPos = Pivot + 1
Else
MaxPos = Pivot - 1
End If
Loop
End If
End Function
'Instr Funktion VB6 -\> Rueckwaerts
Public Function InStrRev(ByRef sCheck As String, ByRef sMatch As String, Optional ByVal Start As Long, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
Dim Stopp As Long
Dim Index As Long
Dim Pivot As Long
Dim Length As Long
Dim LengthPtr As Long
Dim MatchLen As Long
If Compare = vbBinaryCompare Then
MatchLen = LenB(sMatch) - 1
If MatchLen \> -1 Then
Stopp = InStrB(sCheck, sMatch)
If Stopp = 0 Then Exit Function
Length = LenB(sCheck)
If Start Start Then Exit Function
LengthPtr = StrPtr(sCheck) - 4
PokeLng LengthPtr, Start + MatchLen
End If
InStrRev = Stopp
Stopp = Stopp + 2
Do
Pivot = (Stopp + Start) \ 2
Index = InStrB(Pivot, sCheck, sMatch)
If Index Then
InStrRev = Index
If Index \>= Start Then
PokeLng LengthPtr, Length
InStrRev = InStrRev \ 2 + 1
Exit Function
End If
Stopp = Index + 2
Else
If Stopp + 8 \>= Pivot Then Exit Do
Start = Pivot - 1
PokeLng LengthPtr, Start + MatchLen
End If
Loop
Index = InStrB(Stopp, sCheck, sMatch)
Do While Index
InStrRev = Index
Index = InStrB(Index + 2, sCheck, sMatch)
Loop
InStrRev = InStrRev \ 2 + 1
PokeLng LengthPtr, Length
Else
If Start "ß" Then IsWordSep = True
End If
End If
End Function
'Feststellen ob ein optionaler Parameter angegeben wurde oder Abbrechen bei einer Input Box gedrueckt wurde
Function IsNullString(ByRef aString As String) As Boolean
IsNullString = CBool(StrPtr(aString) = 0)
End Function
'Join Funktion
Public Function Join(ByRef sArray() As String, Optional ByRef Delimiter As String = " ") As String
Dim JoinLen As Long
Dim JoinPtr As Long
Dim DelimiterLen As Long
Dim LB As Long
Dim UB As Long
Dim i As Long
LB = LBound(sArray)
UB = UBound(sArray)
For i = LB To UB
JoinLen = JoinLen + LenB(sArray(i))
Next i
JoinPtr = 1
DelimiterLen = LenB(Delimiter)
If DelimiterLen Then
JoinLen = JoinLen + DelimiterLen \* (UB - LB)
Join = Space$(JoinLen \ 2)
For i = LB To UB - 1
MidB$(Join, JoinPtr) = sArray(i)
JoinPtr = JoinPtr + LenB(sArray(i))
MidB$(Join, JoinPtr) = Delimiter
JoinPtr = JoinPtr + DelimiterLen
Next i
MidB$(Join, JoinPtr) = sArray(i)
Else
Join = Space$(JoinLen \ 2)
For i = LB To UB
MidB$(Join, JoinPtr) = sArray(i)
JoinPtr = JoinPtr + LenB(sArray(i))
Next i
End If
End Function
'Repeat Funktion, imenz schneller da wir ein wenig tricksen
Function StrRepeat(ByVal nCount As Long, ByRef sText As String) As String
If nCount 1 Then
StrRepeat = Space$(Len(sText) \* nCount)
Mid$(StrRepeat, 1) = sText
If nCount \> 1 Then Mid$(StrRepeat, Len(sText) + 1) = StrRepeat
Else
StrRepeat = String$(nCount, sText)
End If
End Function
'Replace Funktion, als Sub. Keine Zuweisung nötig!
'Bsp.
'Dim txt As String
'StrReplaceSub(txt, "n", "M")
Public Sub StrReplaceSub(ByRef Text As String, ByRef sOld As String, ByRef sNew As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = 2147483647, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)
If LenB(sOld) = 0 Then
'nix machen
ElseIf ContainsOnly0(sOld) Then
ReplaceBin0 Text, Text, Text, sOld, sNew, Start, Count
ElseIf Compare = vbBinaryCompare Then
If InStr(Start, Text, sOld, vbBinaryCompare) Then \_
ReplaceBin Text, Text, Text, sOld, sNew, Start, Count
Else
If InStr(Start, Text, sOld, vbTextCompare) Then \_
ReplaceBin Text, Text, LCase$(Text), LCase$(sOld), sNew, Start, Count
End If
End Sub
'Replace Function, als Function. Zuweisung nötig!
'Bsp.
'Dim txt As String
'Dim vRet As String
'vRet = StrReplaceFunction(a, "n", "M", Compare:=vbTextCompare)
Public Function StrReplaceFunction(ByRef Text As String, ByRef sOld As String, ByRef sNew As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = 2147483647, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
If LenB(sOld) = 0 Then
StrReplaceFunction = Text
ElseIf ContainsOnly0(sOld) Then
ReplaceBin0 StrReplaceFunction, Text, Text, sOld, sNew, Start, Count
ElseIf Compare = vbBinaryCompare Then
ReplaceBin StrReplaceFunction, Text, Text, sOld, sNew, Start, Count
Else
ReplaceBin StrReplaceFunction, Text, LCase$(Text), LCase$(sOld), sNew, Start, Count
End If
End Function
'Hilfsfunktion
Private Function ContainsOnly0(ByRef s As String) As Boolean
Dim i As Long
For i = 1 To Len(s)
If Asc(Mid$(s, i, 1)) Then Exit Function
Next i
ContainsOnly0 = True
End Function
'Hilfsfunktion
Private Static Sub ReplaceBin(ByRef Result As String, ByRef Text As String, ByRef Search As String, ByRef sOld As String, ByRef sNew As String, ByVal Start As Long, ByVal Count As Long)
Dim TextLen As Long
Dim OldLen As Long
Dim NewLen As Long
Dim ReadPos As Long
Dim WritePos As Long
Dim CopyLen As Long
Dim Buffer As String
Dim BufferLen As Long
Dim BufferPosNew As Long
Dim BufferPosNext As Long
If Start BufferLen Then
Buffer = Text
BufferLen = TextLen
End If
ReadPos = 1
WritePos = 1
If NewLen Then
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(Buffer, BufferPosNew) = sNew
WritePos = BufferPosNew + NewLen
Else
MidB$(Buffer, WritePos) = sNew
WritePos = WritePos + NewLen
End If
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
Else
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
WritePos = WritePos + CopyLen
End If
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
End If
If ReadPos \> TextLen Then
Result = LeftB$(Buffer, WritePos - 1)
Else
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
Result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
End If
Exit Sub
Case Else
TextLen = LenB(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew \> BufferLen Then
Buffer = Space$(BufferPosNew)
BufferLen = LenB(Buffer)
End If
ReadPos = 1
WritePos = 1
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
If BufferPosNext \> BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(Buffer, BufferPosNew) = sNew
Else
BufferPosNext = WritePos + NewLen
If BufferPosNext \> BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
MidB$(Buffer, WritePos) = sNew
End If
WritePos = BufferPosNext
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
If ReadPos \> TextLen Then
Result = LeftB$(Buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext BufferLen Then
Buffer = Text
BufferLen = TextLen
End If
ReadPos = 1
WritePos = 1
If NewLen Then
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
Mid$(Buffer, BufferPosNew) = sNew
WritePos = BufferPosNew + NewLen
Else
Mid$(Buffer, WritePos) = sNew
WritePos = WritePos + NewLen
End If
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
Else
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
WritePos = WritePos + CopyLen
End If
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
End If
If ReadPos \> TextLen Then
Result = Left$(Buffer, WritePos - 1)
Else
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos)
Result = Left$(Buffer, WritePos + Len(Text) - ReadPos)
End If
Exit Sub
Case Else
TextLen = Len(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew \> BufferLen Then
Buffer = Space$(BufferPosNew)
BufferLen = Len(Buffer)
End If
ReadPos = 1
WritePos = 1
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
If BufferPosNext \> BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = Len(Buffer)
End If
Mid$(Buffer, WritePos) = Mid$(Text, ReadPos, CopyLen)
Mid$(Buffer, BufferPosNew) = sNew
Else
BufferPosNext = WritePos + NewLen
If BufferPosNext \> BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = Len(Buffer)
End If
Mid$(Buffer, WritePos) = sNew
End If
WritePos = BufferPosNext
ReadPos = Start + OldLen
Start = InStr(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
If ReadPos \> TextLen Then
Result = Left$(Buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext vbKeySpace Then Exit For
Next iStart
For iEnde = Len(Text) To iStart + 1 Step -1
If Asc(Mid$(Text, iEnde, 1)) \> vbKeySpace Then Exit For
Next iEnde
TrimWS = Mid$(Text, iStart, iEnde - iStart + 1)
End Function
MfG Alex
