|
|
Function ChangeCodeFormat2(myCode As String) As String
'=====================================================
'日期 ：2009-6-3
'编制 ：花生牛奶
'功能 ：将包含在myCode中的vba代码进行格式整理
'返回值：按缩格形式整理的代码
'关联 ：需要调用ClearQuotes函数（清除双引号的字符串）
'=====================================================
'和前一行是否为同一语句的标记
Dim SameLineFlag As Boolean
'当前行的类型,1表示复合体的开始,2表示复合体中间的控制语句,3表示结束,5表示空行,0表示普通语句
Dim ControlFlagType As Integer
'myPreStr1控制语句的空格串来控制缩格
' myPreStr2普通语句的缩格
Dim myPreStr1 As String, myPreStr2 As String
'循环变量
Dim i As Integer, j As Integer
's2为trim后的原来语句,s1为小写的完整原来语句,s为剔除注释后的主语句
Dim s As String, s1 As String, s2 As String, sNext As String, sCur As String
'code存储格式整理后的语句
Dim Code As String
'保存将原来的所有语句按回车进行分解的数组,每个元素为一行语句,可能带chr(13)
Dim X
'预定义缩格一次的长度
Const myPreSpaceNum As Integer = 3
'myMemoPos注释的单引号位置
Dim myRemPos As Integer
X = Split(myCode, Chr(10))
myPreStr1 = ""
myPreStr2 = ""
ControlFlagType = 0
For i = 0 To UBound(X)
s2 = X(i)
If Right(s2, 1) = Chr(13) Then s2 = Left(s2, Len(s2) - 1)
s2 = Trim(s2)
s1 = LCase(ClearQuotes(s2))
myRemPos = InStr(s1, "'")
If myRemPos > 1 Then '检查语句是否带注释内容,如果有则去掉
s = Trim(Left(s1, myRemPos - 1)) 'ClearRem(s1)
Else
s = s1
End If
sCur = s
If Not SameLineFlag Then
If Right(s, 1) = "_" Then
j = 1
Do
sNext = X(i + j)
If Right(sNext, 1) = Chr(13) Then sNext = Left(sNext, Len(sNext) - 1)
sNext = ClearQuotes(LCase(Trim(sNext)))
myRemPos = InStr(sNext, "'")
If myRemPos > 1 Then '检查语句是否带注释内容,如果有则去掉
s = Trim(Left(sNext, myRemPos - 1))
End If
s = s & " " & sNext '空格用来分隔
j = j + 1
Loop Until Right(sNext, 1) <> "_"
SameLineFlag = True
End If
'以下长长的if语句判断当前语句的类型
If s Like "function *" Or s Like "* function *" Then
ControlFlagType = 1
ElseIf s Like "sub *" Or s Like "* sub *" Then
ControlFlagType = 1
ElseIf s Like "property *" Or s Like "* property *" Then
ControlFlagType = 1
ElseIf s Like "if * then" Or s Like "#if * then" Then
ControlFlagType = 1
ElseIf s Like "for *" Then
ControlFlagType = 1
ElseIf s Like "with *" Then
ControlFlagType = 1
ElseIf s Like "select *" Then
ControlFlagType = 1
ElseIf s Like "do" Or s Like "do *" Then
ControlFlagType = 1
ElseIf s Like "while *" Then
ControlFlagType = 1
ElseIf s Like "end *" Or s Like "#end if" Then
ControlFlagType = 3
ElseIf s = "next" Or s Like "next *" Then
ControlFlagType = 3
ElseIf s Like "loop *" Or s = "loop" Then
ControlFlagType = 3
ElseIf s Like "wend" Then
ControlFlagType = 3
ElseIf s Like "elseif *" Or s Like "#elseif *" Then
ControlFlagType = 2
ElseIf s = "else" Or s = "#else" Then
ControlFlagType = 2
ElseIf s Like "case *" Then
ControlFlagType = 2
ElseIf s <> "" Then
ControlFlagType = 0
Else
ControlFlagType = 5
End If
'针对不同类型的语句,选择不同的缩格
'并决定后续的语句缩格长度
Select Case ControlFlagType
Case 0, 5 '一般语句
Code = Code & myPreStr1 & s2 & vbLf
Case 1 '开始语句
myPreStr2 = myPreStr1 '控制语句同开始前的语句
myPreStr1 = myPreStr1 & Space(myPreSpaceNum) '后续普通语句缩格
Code = Code & myPreStr2 & s2 & vbLf
Case 2 '中间语句
Code = Code & myPreStr2 & s2 & vbLf
Case 3 '结束语句,分别回缩,如果顶格则不动
Code = Code & myPreStr2 & s2 & vbLf
If Len(myPreStr1) >= myPreSpaceNum Then myPreStr1 = Left(myPreStr1, Len(myPreStr1) - myPreSpaceNum)
If Len(myPreStr2) >= myPreSpaceNum Then myPreStr2 = Left(myPreStr2, Len(myPreStr2) - myPreSpaceNum)
'myPreStr2 = myPreStr1
End Select
Else '和之前语句实际为同一语句则缩进去
If Not Right(sCur, 1) = "_" Then SameLineFlag = False
Select Case ControlFlagType
Case 0, 5
Code = Code & Space(myPreSpaceNum) & myPreStr1 & s2 & vbLf
Case 1, 2, 3
Code = Code & Space(myPreSpaceNum) & myPreStr2 & s2 & vbLf
End Select
End If
Next
ChangeCodeFormat2 = Code
End Function
Function ClearQuotes(tmpStr As String) As String
'=====================================================
'日期 ：2009-6-3
'编制 ：花生牛奶
'功能 ：将tmpstr中不带双引号之间的内容复制，便于后续判断处理
'返回值：返回没有双引号之间内容的字符串
'关联 ：无
'=====================================================
Dim myPos1 As Integer, myPos2 As Integer
Dim ss As String
ss = tmpStr
myPos1 = InStr(ss, Chr(34))
Do While myPos1
myPos2 = InStr(myPos1 + 1, ss, Chr(34))
If myPos2 Then
ss = Left(ss, myPos1 - 1) & Right(ss, Len(ss) - myPos2)
Else
Exit Do
End If
myPos1 = InStr(ss, Chr(34))
Loop
ClearQuotes = ss
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-6-3 00:18
