Servus Rainer,
erst einmal nachtraeglich HGW zum Mod 
Nun aber mal was anderes. Ich tipple derzeit mit VB 5.0 rum und da fehlen mir gegenüber VB6 einige Funktionen, die ich mir nach gebastelt habe. Erstaunlicherweise, sind diese imenz schneller als die von VB6 vorgegebenen Funktionen:smile: Wenn du interesse daran hast, so sage einfach bescheid und ich lasse dir dann den Quelltext zukommen.
MfG Alex
Hi Alex,
erst einmal nachtraeglich HGW zum Mod
thx
Nun aber mal was anderes. Ich tipple derzeit mit VB 5.0 rum
und da fehlen mir gegenüber VB6 einige Funktionen, die ich mir
nach gebastelt habe. Erstaunlicherweise, sind diese imenz
schneller als die von VB6 vorgegebenen Funktionen:smile: Wenn du
interesse daran hast, so sage einfach bescheid und ich lasse
dir dann den Quelltext zukommen.
klar, schneller ist immer toll! Was denn so?
Danke schon mal!
Gruß, Rainer
Hallo Rainer,
erst einmal habe ich nur die VB6 Funktionen geschrieben, die es unter VB 5 net gibt 
Ich bin am überlegen ob ich noch diverse Bit und String und Farb Functionen schreibe werde. Nur bringt das was wenn ich sie auch in meinem Project brauche, denn sonst tippel ich die umsonst.
Aber nungut hier der ganze Code. Ich erkläre es mal net weiter. Ich denke das du weisst wie du sie aufrufen musst und wozu welches modul / Klasse da ist
MfG Alex
'Modul VB5toVb6
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal lpstr As Long, ByVal ByteLen As Long)
Public Function Replace(Text As String, sOld As String, sNew As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = 2147483647, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
Dim x As ReplaceFunction
Set x = New ReplaceFunction
Replace = x.ReplaceIt(Text, sOld, sNew, Start, Count, Compare)
End Function
Public Function Reverse(Text As String) As String
Dim x As ReverseFunction
Set x = New ReverseFunction
Reverse = x.Reverse(Text)
End Function
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 x As InstrRevFunction
Set x = New InstrRevFunction
InStrRev = x.InStrRev(sCheck, sMatch, Start, Compare)
End Function
Public Sub Split(Expression$, ResultSplit$(), Optional Delimiter$ = " ")
Dim c&, SLen&, DelLen&, tmp&, Results&()
SLen = LenB(Expression) \ 2
DelLen = LenB(Delimiter) \ 2
If SLen = 0 Or DelLen = 0 Then
ReDim Preserve ResultSplit(0 To 0)
ResultSplit(0) = Expression
Exit Sub
End If
ReDim Preserve Results(0 To SLen)
tmp = InStr(Expression, Delimiter)
Do While tmp
Results(c) = tmp
c = c + 1
tmp = InStr(Results(c - 1) + 1, Expression, Delimiter)
Loop
ReDim Preserve ResultSplit(0 To c)
If c = 0 Then
ResultSplit(0) = Expression
Else
ResultSplit(0) = Left$(Expression, Results(0) - 1)
For c = 0 To c - 2
ResultSplit(c + 1) = Mid$(Expression, Results(c) + DelLen, Results(c + 1) - Results(c) - DelLen)
Next c
ResultSplit(c + 1) = Right$(Expression, SLen - Results(c) - DelLen + 1)
End If
End Sub
Public Function Join(SourceArray() As String, Optional Delimiter As String = " ", Optional ByVal Count As Long = -1) As String
Dim Lower As Long
Dim Upper As Long
Dim cbDelim As Long
Dim cbTotal As Long
Dim i As Long
Dim pCurDest As Long
Dim pDelim As Long
Dim cbCur As Long
Lower = LBound(SourceArray)
If Count = -1 Then
Upper = UBound(SourceArray)
Else
Upper = Lower + Count - 1
End If
For i = Lower To Upper
cbTotal = cbTotal + LenB(SourceArray(i))
Next i
cbDelim = LenB(Delimiter)
If cbDelim Then cbTotal = cbTotal + cbDelim \* (Upper - Lower)
CopyMemory ByVal VarPtr(Join), SysAllocStringByteLen(0, cbTotal), 4
pCurDest = StrPtr(Join)
If cbDelim = 0 Then
For i = Lower To Upper
cbCur = LenB(SourceArray(i))
CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), cbCur
pCurDest = pCurDest + cbCur
Next i
Else
pDelim = StrPtr(Delimiter)
For i = Lower To Upper - 1
cbCur = LenB(SourceArray(i))
CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), cbCur
pCurDest = pCurDest + cbCur
CopyMemory ByVal pCurDest, ByVal pDelim, cbDelim
pCurDest = pCurDest + cbDelim
Next i
CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), LenB(SourceArray(i))
End If
End Function
Public Function Round(ByRef v As Double, Optional ByVal lngDecimals As Long = 0) As Double
Dim xint As Double, yint As Double, xrest As Double
Static PreviousValue As Double
Static PreviousDecimals As Long
Static PreviousOutput As Double
Static m As Double
If m = 0 Then m = 1
If PreviousValue = v And PreviousDecimals = lngDecimals Then Round = PreviousOutput: Exit Function
If v = 0 Then Exit Function
If PreviousDecimals = lngDecimals Then
Else
PreviousDecimals = lngDecimals
m = 10 ^ lngDecimals
End If
If m = 1 Then xint = v Else xint = v \* CDec(m)
Round = Fix(xint)
If Abs(Fix(10 \* (xint - Round))) \> 4 Then
If Round \>= 0 Then
Round = Round + 1
Else
Round = Round - 1
End If
End If
If m = 1 Then Else Round = Round / m
PreviousOutput = Round
PreviousValue = v
End Function
Public Function Filter(sSourceArray() As String, sMatch As String, sTargetArray() As String, Optional bInclude As Boolean = True, Optional lCompare As VbCompareMethod = vbBinaryCompare) As Long
'Filtert Daten aus einen Array in ein Neues
'Bsp: Array mit Zahlen 1 -100
' sMatch = 10
' Ergebnis Array mit 2 Elementen (10 und 100, da dort die 10 vorkommt)
Dim lNdx As Long
Dim lLo As Long
Dim lHi As Long
Dim lLenMatch As Long
lLenMatch = Len(sMatch)
lLo = LBound(sSourceArray)
lHi = UBound(sSourceArray)
ReDim sTargetArray(lHi - lLo)
Filter = -1
If lLenMatch Then
If bInclude Then
For lNdx = lLo To lHi
If Len(sSourceArray(lNdx)) \>= lLenMatch Then
If InStr(1, sSourceArray(lNdx), sMatch, lCompare) Then
Filter = Filter + 1
sTargetArray(Filter) = sSourceArray(lNdx)
End If
End If
Next
Else
For lNdx = lLo To lHi
Select Case Len(sSourceArray(lNdx))
Case Is
'Klasse InstrRevFunction
Option Explicit
Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&:wink:
Private Header1(5) As Long
Private Header2(5) As Long
Private SafeArray1() As Integer
Private SafeArray2() As Integer
Private Declare Function CharUpperBuffW& Lib "user32" (lpsz As Any, ByVal cchLength&:wink:
Private Declare Function CharUpperBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&:wink:
Private aUChars(&H8000 To &H7FFF) As Integer
Private Sub Class\_Initialize()
Header1(0) = 1
Header1(1) = 2
Header1(4) = &H7FFFFFFF
RtlMoveMemory ByVal ArrPtr(SafeArray1), VarPtr(Header1(0)), 4
Header2(0) = 1
Header2(1) = 2
Header2(4) = &H7FFFFFFF
RtlMoveMemory ByVal ArrPtr(SafeArray2), VarPtr(Header2(0)), 4
Dim c As Long
Dim ret As Long
For c = &H8000 To &H7FFF: aUChars(c) = c: Next
If CharUpperBuffW(aUChars(-32768), &H10000) = 0 Then
ret = CharUpperBuffA(aUChars(0), 256 \* 2) '2 bytes/char
End If
aUChars(353) = 352
aUChars(339) = 338
aUChars(382) = 381
aUChars(255) = 376
End Sub
Private Sub Class\_Terminate()
RtlMoveMemory ByVal ArrPtr(SafeArray1), 0&, 4
RtlMoveMemory ByVal ArrPtr(SafeArray2), 0&, 4
End Sub
Friend Function InStrRev(ByRef sCheck As String, ByRef sMatch As String, Optional ByVal Start As Long, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
Dim lLenCheck As Long, lLenMatch As Long
Dim i As Long, j As Long, iLastMatchChar As Integer
lLenCheck = Len(sCheck)
lLenMatch = Len(sMatch)
If lLenCheck Then
If lLenMatch Then
If Start 1 Then
If Compare = vbBinaryCompare Then
iLastMatchChar = SafeArray2(lLenMatch - 1)
Do
Start = Start - 1
If SafeArray1(Start) = iLastMatchChar Then
j = lLenMatch - 1
i = Start - j
Do
j = j - 1
If SafeArray1(i + j) SafeArray2(j) Then GoTo NotEqual
Loop While j
InStrRev = i + 1
Exit Function
End If
NotEqual:
Loop Until Start aUChars(SafeArray2(j)) Then GoTo NotEqual2
Loop While j
InStrRev = i + 1
Exit Function
End If
NotEqual2:
Loop Until Start
'Klasse ReplaceFunction
Option Explicit
Private src%(), saSrc&(5)
Private Fnd%(), saFnd&(5)
Private Rep%(), saRep&(5)
Private Out%(), saOut&(5)
Private PosArr&(), UBPosArr&
Private Declare Function ArrPtr& Lib "msvbvm50.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&:wink:
Private Declare Function SysAllocStringByteLen& Lib "oleaut32" (ByVal olestr&, ByVal BLen&:wink:
Friend Function ReplaceIt(Text As String, sOld As String, sNew As String, \_
Optional ByVal Start As Long = 1, \_
Optional ByVal Count As Long = 2147483647, \_
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare \_
) As String
Dim lenSrc&, lenFnd&, LenRep&, LenOut&
Dim i&, j&, InPos&, OutPos&, CFnd&, Dist&, LCmp&, LFnd&, Fnd0%
lenSrc = Len(Text)
If lenSrc = 0 Then Exit Function
lenFnd = Len(sOld): LenRep = Len(sNew)
If lenFnd = 0 Then ReplaceIt = Text: Exit Function
saRep(3) = StrPtr(sNew)
saSrc(3) = StrPtr(Text)
saFnd(3) = StrPtr(sOld): Fnd0 = Fnd(0)
If lenFnd = LenRep Then
RtlMoveMemory ByVal VarPtr(ReplaceIt), SysAllocStringByteLen(saSrc(3), lenSrc + lenSrc), 4
saOut(3) = StrPtr(ReplaceIt)
End If
If Compare = vbBinaryCompare Then
For i = Start - 1 To lenSrc - 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then
i = i + 1
If src(i) Fnd0 Then GoTo nxt\_i
End If
End If
End If
End If
End If
End If
End If
For j = 1 To lenFnd - 1
If src(i + j) Fnd(j) Then GoTo nxt\_i
Next j
If i \>= lenSrc Then Exit For
CFnd = CFnd + 1
If lenFnd = LenRep Then
For j = 0 To LenRep - 1: Out(i + j) = Rep(j): Next j
Else
If CFnd \> UBPosArr Then
ReDim Preserve PosArr(UBPosArr + 512): UBPosArr = UBound(PosArr)
End If
PosArr(CFnd) = i
End If
If CFnd = Count Then Exit For
i = i + lenFnd - 1
nxt\_i: Next i
Else
If Fnd0 \> 64& And Fnd0 191& And Fnd0 64& And LCmp 191& And LCmp Fnd0 Then
i = i + 1: LCmp = src(i): If LCmp \> 64& And LCmp 191& And LCmp Fnd0 Then
i = i + 1: LCmp = src(i): If LCmp \> 64& And LCmp 191& And LCmp Fnd0 Then
i = i + 1: LCmp = src(i): If LCmp \> 64& And LCmp 191& And LCmp Fnd0 Then GoTo nxt\_ii
End If
End If
End If
For j = 0 To lenFnd - 1
LCmp = src(i + j): If LCmp \> 64& And LCmp 191& And LCmp 64& And LFnd 191& And LFnd LFnd Then GoTo nxt\_ii
Next j
If i \>= lenSrc Then Exit For
CFnd = CFnd + 1
If lenFnd = LenRep Then
For j = 0 To LenRep - 1: Out(i + j) = Rep(j): Next j
Else
If CFnd \> UBPosArr Then
ReDim Preserve PosArr(UBPosArr + 512): UBPosArr = UBound(PosArr)
End If
PosArr(CFnd) = i
End If
If CFnd = Count Then Exit For
i = i + lenFnd - 1
nxt\_ii: Next i
End If
If lenFnd LenRep Then
If CFnd = 0 Then
ReplaceIt = Text
Else
LenOut = lenSrc + (LenRep - lenFnd) \* CFnd
RtlMoveMemory ByVal VarPtr(ReplaceIt), SysAllocStringByteLen(0, LenOut + LenOut), 4
saOut(3) = StrPtr(ReplaceIt)
OutPos = 0: InPos = 0
For i = 1 To CFnd
Dist = PosArr(i) - InPos
If Dist \> 100 Then
RtlMoveMemory Out(OutPos), src(InPos), Dist + Dist
ElseIf Dist \> 0 Then
j = 0
Do
Out(OutPos + j) = src(InPos + j): j = j + 1: If j = Dist Then Exit Do
Out(OutPos + j) = src(InPos + j): j = j + 1: If j = Dist Then Exit Do
Out(OutPos + j) = src(InPos + j): j = j + 1: If j = Dist Then Exit Do
Out(OutPos + j) = src(InPos + j): j = j + 1: If j = Dist Then Exit Do
Loop
End If
OutPos = OutPos + Dist
InPos = PosArr(i) + lenFnd
If LenRep \> 100 Then
RtlMoveMemory Out(OutPos), Rep(0), LenRep + LenRep
ElseIf LenRep \> 0 Then
j = 0
Do
Out(OutPos + j) = Rep(j): j = j + 1: If j = LenRep Then Exit Do
Out(OutPos + j) = Rep(j): j = j + 1: If j = LenRep Then Exit Do
Out(OutPos + j) = Rep(j): j = j + 1: If j = LenRep Then Exit Do
Out(OutPos + j) = Rep(j): j = j + 1: If j = LenRep Then Exit Do
Loop
End If
OutPos = OutPos + LenRep
Next i
If (lenSrc - InPos) \> 0 Then
RtlMoveMemory Out(OutPos), src(InPos), (lenSrc - InPos) + (lenSrc - InPos)
End If
End If
End If
End Function
Private Sub Class\_Initialize()
ReDim PosArr(512): UBPosArr = UBound(PosArr)
saSrc(0) = 1: saSrc(1) = 2: saSrc(4) = 2147483647
RtlMoveMemory ByVal ArrPtr(src), VarPtr(saSrc(0)), 4
saFnd(0) = 1: saFnd(1) = 2: saFnd(4) = 2147483647
RtlMoveMemory ByVal ArrPtr(Fnd), VarPtr(saFnd(0)), 4
saRep(0) = 1: saRep(1) = 2: saRep(4) = 2147483647
RtlMoveMemory ByVal ArrPtr(Rep), VarPtr(saRep(0)), 4
saOut(0) = 1: saOut(1) = 2: saOut(4) = 2147483647
RtlMoveMemory ByVal ArrPtr(Out), VarPtr(saOut(0)), 4
End Sub
Private Sub Class\_Terminate()
RtlMoveMemory ByVal ArrPtr(src), 0&, 4
RtlMoveMemory ByVal ArrPtr(Fnd), 0&, 4
RtlMoveMemory ByVal ArrPtr(Rep), 0&, 4
RtlMoveMemory ByVal ArrPtr(Out), 0&, 4
End Sub
'Klasse ReverseFunction
Option Explicit
Private Declare Function VarPtrArray& Lib "msvbvm50.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&:wink:
Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&:wink:
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 0) As SAFEARRAYBOUND
End Type
Private m\_aIntSrc%()
Private m\_aIntDst%()
Private m\_pArrSrc&
Private m\_pArrDst&
Private m\_saSrc As SAFEARRAY1D
Private m\_saDst As SAFEARRAY1D
Private Sub Class\_Initialize()
m\_saSrc.cbElements = 2
m\_saSrc.cDims = 1
m\_saSrc.Bounds(0).cElements = &H7FFFFFFF
m\_saDst = m\_saSrc
m\_pArrSrc = VarPtrArray(m\_aIntSrc)
m\_pArrDst = VarPtrArray(m\_aIntDst)
RtlMoveMemory ByVal m\_pArrSrc, VarPtr(m\_saSrc), 4
RtlMoveMemory ByVal m\_pArrDst, VarPtr(m\_saDst), 4
End Sub
Private Sub Class\_Terminate()
RtlZeroMemory ByVal m\_pArrSrc, 4
RtlZeroMemory ByVal m\_pArrDst, 4
End Sub
Friend Function Reverse(s As String) As String
Dim iLen&, c&
iLen = Len(s)
Reverse = Space$(iLen)
m\_saSrc.pvData = StrPtr(s)
m\_saDst.pvData = StrPtr(Reverse)
iLen = iLen - 1
For c = 0 To iLen
m\_aIntDst(c) = m\_aIntSrc(iLen - c)
Next c
End Function
Hallo Alex,
danke erst mal! Das muß ich mir natürlich noch genau ansehen. Auf den ersten Blick: ‚Find‘? Im Array? So etwas gibt’s in VB6? Egal, ich verwende Dein Modul! Gefällt mir! Danke! ‚*‘ *gg’
Gruß, Rainer
vb5tovb6 vb52vb6 instrrev reverse split round
Moin,
nur ein kleiner Versuch das auch im Archiv wiederfindbar zu machen.
Gruß
Reinhard