?? misc.bas
字號:
GetInfo = Replace(strValue, " ", "")
Exit Function
error:
GetInfo = ""
End Function
'Returns the Line that contains a String (reversed for speed reasons)*
Public Function RevfindLine(SearchStr As String, ByRef strlines() As String) As Long
Dim Counter As Long
Dim TmpLngt As Long
Dim TmpString As String
On Error GoTo error
TmpLngt = UBound(strlines)
Counter = TmpLngt
Do
Counter = Counter - 1
TmpString = strlines(Counter + 1)
If InStr(TmpString, SearchStr) > 0 Then
RevfindLine = Counter + 1
Exit Function
End If
Loop Until Counter = 0
error:
RevfindLine = -1
End Function
'Checks if a string contains a special seperated word
Public Function InStrWord( _
ByRef Text As String, _
ByRef Word As String _
) As Long
'Deklarationen:
Dim WordLen As Long
Dim TextEnd As Long
Dim OK As Boolean
WordLen = Len(Word)
If WordLen = 0 Then
Exit Function
End If
TextEnd = Len(Text) - WordLen + 1
InStrWord = InStr(1, Text, Word, vbTextCompare)
Do While InStrWord
If InStrWord = 1 Then
OK = True
Else
OK = IsWordSep(Mid$(Text, InStrWord - 1, 1))
End If
'Ggf. Zeichen hinter dem Wort checken:
If OK And (InStrWord < TextEnd) Then
OK = IsWordSep(Mid$(Text, InStrWord + WordLen, 1))
End If
'Treffer zur點kgeben oder weitersuchen:
If OK Then
Exit Do
End If
InStrWord = InStr(InStrWord + WordLen, Text, Word, vbTextCompare)
Loop
End Function
'Returns true if a char is a known seperator
Public Function IsWordSep(ByVal Char As String) As Boolean
If Char = " " Or Char = vbCr Or Char = vbLf Or Char = vbTab Or Char = Chr$(34) Or Char = vbCrLf Or Char = "-" Then
IsWordSep = True
End If
End Function
'**************************************************************************************
'Replace function
'
'Author: unknown
'
'Desc:
'
'this functions are a lot faster than the original functions and usefull
'for VB5 User
''**************************************************************************************
Public Function Replace(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) Then
If Compare = vbBinaryCompare Then
ReplaceBin Replace, Text, Text, _
sOld, sNew, Start, Count
Else
ReplaceBin Replace, Text, LCase$(Text), _
LCase$(sOld), sNew, Start, Count
End If
Else 'Suchstring ist leer:
Replace = Text
End If
End Function
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
'Ersten Treffer bestimmen:
If Start < 2 Then
Start = InStrB(Search, sOld)
Else
Start = InStrB(Start + Start - 1, Search, sOld)
End If
If Start Then
OldLen = LenB(sOld)
NewLen = LenB(sNew)
Select Case NewLen
Case OldLen 'einfaches 躡erschreiben:
Result = Text
For Count = 1 To Count
MidB$(Result, Start) = sNew
Start = InStrB(Start + OldLen, Search, sOld)
If Start = 0 Then
Exit Sub
End If
Next Count
Exit Sub
Case Is < OldLen 'Ergebnis wird k黵zer:
'Buffer initialisieren:
TextLen = LenB(Text)
If TextLen > BufferLen Then
Buffer = Text
BufferLen = TextLen
End If
'Ersetzen:
ReadPos = 1
WritePos = 1
If NewLen Then
'Einzuf黦enden Text beachten:
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
End If
Next Count
Else
'Einzuf黦enden Text ignorieren (weil leer):
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
End If
Next Count
End If
'Ergebnis zusammenbauen:
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 'Ergebnis wird l鋘ger:
'Buffer initialisieren:
TextLen = LenB(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew > BufferLen Then
Buffer = Space$(BufferPosNew)
BufferLen = LenB(Buffer)
End If
'Ersetzung:
ReadPos = 1
WritePos = 1
For Count = 1 To Count
CopyLen = Start - ReadPos
If CopyLen Then
'Positionen berechnen:
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
'Ggf. Buffer vergr鲞ern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
'String "patchen":
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(Buffer, BufferPosNew) = sNew
Else
'Position bestimmen:
BufferPosNext = WritePos + NewLen
'Ggf. Buffer vergr鲞ern:
If BufferPosNext > BufferLen Then
Buffer = Buffer & Space$(BufferPosNext)
BufferLen = LenB(Buffer)
End If
'String "patchen":
MidB$(Buffer, WritePos) = sNew
End If
WritePos = BufferPosNext
ReadPos = Start + OldLen
Start = InStrB(ReadPos, Search, sOld)
If Start = 0 Then Exit For
Next Count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
Result = LeftB$(Buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext < BufferLen Then
MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
Result = LeftB$(Buffer, BufferPosNext)
Else
Result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
End If
End If
Exit Sub
End Select
Else
Result = Text
End If
End Sub
Public Sub MoveStringArray(Source() As String, dest() As String, firstEl As Long, lastEL As Long)
Dim numBytes As Long
On Error GoTo error
numBytes = (lastEL - firstEl + 1) * 4
' start with a fresh new array
'(it clears all its descriptors)
ReDim dest(0 To lastEL - firstEl) As String
' copy all the descriptors from source() to dest()
CopyMemory ByVal VarPtr(dest(0)), _
ByVal VarPtr(Source(firstEl)), numBytes
' manually clear all the descriptors in source()
ZeroMemory ByVal VarPtr(Source(firstEl)), numBytes
error:
End Sub
':) Ulli's VB Code Formatter V2.12.7 (19.06.2002 23:13:06) 48 + 401 = 449 Lines
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -