我更据别人的代码修改的查找符合要求的字符串(功能能实现),但自己觉得写得太乱,还请哪位高手帮助修改一下,谢谢!!!如:a="clos" b="SUM(IF(CLOSE>REF(CLOSE,1),VOL,IF(CLOS<REF(CLOSE,1),-VOL,0)),0)"
如b里含有a(如close,cclos都不算含有)则strtrue=True,否则为strtrue=False
Private Type mMatch
FirstIndex As Long
Length As Long
Value As String
End TypePrivate Sub Command1_Click()
Dim s, sa As String
s = "clos"
sa = "SUM(IF(CLOSE>REF(CLOSE,1),VOL,IF(CLOSE<REF(CLOSE,1),-VOL,0)),0)"
MsgBox strtrue(s, sa)
End Sub
Private Function strtrue(ByVal sPattern As String, sText As String) As Boolean
Dim i As Long
Dim p() As mMatch
Dim str1 As String
Dim p1() As String
Dim a As String
a = ",+-*/\;()=:<>"
p = RunRegExp(sPattern, sText)
For i = 1 To UBound(p)
DoEvents
ReDim Preserve p1(1 To i)
With p(i)
p1(i) = .FirstIndex
End With
Next
If UBound(p1) > 1 Then
For i = 1 To UBound(p1)
If p1(i) = 0 Then
If ValidateString(a, "", Mid(sText, p1(i) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Exit For
End If
Else
If ValidateString(a, Mid(sText, p1(i), 1), Mid(sText, p1(i) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Exit For
Else
strtrue = False
End If
End If
Next
Else
If p1(1) = 0 Then
If ValidateString(a, "", Mid(sText, p1(1) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Else
strtrue = False
End If
Else
If ValidateString(a, Mid(sText, p1(1), 1), Mid(sText, p1(1) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Else
strtrue = False
End If
End If
End If
Erase p
Erase p1
End Function
Private Function RunRegExp(ByVal sPattern As String, sText As String) As mMatch()
Dim objRegExp As Object
Dim colMatches As Object
Dim pMatch() As mMatch
Dim p() As String
Dim pPattern() As String
Dim i As Long
ReDim pMatch(0)
pPattern = Split("")
p = Split(sPattern, "(?<=")
For i = 0 To UBound(p)
If i = 0 Then
If Len(p(0)) > 0 And UBound(p) > 0 Then
ReDim Preserve pPattern(UBound(pPattern) + 1)
pPattern(UBound(pPattern)) = str1
End If
sPattern = p(0)
Else
If Right$(p(i - 1), 1) = "\" Then
sPattern = sPattern & "(?<=" & p(i) Else
k = 0
str1 = ""
Do
k = k + 1
If Mid$(p(i), k, 1) = ")" Then
If k = 1 Then
str1 = Left$(p(i), k)
Else
str1 = Left$(p(i), k - 1)
End If
sPattern = sPattern & str1 & Right$(p(i), Len(p(i)) - k)
ReDim Preserve pPattern(UBound(pPattern) + 1)
pPattern(UBound(pPattern)) = str1 Exit Do
End If
Loop Until k > Len(p(i))
End If
End If
Next
Set objRegExp = CreateObject("VBscript.RegExp")
With objRegExp
.Pattern = sPattern
.Global = True
.IgnoreCase = True
On Error GoTo err1
If (.Test(sText) = True) Then
Set colMatches = .Execute(sText)
k = 0
For i = 0 To colMatches.Count - 1
ReDim Preserve pMatch(UBound(pMatch) + 1)
With pMatch(UBound(pMatch))
.Value = colMatches(i).Value
.FirstIndex = colMatches(i).FirstIndex + Len(colMatches(i).Value) - Len(.Value)
End With
Next End If
End With
err1:
RunRegExp = pMatch
Set objRegExp = Nothing
Set colMatches = Nothing
Erase p
Erase pPattern
End FunctionPrivate Function ValidateString(strPatternIn As String, strContent As String, strContent1 As String) As Boolean
If Trim(strContent) = "" And Trim(strContent1) = "" Then
ValidateString = True
Else
If ValidateString1(strContent, strPatternIn) = True And ValidateString1(strContent1, strPatternIn) = True Then
ValidateString = True Else
If ValidateString1(strContent, strPatternIn) = False And ValidateString1(strContent1, strPatternIn) = True Then
ValidateString = False
Else
If ValidateString1(strContent, strPatternIn) = True And ValidateString1(strContent1, strPatternIn) = False Then
ValidateString = False
End If
End If
End If
End IfEnd FunctionPrivate Function ValidateString1(strPatternIn As String, strContent As String) As Boolean
If InStr(strContent, strPatternIn) > 0 Or Trim(strPatternIn) = "" Then
ValidateString1 = True
Else
ValidateString1 = False
End If
End Function
如b里含有a(如close,cclos都不算含有)则strtrue=True,否则为strtrue=False
Private Type mMatch
FirstIndex As Long
Length As Long
Value As String
End TypePrivate Sub Command1_Click()
Dim s, sa As String
s = "clos"
sa = "SUM(IF(CLOSE>REF(CLOSE,1),VOL,IF(CLOSE<REF(CLOSE,1),-VOL,0)),0)"
MsgBox strtrue(s, sa)
End Sub
Private Function strtrue(ByVal sPattern As String, sText As String) As Boolean
Dim i As Long
Dim p() As mMatch
Dim str1 As String
Dim p1() As String
Dim a As String
a = ",+-*/\;()=:<>"
p = RunRegExp(sPattern, sText)
For i = 1 To UBound(p)
DoEvents
ReDim Preserve p1(1 To i)
With p(i)
p1(i) = .FirstIndex
End With
Next
If UBound(p1) > 1 Then
For i = 1 To UBound(p1)
If p1(i) = 0 Then
If ValidateString(a, "", Mid(sText, p1(i) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Exit For
End If
Else
If ValidateString(a, Mid(sText, p1(i), 1), Mid(sText, p1(i) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Exit For
Else
strtrue = False
End If
End If
Next
Else
If p1(1) = 0 Then
If ValidateString(a, "", Mid(sText, p1(1) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Else
strtrue = False
End If
Else
If ValidateString(a, Mid(sText, p1(1), 1), Mid(sText, p1(1) + Len(sPattern) + 1, 1)) = True Then
strtrue = True
Else
strtrue = False
End If
End If
End If
Erase p
Erase p1
End Function
Private Function RunRegExp(ByVal sPattern As String, sText As String) As mMatch()
Dim objRegExp As Object
Dim colMatches As Object
Dim pMatch() As mMatch
Dim p() As String
Dim pPattern() As String
Dim i As Long
ReDim pMatch(0)
pPattern = Split("")
p = Split(sPattern, "(?<=")
For i = 0 To UBound(p)
If i = 0 Then
If Len(p(0)) > 0 And UBound(p) > 0 Then
ReDim Preserve pPattern(UBound(pPattern) + 1)
pPattern(UBound(pPattern)) = str1
End If
sPattern = p(0)
Else
If Right$(p(i - 1), 1) = "\" Then
sPattern = sPattern & "(?<=" & p(i) Else
k = 0
str1 = ""
Do
k = k + 1
If Mid$(p(i), k, 1) = ")" Then
If k = 1 Then
str1 = Left$(p(i), k)
Else
str1 = Left$(p(i), k - 1)
End If
sPattern = sPattern & str1 & Right$(p(i), Len(p(i)) - k)
ReDim Preserve pPattern(UBound(pPattern) + 1)
pPattern(UBound(pPattern)) = str1 Exit Do
End If
Loop Until k > Len(p(i))
End If
End If
Next
Set objRegExp = CreateObject("VBscript.RegExp")
With objRegExp
.Pattern = sPattern
.Global = True
.IgnoreCase = True
On Error GoTo err1
If (.Test(sText) = True) Then
Set colMatches = .Execute(sText)
k = 0
For i = 0 To colMatches.Count - 1
ReDim Preserve pMatch(UBound(pMatch) + 1)
With pMatch(UBound(pMatch))
.Value = colMatches(i).Value
.FirstIndex = colMatches(i).FirstIndex + Len(colMatches(i).Value) - Len(.Value)
End With
Next End If
End With
err1:
RunRegExp = pMatch
Set objRegExp = Nothing
Set colMatches = Nothing
Erase p
Erase pPattern
End FunctionPrivate Function ValidateString(strPatternIn As String, strContent As String, strContent1 As String) As Boolean
If Trim(strContent) = "" And Trim(strContent1) = "" Then
ValidateString = True
Else
If ValidateString1(strContent, strPatternIn) = True And ValidateString1(strContent1, strPatternIn) = True Then
ValidateString = True Else
If ValidateString1(strContent, strPatternIn) = False And ValidateString1(strContent1, strPatternIn) = True Then
ValidateString = False
Else
If ValidateString1(strContent, strPatternIn) = True And ValidateString1(strContent1, strPatternIn) = False Then
ValidateString = False
End If
End If
End If
End IfEnd FunctionPrivate Function ValidateString1(strPatternIn As String, strContent As String) As Boolean
If InStr(strContent, strPatternIn) > 0 Or Trim(strPatternIn) = "" Then
ValidateString1 = True
Else
ValidateString1 = False
End If
End Function
Dim s As String, sa As String
s = "clos"
sa = "SUM(IF(CLOSE>REF(CLOSE,1),VOL,IF(CLOSE <REF(CLOSE,1),-VOL,0)),0)"
'sa = "SUM(IF(CLOSE>REF(CLOSE,1),VOL,IF(CLOS <REF(CLOSE,1),-VOL,0)),0)"
MsgBox strtrue(s, sa)
End SubPrivate Function strtrue(ByVal sPattern As String, sText As String) As Boolean
sPattern = VBA.UCase(sPattern)
sText = VBA.UCase(sText)
Dim start As Integer: start = 1
Dim symbol As String: symbol = ",+-*/\;()=: <>"
Dim position As Integer
Dim preMatch As Boolean
Dim posMatch As Boolean
Do
preMatch = False
posMatch = False
position = InStr(start, sText, sPattern)
If position > 0 Then '//存在该字符串
If position > 1 Then '//字符串不在开头,需检查字符串前一字符
If InStr(symbol, Mid(sText, position - 1, 1)) > 0 Then preMatch = True '//字符串前无其他字母或数字
Else
preMatch = True
End If
If position < Len(sText) - Len(sPattern) + 1 Then '//字符串不在结尾,需检查字符串后一字符
If InStr(symbol, Mid(sText, position + Len(sPattern), 1)) > 0 Then posMatch = True '//字符串后无其他字母或数字
Else
posMatch = True
End If
start = position + 1 '//调整查找起始位置
Else
Exit Do
End If
If preMatch And posMatch Then strtrue = True: Exit Function
Loop
End Function
"\s" & a & "\s"
组合出的正则表达式进行匹配。