Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Workbook_Activate()

    On Error Resume Next   '少数电脑会出现错误  增加右键菜单时
     With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = 1 Then        '已经标记错误的，不再执行些过程
                Exit Sub
            Else
                .Cells(100, 3).Value = 1
        End If
    End With
    Call youjiancaidan01

    With Sheets("账套基础信息表")
        .Cells(100, 3).Value = ""
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next                                '少数电脑会出现错误  增加右键菜单时
    With Sheets("凭证表")
        .TextBox1.Visible = False
        .ListBox1.Visible = False
        .ListBox1.Width = 2
        .ListBox1.Height = 2
    End With
    
    With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = "" Then
        
            
            
            Call chongzhi       '右键菜单重置  恢复默认
        End If
    End With
    
    Application.MoveAfterReturnDirection = xlDown       '设置主程序为回车向下
    
    With Sheets("首页")
        .Visible = True
        .Activate
        .Cells(1, 1).Select
        .Move before:=Sheets("凭证表")
    End With
    
    Application.OnTime thetime, "Backup", , False
    
    
    
    
    
    
    Dim x As String
    Dim x2 As Integer
    x2 = 0

    Dim FSO As Object, mDisk
    Set FSO = CreateObject("scripting.filesystemobject")
    Set mDisk = FSO.drives
    For Each D In mDisk
        Select Case D.DriveType
            Case 0: t = "未知磁盘"
            Case 1: t = "U盘"
            Case 2
                t = "本地硬盘"
               
             
               
               If D.FreeSpace / 1024 / 1024 > 10000 Then
                x = D
                x2 = 1
               End If
                
            Case 3: t = "网络硬盘"
            Case 4: t = "光盘驱动器"
            Case 5: t = "内存虚拟盘"
        End Select
       ' MsgBox "55"
    
    Next
    

  
    
    If x2 = 0 Then Exit Sub         '没有大于10G的最后一个盘时，停止备份
    
    On Error Resume Next
    Dim Path As String, OldPath As String
    On Error Resume Next                       '20181110
    
    
    
   
    Application.DisplayAlerts = False
    If Dir(x & "\zidongbeifen\", vbDirectory) = "" Then
        MkDir x & "\zidongbeifen\"
        Dim gPath As String
        Dim sFile As Object     ', FSO As Object
        gPath = x & "\zidongbeifen\"
        
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set sFile = FSO.CreateTextFile(gPath & "/说明.txt", True)
        
        sFile.WriteLine ("  ")
        sFile.WriteLine ("  ")
        sFile.WriteLine ("    说明： ")
        sFile.WriteLine ("          1、本文件所在的文件夹为备份专用。")
        
        sFile.WriteLine ("          2、本文件夹中的文件是一个双重备份，是在用户关闭原始excel文件时产生的，操作过程中不备份，仅在关闭时备份一次。")
        sFile.WriteLine ("          3、本文件夹中的备份文件如果不是excel格式无法直接打开，且为用户安全考虑设置了复杂密码。")
        sFile.WriteLine ("          4、当前位置备份在用户确认原始文件已经安全保存后可以删除。")
        sFile.WriteLine ("          5、安全起见，用户请保留适当数量的近期备份文件，对于较早期间的备份文件确认不需要后可以删除。")
        sFile.WriteLine ("          6、请勿仅依靠此备份功能，重要数据请经常复制到电脑或发送到邮箱备份，避免仅保存在优盘中。")
        sFile.WriteLine ("          7、需要使用此位置备份恢复或远程是要收费的。")
        
        sFile.WriteLine ("          ")
        
        sFile.WriteLine ("  ")
        sFile.WriteLine ("                   祝  使用愉快")
        sFile.Close
        Set sFile = Nothing
        Set FSO = Nothing                                           '以上增加文本文件说明文件  结束
    End If
    Path = x & "\zidongbeifen\"
    
    Dim aa As String
             
    aa = VBA.Format(Now(), "yyyy-mm-dd")
    aa = aa & "  " & VBA.Format(Now(), "hh:mm:ss")
    aa = Replace(aa, ":", "：")
    'MsgBox aa
              
   
   
   
   
    
    
    If InStrRev(Application.Caption, "Microsoft") <> 0 Then                                      '判断当前程序是否为 excel，
        If Val(Application.Version) < 14 Or InStrRev(ThisWorkbook.Name, ".xlsm") = 0 Then GoTo a30
    End If
    
  
    
    ThisWorkbook.SaveCopyAs Filename:=Path & aa & ".xlsm"
    
   
    
    On Error Resume Next
    Name Path & aa & ".xlsm" As Path & aa & ".ndb"
    
    GoTo a32
    
a30:
    ThisWorkbook.SaveCopyAs Path & aa & ".xls"
    
    On Error Resume Next
    Name Path & aa & ".xls" As Path & aa & ".ndb"
a32:
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Private Sub Workbook_Deactivate()
    On Error Resume Next                        '少数电脑会出现错误  增加右键菜单时
    
    
    With Sheets("账套基础信息表")
        If .Cells(100, 3).Value = "" Then
            
            
            Call chongzhi
        End If
    End With
    Application.Calculation = xlAutomatic

End Sub

Private Sub Workbook_Open()
    
    Application.ScreenUpdating = False
    
    With Sheets("首页")             '启用宏时自动不显示提示
        .Visible = False
    End With
    
    
    ' 以下变量已在模块中定义为全局变量
    
    'ps    ' 可能的保护密码 以变量代替

    On Error Resume Next
    
    With Application.ActiveProtectedViewWindow
        .Edit
    End With
    On Error GoTo 0
 
 
    
    With Sheets("账套基础信息表")
        If .Cells(24, 3).Value = 1 Then         '读取保护情况到全局变量
                bh = 1
            Else
                bh = 0
        End If
        If .Cells(25, 3).Value = "" Then        '记录保护密码
                ps = ""
            Else
                ps = (Sheets("账套基础信息表").Cells(25, 3).Value - 776) / 3
        End If
        If .Cells(18, 3).Value = 1 Then         '记录是否在日期变化时自动增加凭证号
                p5 = 1
            Else
                p5 = 0
        End If
        If .Cells(21, 3).Value = 1 Then         '记录是否在借贷平衡时自动增加凭证号
                p7 = 1
            Else
                p7 = 0
        End If
        
        If .Cells(30, 3).Value = 1 Then         '记录是否在跨月时连续增加凭证号
                p9 = 1
            Else
                p9 = 0
        End If
        
        
        If .Cells(19, 3).Value = 1 Then         '记录是否启用现金流量表（及选项）
                xj02 = 1
            Else
                xj02 = 0
        End If
        If .Cells(27, 3).Value = "" Then        '记录是否启用凭证录入时的余额实时提示窗体
                yuetishi = True
            Else
                yuetishi = False
        End If
        If .Cells(28, 3).Value = 1 Then         '记录是否关闭科目智能录入提示窗体
                zhineng15 = 1                   '1为关闭
            Else
                zhineng15 = 0
        End If
        If .Cells(95, 3).Value <> 1 Then        '记录是否关闭自动备份功能
                Flag = True                     '代表启用自动备份
            Else
                Flag = False                    '代表不启用自动备份
        End If
        
        If .Cells(29, 3).Value = "" Then        '相似度指数设置值读取到变量
                xsd = 30                        '默认值
            Else
                xsd = .Cells(29, 3).Value       '按设置值
        End If
        
    End With
    
    
    '（二）辅助核算状态默认值
    fz = 0
    If Flag = True Then Call Backup      '启用自动备份过程  在模块5中

    
    Call wps01
    If wpshuanjing = True Then
        With Sheets("凭证表")
            If .Columns("v:v").ColumnWidth <> 2.88 Then .Columns("v:v").ColumnWidth = 2.88
        End With
    
    End If
    
    Application.ScreenUpdating = False
    
    
    
    
    
    
    On Error Resume Next        '防止有些工作表不存在
    
    If Sheets("视频教程").Visible = True Then Sheets("视频教程").Move After:=Sheets("凭证表")
    If Sheets("备忘录").Visible = True Then Sheets("备忘录").Move After:=Sheets("凭证表")
    If Sheets("费用分摊表").Visible = True Then Sheets("费用分摊表").Move After:=Sheets("凭证表")
    If Sheets("现金流量表").Visible = True Then Sheets("现金流量表").Move After:=Sheets("凭证表")
    If Sheets("利润表").Visible = True Then Sheets("利润表").Move After:=Sheets("凭证表")
    If Sheets("资产负债表").Visible = True Then Sheets("资产负债表").Move After:=Sheets("凭证表")
    If Sheets("科目余额表02").Visible = True Then Sheets("科目余额表02").Move After:=Sheets("凭证表")
    If Sheets("科目余额表").Visible = True Then Sheets("科目余额表").Move After:=Sheets("凭证表")
    If Sheets("科目汇总表").Visible = True Then Sheets("科目汇总表").Move After:=Sheets("凭证表")
    If Sheets("数量金额明细账").Visible = True Then Sheets("数量金额明细账").Move After:=Sheets("凭证表")
    If Sheets("明细账").Visible = True Then Sheets("明细账").Move After:=Sheets("凭证表")
    If Sheets("项目核算科目期初余额表").Visible = True Then Sheets("项目核算科目期初余额表").Move After:=Sheets("凭证表")
    If Sheets("项目核算表").Visible = True Then Sheets("项目核算表").Move After:=Sheets("凭证表")
    If Sheets("固定资产表").Visible = True Then Sheets("固定资产表").Move After:=Sheets("凭证表")
    If Sheets("科目设置表").Visible = True Then Sheets("科目设置表").Move After:=Sheets("凭证表")
    
    Sheets("凭证表").Activate
    
    Application.ScreenUpdating = True
    
    
    
    
    
    
    
    
    
    
    If InStrRev(Application.Caption, "Microsoft") <> 0 Then                                      '判断当前程序是否为 excel，
        
        If Val(Application.Version) < 14 Then
        
            MsgBox "当前财务系统运行环境提示：" & vbCrLf & "" & vbCrLf & "   检测到当前office版本为2010以下版本，本财务系统正常运行已不再支持2010以下excel版本，需要安装2010以上版本office或wps2019以上版本。" & vbCrLf & "请尽快卸载当前版本office并安装2010或以上版本office或wps2019以上版本，以便能正常运行本财务系统的最新功能。避免出现运行错误。" & vbCrLf & "如需office2010完整版安装程序，也可以联系客服免费领取。" & vbCrLf & "" & vbCrLf & ""
        
        End If
    End If
    
End Sub
 

Attribute VB_Name = "UserForm7"
Attribute VB_Base = "0{DD967302-9C3E-4947-B1EF-E967C1015D3D}{651F2412-71AF-4ED5-81C3-949725A1B0AB}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub CommandButton1_Click()
         
    Application.EnableEvents = False
    
    If Cells(3, 2).Value = "" Or Cells(3, 2).Value = 1 Then
        Cells(3, 2).Value = TextBox1.Text & "1"
    End If
    
    If Cells(3, 2).Value = "记-11" Then Cells(3, 2).Value = "记-1"
    Unload Me
End Sub
 

Private Sub TextBox1_Change()
      If VBA.IsNumeric(VBA.Right(TextBox1.Text, 1)) = True Then
            MsgBox "错误提示： 自动添加的凭证字，最后不能数字结尾。（设置自动添加凭证字后，在录入凭证号时只需要录入后面数字部分，前面的部分会自动添加，但自动添加的部分不需要包含数字。"
        Else
            Sheets("账套基础信息表").Cells(20, 3).Value = TextBox1.Text
    End If
End Sub


Private Sub UserForm_Activate()
    CommandButton1.SetFocus
End Sub
Private Sub UserForm_Initialize()

    With Sheets("账套基础信息表")
        If .Cells(20, 3).Value = "" Then
                TextBox1.Text = "记-"
            Else
                TextBox1.Text = .Cells(20, 3).Text
        End If
    End With
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     If Cells(3, 2).Value = "" Or Cells(3, 2).Value = 1 Then
         Cells(3, 2).Value = TextBox1.Text & "1"
     End If
End Sub

Attribute VB_Name = "UserForm31"
Attribute VB_Base = "0{9291791F-21E1-4E52-8C5E-B7D56F0A23B7}{41816508-313A-4DD7-A80F-6A21244228B1}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub CommandButton1_Click()
    Unload Me
End Sub

Attribute VB_Name = "模块7"
 
Sub 宏9()
Attribute 宏9.VB_ProcData.VB_Invoke_Func = " \n14"
'
 





    Application.ScreenUpdating = False
    For x = 1 To 94
        Rows("16:30").Copy
        Cells(31, 1).Insert Shift:=xlDown
    Next
    Application.ScreenUpdating = True
    Application.CutCopyMode = False             '取消复制状态
    
End Sub



Sub hanggaotiaojie()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板")
        For i = 0 To 95                                      '共96个凭证模板
            For x = 5 To 11
                rx = i * 15 + x
                .Rows(rx & ":" & rx).RowHeight = 31.2
            Next
        Next
    End With
End Sub


Sub huanhang()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板06")
        For i = 0 To 95                                      '共96个凭证模板
            With .Range(.Cells(i * 18 + 14, 2), .Cells(i * 18 + 14, 2))
                .WrapText = True                                            '自动换行
            End With
        Next
    End With
    
End Sub

Sub hanggaotiaojie02()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板02")
        For i = 0 To 95                                                     '共96个凭证模板
            For x = 5 To 11
                rx = i * 15 + x
                If x = 5 Or x = 11 Then     '标题行时，调整的高度和数据行有不同
                        .Rows(rx & ":" & rx).RowHeight = 30.6
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 31.2
                End If
            Next
        Next
    End With
End Sub



Sub hanggaotiaojie03()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板03")
        For i = 0 To 95                                                     '共96个凭证模板
            For x = 5 To 14
                rx = i * 18 + x
                If x = 5 Or x = 14 Then     '标题行时，调整的高度和数据行有不同
                        .Rows(rx & ":" & rx).RowHeight = 28.8
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 29.4                   '
                End If
            Next
        Next
    End With
    
End Sub



Sub hanggaotiaojie04()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板04")
        For i = 0 To 95                                                     '共96个凭证模板
            For x = 5 To 11
                rx = i * 15 + x
                If x = 5 Or x = 11 Then                             '标题行时，调整的高度和数据行有不同
                        .Rows(rx & ":" & rx).RowHeight = 27.6
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 30                   '
                End If
            Next
        Next
    End With
    
End Sub


Sub hanggaotiaojie05()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板05")
        For i = 0 To 143
            For x = 5 To 11
                rx = i * 15 + x                                 '当前循环到的行 值
                .Rows(rx & ":" & rx).RowHeight = 24.6
            Next
        Next
    End With
    
End Sub



Sub hanggaotiaojie06()
  
    
        
    Dim i As Integer
    Dim x As Integer
    Dim rx As Integer
        
    With Sheets("凭证打印模板06")
        For i = 0 To 95                                  '96个凭证模板
            For x = 5 To 14
                rx = i * 18 + x                                 '当前循环到的行 值
                If x = 5 Or x = 14 Then                             '标题行时，调整的高度和数据行有不同
                        .Rows(rx & ":" & rx).RowHeight = 28.8
                    Else
                        .Rows(rx & ":" & rx).RowHeight = 29.4                   '
                End If
            Next
        Next
    End With
End Sub



Attribute VB_Name = "模块11"
Sub 宏2()
Attribute 宏2.VB_ProcData.VB_Invoke_Func = " \n14"
'
' 宏2 宏
'

'
  
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Color = -11489280
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Font
        .Color = -11489280
        .TintAndShade = 0
    End With
    Columns("L:L").ColumnWidth = 33.56
    Columns("J:J").ColumnWidth = 14.11
    Range("K8:K10").Select
    Selection.Style = "Percent"
    Selection.NumberFormatLocal = "0.0%"
    Selection.NumberFormatLocal = "0.00%"
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub
Sub 宏4()
Attribute 宏4.VB_ProcData.VB_Invoke_Func = " \n14"
'
' 宏4 宏
'

'
    Range("J8:J10").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("K8:K9").Select
    Selection.NumberFormatLocal = "0.00000000"
    Selection.NumberFormatLocal = "0.0000000"
    Selection.NumberFormatLocal = "0.000000"
    Selection.NumberFormatLocal = "0.00000"
    Selection.NumberFormatLocal = "0.0000"
    Selection.NumberFormatLocal = "0.000"
    Selection.NumberFormatLocal = "0.00"
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("K10").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Style = "Percent"
    Selection.NumberFormatLocal = "0.0%"
    Selection.NumberFormatLocal = "0.00%"
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("L7").Select
End Sub

Attribute VB_Name = "Sheet27"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
    
    
    Public x1 As Double
    Public x2 As Double
    Public x3 As Double
    Public x4 As Double
    Public x5 As Double
    Public x6 As Double
    
    Public dm1 As Long
    Public jc As Long
     
Private Sub Worksheet_Activate()
    Application.ScreenUpdating = False

    On Error Resume Next
 

    
    Application.MoveAfterReturnDirection = xlToRight
    
    
    With Range("A:A,B:B,V:V,X:X,Z:Z")
        .NumberFormatLocal = "0_ "
    End With
    
    
    Dim p4 As Integer
    p4 = 0      '设置默认值
    
    With Sheets("账套基础信息表")
        If .Cells(54, 3).Value <> "" Then
            p4 = .Cells(54, 3).Value
        End If
    End With
    If p4 = 20 Then                                     '行政事业单位科目表时
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:Z").ColumnWidth = 0
    End If
    If p4 = 10 Then                                     '民非单位科目表时
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:Y").ColumnWidth = 0
    End If
    If p4 = 0 Then
        Columns("H:H").ColumnWidth = 0
        Columns("M:O").ColumnWidth = 0
        Columns("W:W").ColumnWidth = 0
        Columns("Y:Y").ColumnWidth = 0
    End If

    
    Dim zhidu As Integer
    With Sheets("账套基础信息表")
        If .Cells(54, 3).Value = 10 Then         '现金流量表只有企业和民非有，两种情况
                zhidu = 10
            Else
                If .Cells(54, 3).Value = 20 Then
                        zhidu = 20
                    Else
                        If .Cells(54, 3).Value = 30 Then
                                zhidu = 30
                            Else
                                zhidu = 1
                        End If
                End If
        End If
    End With
    
    
    Application.ScreenUpdating = True

End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Call youjiancaidan03
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim r As Integer
    r = Target.Row
    On Error Resume Next                        '防止删除行时引起内存溢出错误
    If r < 3 Then Exit Sub
    
    If Target.Column = 1 Then                   '第一列数据发生变化时
        If Cells(r, 1).Value = "" Then
            Cells(r, 2).Value = ""
            Exit Sub
        End If
                              
        
        
         If VBA.Int(VBA.Val(VBA.Len(Cells(r, 1).Value) / 2 - 1)) <> VBA.Len(Cells(r, 1).Value) / 2 - 1 Or VBA.Len(Cells(r, 1).Value) / 2 - 1 > 6 Or VBA.Len(Cells(r, 1).Value) / 2 - 1 < 1 Then         '函数前都加上vba.   20210106
                                                                                                
                                
            MsgBox "异常提示：" & vbCrLf & "    第一列最新输入的科目代码的长度可能有问题，科目代码请按以下规则输入：一级科目总长4位，二级科目总长6位，三级科目总长8位，" _
                    & "四级科目总长10位，五级科目总长12位，六级科目总长14位。科目级次最大为六级。"
            Exit Sub
        End If
        
        
        Cells(r, 2).Value = VBA.Len(Cells(r, 1).Value) / 2 - 1
        
        
        If Cells(r, 2).Value > 1 Then
            For i = r To r - 800 Step -1
                If r = 3 Then Exit For
                If VBA.Len(Cells(i, 1).Value) / 2 - 1 = 1 And VBA.Left(Cells(r, 1).Text, 4) = VBA.Left(Cells(i, 1), 4) Then
                    Application.EnableEvents = False
                    Cells(r, 4).Value = Cells(i, 4).Value
                    Application.EnableEvents = True
                End If
            Next
        End If
        
        If Cells(r, 2).Value = 1 Then
            If Cells(r, 1).Value <= 1012 Then
                MsgBox "系统提示：根据本财务系统设置规则，科目代码开头四位为1012或以下的科目，本财务软件自动默认为货币资金类会计科目，在自动分析填报现金流量表时，视同货币资金类科目。科目代码开关四位大于1012的，本软件默认视为非货币资金类科目，不在现金流量表的统计范围内，新增会计科目时请知晓此规则。"
                Exit Sub            '提示后退出
            End If
        End If
        
        
        If VBA.Len(Cells(r, 1).Value) / 2 - 1 > 1 And VBA.Len(Cells(r, 1).Value) / 2 - 1 >= VBA.Len(Cells(r - 1, 1).Value) / 2 - 1 Then
            If VBA.Len(Cells(r, 1).Value) / 2 - 1 > VBA.Len(Cells(r - 1, 1).Value) / 2 - 1 Then
                    If VBA.str(VBA.Left(Cells(r, 1).Value, VBA.Len(Cells(r, 1).Value) - 2)) <> VBA.str(Cells(r - 1, 1).Value) Then
                        MsgBox "异常提示：" & vbCrLf & "    新增加科目与上行科目之间位置顺序或隶属关系异常，请检查。"
                        Exit Sub        '20200109
                    End If
                Else                '代码长度相同时，上级代码应一致
                    If VBA.Left(Cells(r, 1).Value, VBA.Len(Cells(r, 1).Value) - 2) <> VBA.Left(Cells(r - 1, 1).Value, VBA.Len(Cells(r - 1, 1).Value) - 2) Then
                        MsgBox "异常提示：" & vbCrLf & "    新增加科目与上行科目的上级科目应一致，此处不一致，异常请检查。"
                        Exit Sub        '20200109
                    End If
            End If
        End If
                
        
        On Error Resume Next                        '先删除所有分组显示
        Application.ScreenUpdating = False
        Cells.ClearOutline
        For i = 1 To 5
            ActiveSheet.Rows("1:4000").Ungroup
        Next
        
        '重设分级显示
        For i = 3 To 4000
            If Cells(i + 1, 1).Value = "" Then Exit For                                     '下行为空时（到最后一行时） 结束
            If VBA.Len(Cells(i + 1, 1).Value) <= VBA.Len(Cells(i, 1).Value) Then GoTo a800
            For ii = i + 1 To 2000
                If VBA.Len(Cells(ii + 1, 1).Value) <= VBA.Len(Cells(i, 1).Value) Then Exit For
            Next
            Rows(i + 1 & ":" & ii).Group
a800:
        Next
        Application.ScreenUpdating = True
    End If

    Select Case Target.Column
        Case 3
            Range(Cells(r, 3), Cells(r, 3)).IndentLevel = Cells(r, 2).Value - 1             '设置科目名称的左缩进
        Case 4
            If Target.Count > 1 Then Exit Sub       '不对可能的批量操作进行检查
            
            '(一）第四列，录入数据后
            If Target.Value <> "" Then
                
                If r > 3 And Cells(r, 1).Value <> "" And Cells(r - 1, 1).Value <> "" Then
                    If VBA.Left(Cells(r, 1).Value, 4) = VBA.Left(Cells(r - 1, 1).Value, 4) And VBA.Left(Cells(r, 4).Value, 3) <> VBA.Left(Cells(r - 1, 4).Value, 3) Then  '一级科目相同，科目类别不同时
                        
                        
                        MsgBox "错误提示： 当前选择的科目类别与上行科目类别不同，请重新选择。注意相同一级科目下的明细科目的科目类别应相同。"
                        Application.EnableEvents = False
                        Target = ""                                     '自动提示并清空当前录入的科目类别
                        Application.EnableEvents = True
                        Exit Sub
                    End If
                End If
        
                
                If Target.Value <> "资产类" And Target.Value <> "负债类" And Target.Value <> "净资产类" And Target.Value <> "事业收入类" And Target.Value <> "经营收入类" _
                    And Target.Value <> "事业支出类" And Target.Value <> "经营支出类" And Target.Value <> "权益类" And Target.Value <> "成本类" And Target.Value <> "损益类" _
                    And Target.Value <> "损益类（限定性）" Then
                
                    MsgBox "录入值不合规，请重新录入或重新选择当前位置后使用下拉菜单选择"
                    Target.Value = ""
                    Exit Sub
                End If
                
                With Target.Validation
                    .Delete
                End With
            End If
            
            
            If Target.Value = "" And Cells(r, 1).Value <> "" Then
                With Target.Validation                              '数据有效性
                    .Delete
                    
                    If Sheets("账套基础信息表").Cells(54, 3).Value = 20 Or ActiveSheet.Name = "科目设置表模板20" Then       '行政事业类时
                            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,净资产类,事业收入类,经营收入类,事业支出类,经营支出类"    '事业制度的下拉选项
                        Else
                            If Sheets("账套基础信息表").Cells(54, 3).Value = 10 Or ActiveSheet.Name = "科目设置表模板10" Then       '民非时
                                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,权益类,成本类,损益类,损益类（限定性）"    '民非时
                                Else
                                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="资产类,负债类,权益类,成本类,损益类"    '企业时
                            End If
                    End If
                    .IgnoreBlank = True    '空白时也可以   单元格内容可以是空白
                    .ShowError = False
                End With
            End If
            
        Case 5
            If Target.Count = 1 Then
                If Target.Value <> "" Then
                    With Target.Validation
                        .Delete
                    End With
                End If
                If Target.Value <> "" Then                  '有录入内容时
                    If Target.Value <> "借" And Target.Value <> "贷" Then
                        MsgBox "录入值不合规，请重新录入或重新选择当前位置后使用下拉菜单选择"
                        Target.Value = ""
                    End If
                End If
                If Target.Value = "" And Cells(r, 1).Value <> "" Then
                    With Target.Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="借,贷"
                        .IgnoreBlank = True
                        .ShowError = False
                    End With
                End If
            End If
            
        Case 6, 11
            If Target.Count = 1 Then
                If Target <> "" Then
                    If Target <> "是" Then
                            MsgBox " 提示：当前位置只能录入 是 或不录入，请勿录入其他内容。"    '20190221  增加录入内容验证
                            Target = ""
                            GoTo a228
                        Else
                            With Target.Validation
                                .Delete
                            End With
                    End If
                End If
            End If
            
            If Cells(r, Target.Column).Value = "是" Then
                If Target.Column = 6 Then                                                   '辅助核算列选是时
                        Sheets("凭证表").Columns("M:M").EntireColumn.Hidden = False
                        Sheets("科目设置表").Columns("G:G").EntireColumn.Hidden = False
                    Else                                                                    '11列时，数量核算列选是时
                        GoTo a1557
                        If Sheets("凭证表").Columns("J:J").ColumnWidth < 8 Then Sheets("凭证表").Columns("J:J").ColumnWidth = 10
                        If Sheets("凭证表").Columns("K:K").ColumnWidth < 8 Then Sheets("凭证表").Columns("K:K").ColumnWidth = 10        '数量贷
                        If Sheets("凭证表").Columns("L:L").ColumnWidth < 6 Then Sheets("凭证表").Columns("L:L").ColumnWidth = 8         '单价
a1557:
                        
                        If Sheets("科目设置表").Columns("L:L").ColumnWidth < 6 Then Sheets("科目设置表").Columns("L:L").ColumnWidth = 7         '科目设置表计量单位列自动显示
                End If
            End If
            
            
            For i = r + 1 To 5000
                If Cells(i, 1).Value = "" Then Exit For
                If VBA.Len(Cells(i, 1).Value) > VBA.Len(Cells(r, 1).Value) And VBA.Left(VBA.str(Cells(i, 1).Value), VBA.Len(VBA.str(Cells(r, 1).Value))) = VBA.str(Cells(r, 1).Value) Then
                    Application.EnableEvents = False
                    If Cells(r, Target.Column).Value = "是" Then
                            Cells(i, Target.Column).Value = "是"
                        Else
                            
                    End If
                    Application.EnableEvents = True
                End If
            Next
a228:
            
        Case 7
            
            
…