Private mWIID As Integer
Const Operator As String = "+-*/> <()"
Public Event Done(strExp As String, strDis As String)
Public Property Let WIID(ByVal iID As Integer)
mWIID = iID
End Property
Public Property Let Expression(ByVal strExp As String)
txtExp.Text = strExp
txtExp.SelStart = Len(strExp)
End Property
'-----------------------------------------------------
'检查表达式的是否正确有效
'-----------------------------------------------------
Public Function CheckValid(strExp As String) As Boolean
Dim i As Integer
Dim strTmp As String
Dim s As Integer
Dim start As Integer
Dim send As Integer
s = 0
strTmp = strExp
start = 1
For i = 1 To Len(strExp)
If Mid(strExp, i, 1) = "(" Then
If s = 0 Then
start = i
End If
s = s - 1
End If
If Mid(strExp, i, 1) = ")" Then
send = i
s = s + 1
If s = 0 Then
If CheckValid(Mid(strExp, start + 1, send - start - 1)) = True Then
strTmp = Replace(strTmp, Mid(strExp, start, send - start + 1), "$")
Else
CheckValid = False
Exit Function
End If
End If
End If
Next i
'----------------------------------------------------------
'检查不包含括号的表达式的有效性
'----------------------------------------------------------
Public Function CheckExceptBrack(strExp As String) As Boolean
Dim strTmp As String
Dim i As Integer
Dim s As Boolean
Dim rlt As Integer
Dim Fds() As String
Fds = Split(strTmp, " ", -1, vbTextCompare)
For i = 0 To UBound(Fds)
If IsDatabaseField(Fds(i)) = False And IsNumeric(Fds(i)) = False Then
CheckExceptBrack = False
Exit Function
End If
Next i
For i = 1 To Len(strExp)
If Mid(strTmp, i, 1) = Mid(strExp, i, 1) Then
If s = False Then
s = True
rlt = rlt + 1
If rlt > 0 Then Exit Function
End If
Else
s = False
rlt = rlt - 1
If rlt < -1 Then Exit Function
End If
Next i
If rlt = 0 Then
CheckExceptBrack = True
End If
End Function
'------------------------------------------------------
'将表达式中的操作符用空格替换掉
'------------------------------------------------------
Public Function ReplaceOpterater(strExpression As String) As String
Dim i As Integer
Dim strTmp As String
strTmp = strExpression
For i = 1 To 8
strTmp = Replace(strTmp, Mid(Operator, i, 1), " ")
Next i
ReplaceOpterater = strTmp
End Function
'--------------------------------------------------------
'判断字符串是否是数据库中的字段
'--------------------------------------------------------
Public Function IsDatabaseField(strCheck As String) As Boolean
Dim i As Integer
If strCheck = "$" Then
IsDatabaseField = True
Exit Function
End If
For i = 0 To UBound(mFields, 2)
If strCheck = mFields(0, i) Then
IsDatabaseField = True
Exit Function
End If
Next i
IsDatabaseField = False
End Function
Private Function CreateExp(strExp As String) As String
Dim i As Integer, j As Integer
Dim strTemp As String
Dim strItems() As String
Dim strNewExp As String
For i = 0 To UBound(strItems)
For j = 0 To UBound(mFields, 2)
If strItems(i) = mFields(0, j) Then
strItems(i) = mFields(2, j)
Exit For
End If
Next j
Next i
j = 0
For i = 1 To Len(strExp)
If Mid(strExp, i, 1) <> Mid(strTemp, i, 1) Then
strNewExp = strNewExp & strItems(j) & Mid(strExp, i, 1)
j = j + 1
End If
Next i
Private Sub cmdCheckValid_Click()
If CheckValid(txtExp.Text) = True Then
MsgBox "计算公式验证结果正确!", vbOKOnly + vbInformation, App.ProductName
Else
MsgBox "计算公式格式不正确!", vbOKOnly + vbInformation, App.ProductName
End If
End Sub
Private Sub cmdInput_Click(Index As Integer)
Dim pos As Integer
Dim strText As String
Private Sub cmdOK_Click()
If CheckValid(txtExp.Text) = False Then
MsgBox "计算公式输入不正确!", vbOKOnly + vbInformation, App.ProductName
Else
RaiseEvent Done(CreateExp(txtExp.Text), txtExp.Text)
Unload Me
End If
End Sub
Private Sub Form_Load()
Call InitForm
txtExp.SelStart = Len(txtExp.Text)
End Sub
'----------------------------------------------------------------------
'初始化UcGridDA;初始化数据库字段,保存到数组中
'----------------------------------------------------------------------
Private Sub InitForm()
Dim puArrayColInfo() As puHEADSTRUCT
Dim lTmpCol As Long
Dim puArrayRowInfo(16) As puHEADSTRUCT
Dim rst As New ADODB.Recordset
Dim strSQL As String
Dim cnt As Integer
strSQL = "SELECT FDDictID,FDName,FDFieldName,FDExpression FROM FieldDict WHERE FDDictID <" & mWIID
rst.ActiveConnection = glbConnString
rst.CursorLocation = adUseClient
rst.Open strSQL
UcGrid1.subSetRecordSet rst.Clone
With rst
Do While Not .EOF
cnt = cnt + 1
ReDim Preserve mFields(2, cnt)
mFields(0, cnt) = Trim(!FdName)
mFields(1, cnt) = Trim(!FDExpression)
mFields(2, cnt) = Trim(!FDFieldName)
.MoveNext
Loop
End With
rst.Close
Set rst = Nothing
End Sub
Private Sub UcGrid1_DblClick()
Dim strDisp As String
Dim pos As Integer
Dim strText As String
If UcGrid1.CurRow > 0 Then
strDisp = Trim(UcGrid1.DisplayText(UcGrid1.CurRow, 1))
If strDisp <> "" Then
strText = txtExp.Text
pos = txtExp.SelStart
txtExp.Text = Left(strText, pos) & strDisp & VBA.Right(strText, VBA.Len(strText) - pos)
txtExp.SelStart = pos + Len(strDisp)
End If
End If
txtExp.SetFocus
End Sub