Sub Test_CleanCode_AddToModule()
Dim codeStr$, ModName$
ModName = "zTemp"
codeStr = getCodeModule(ModName)
If codeStr = "" Then Exit Sub
codeStr = CleanCode(codeStr, False, True, True, True)
AddCodeModule ModName, codeStr, True
End Sub
Sub Test_CleanCode_str()
Debug.Print CleanCode(ExamStringCode, False, True, True, True)
End Sub
Function CleanCode(Optional ByVal imStr, _
Optional ByVal Protruding As Boolean = True, _
Optional ByVal clearLinesBlank As Boolean = True, _
Optional ByVal clearCommentApostrophe As Boolean = False, _
Optional ByVal ClearCommentRem As Boolean = False) As String
If Not imStr Like "*" & vbNewLine & "*" Then: CleanCode = imStr: Exit Function
Dim Str$: Str = imStr
Dim Arr() As String: Arr = Split(Str, vbNewLine)
Dim blankArr() As String, k: k = 0
Dim i&, bBCm As Boolean
If Protruding Then
For i = 0 To UBound(Arr)
Arr(i) = Application.WorksheetFunction.Clean(Trim$(Arr(i)))
Next i
End If
If clearLinesBlank Then
For i = 0 To UBound(Arr)
If k <> 0 Then
If Right$(Trim$(blankArr(k - 1)), 2) = " _" And Arr(i) = vbNullString Then
blankArr(k - 1) = Left$(blankArr(k - 1), Len(blankArr(k - 1)) - 1)
End If
End If
If Arr(i) <> vbNullString Then
ReDim Preserve blankArr(k)
blankArr(k) = Arr(i)
k = k + 1
End If
Next i
Else
blankArr = Arr
End If
Dim atpArr() As String, bMul As Boolean, bO1 As Boolean, bO2 As Boolean
k = 0
If clearCommentApostrophe Then
For i = 0 To UBound(blankArr)
If i <> 0 Then
If bMul = True _
And Right$(Trim$(blankArr(i - 1)), 2) = " _" Then
bMul = True
Else
bMul = False
End If
End If
bO1 = False: bO2 = False
If bMul = False Then
If Left$(Trim$(blankArr(i)), 1) = "'" Then
bO1 = True
If Right$(Trim$(blankArr(i)), 2) <> " _" Then
bMul = False
Else
bMul = True
End If
Else
If blankArr(i) Like "*'*" Then
bO2 = True
If Right$(Trim$(blankArr(i)), 2) <> " _" Then
bMul = False
Else
bMul = True
End If
End If
End If
If bO1 = False And bO2 = False Then
ReDim Preserve atpArr(k)
atpArr(k) = blankArr(i)
k = k + 1
ElseIf bO2 = True Then
ReDim Preserve atpArr(k)
If Not blankArr(i) Like "*""*'*""*" Then 'scarce - Handle
atpArr(k) = Split(blankArr(i), "'")(0)
Else
atpArr(k) = blankArr(i)
End If
k = k + 1
End If
End If
Next i
Else
atpArr = blankArr
End If
Dim remArr() As String, bRMul As Boolean, bRO1 As Boolean, bRO2 As Boolean
k = 0
If ClearCommentRem Then
For i = 0 To UBound(atpArr)
If i <> 0 Then
If bRMul = True And Right$(Trim$(atpArr(i - 1)), 2) = " _" Then
bRMul = True
Else
bRMul = False
End If
End If
bRO1 = False: bRO2 = False
If bRMul = False Then
If LCase$(Left(Trim$(atpArr(i)), 4)) = "rem " Then
bRO1 = True
If Right$(Trim$(atpArr(i)), 2) <> " _" Then
bRMul = False
Else
bRMul = True
End If
Else
If LCase$(atpArr(i)) Like "*: rem*" Then
bRO2 = True
If Right$(Trim$(atpArr(i)), 2) <> " _" Then
bRMul = False
Else
bRMul = True
End If
End If
End If
If bRO1 = False And bRO2 = False Then
ReDim Preserve remArr(k)
remArr(k) = atpArr(i)
k = k + 1
ElseIf bRO2 = True Then
ReDim Preserve remArr(k)
remArr(k) = Split(atpArr(i), ": Rem")(0)
k = k + 1
End If
End If
Next i
Else
remArr = atpArr
End If
CleanCode = Join(remArr, vbNewLine)
End Function
Function ExamStringCode() As String
Dim Str As String
Str = "Sub Test_zTemp_code_()"
Str = Str + vbNewLine
Str = Str + vbNewLine
Str = Str + vbNewLine
Str = Str + "Rem comment" + vbNewLine
Str = Str + "Rem comment _" + vbNewLine
Str = Str + vbNewLine
Str = Str + "Dim a As String" + vbNewLine
Str = Str + "Rem comment _" + vbNewLine
Str = Str + " Rem comment _" + vbNewLine
Str = Str + "comment" + vbNewLine
Str = Str + vbNewLine
Str = Str + "Rem comment _" + vbNewLine
Str = Str + "comment _" + vbNewLine
Str = Str + " comment _" + vbNewLine
Str = Str + vbNewLine
Str = Str + "'comment" + vbNewLine
Str = Str + " ' _" + vbNewLine
Str = Str + " ' _" + vbNewLine
Str = Str + " ' _" + vbNewLine
Str = Str + " 'comment _" + vbNewLine
Str = Str + " comment _" + vbNewLine
Str = Str + " comment _" + vbNewLine
Str = Str + "comment _" + vbNewLine
Str = Str + "comment" + vbNewLine
Str = Str + vbNewLine
Str = Str + "Dim b As String 'comment" + vbNewLine
Str = Str + " Dim c As String 'comment _" + vbNewLine
Str = Str + "comment _" + vbNewLine
Str = Str + "comment" + vbNewLine
Str = Str + vbNewLine
Str = Str + " Dim d As String 'comment _" + vbNewLine
Str = Str + "comment _" + vbNewLine
Str = Str + vbNewLine
Str = Str + vbNewLine
Str = Str + " Dim e As String" + vbNewLine
Str = Str + " e = ""hello'hello"" 'comment" + vbNewLine
Str = Str + "Dim f As String: Rem _" + vbNewLine
Str = Str + "comment _" + vbNewLine
Str = Str + "comment" + vbNewLine
Str = Str + "Call Test_AddCodeModule" + vbNewLine
Str = Str + "End Sub"
ExamStringCode = Str
End Function
Sub Test_AddCodeModule()
AddCodeModule , ExamStringCode, True
End Sub
Function AddCodeModule(Optional ByVal mdName As String = "zTemp", _
Optional ByVal StrCode As String, _
Optional ByVal bNewCode As Boolean = False)
addModule (mdName)
Dim CodeMod: Set CodeMod = ActiveWorkbook.VBProject.VBComponents.Item(mdName).CodeModule
With CodeMod
If bNewCode And .CountOfLines > 1 Then .DeleteLines 1, .CountOfLines
.InsertLines .CountOfLines + 1, StrCode
End With
End Function
Function getCodeModule(Optional ByRef codeName As String = "zTemp", _
Optional ByRef arrLines As Variant, _
Optional ByRef strNLine As String, _
Optional ByRef arrNLine As Variant) As String
If IsMissing(codeName) Or codeName = vbNullString Or _
IsNumeric(Left(codeName, 1)) Then getCodeModule = vbNullString: Exit Function
Dim CodeMod: Set CodeMod = ThisWorkbook.VBProject.VBComponents.Item(codeName).CodeModule
On Error Resume Next
Dim codeStr As String: codeStr = CodeMod.Lines(1, CodeMod.CountOfLines)
Dim i As Long, Arr As Variant, rArr As Variant
Arr = Split(codeStr, vbNewLine)
ReDim rArr(UBound(Arr))
For i = 0 To UBound(Arr)
rArr(i) = i + 1
Next i
getCodeModule = Join(Arr, vbNewLine)
arrLines = Arr
strNLine = Join(rArr, vbNewLine)
arrNLine = rArr
Set CodeMod = Nothing
End Function
Sub test_addModule()
addModule
End Sub
Function addModule(Optional addName$ = "zTemp") As Boolean
If addName = vbNullString Then addModule = False: Exit Function
If findModule(addName) Then addModule = False: Exit Function
Dim VBProj As Object, Wb As Workbook
Set Wb = ThisWorkbook
Set VBProj = Wb.VBProject
VBProj.VBComponents.Add(1).Name = addName
VBProj.VBComponents(addName).Activate
Application.VBE.MainWindow.Visible = True
addModule = True
End Function
Function findModule(mdName) As Boolean
Dim VBProj As Object, Wb As Workbook
Set Wb = ThisWorkbook
Set VBProj = Wb.VBProject
Dim Obj
For Each Obj In VBProj.VBComponents
If UCase(mdName) = UCase(Obj.Name) Then
findModule = True
Exit Function
End If
Next Obj
End Function
òng Sub Macro1() và dòng End Sub bị so le nhau, không thẳng hàng)
