Malicious Office (OLE) / .XLS — malware analysis report

Attribute VB_Name = "CXlsApp"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'==============================================================================
'名称:                               CXlsApp                                  =
'说明:                               类模块                                   =
'作者:                                常曦                                    =
'时间:                              2008-11-5                                 =
'==============================================================================
Option Explicit

Private WithEvents AppExcel As Application  '申明一个当前工作簿对象
Attribute AppExcel.VB_VarHelpID = -1

Private PreviousSheet  As String  '上一张工作表名
Private LastSheet      As String  '最后一张工作表名
Public Path            As String  '当前工作簿所在路径
Public SheetCount      As Integer '工作簿所包含工作表数
Public FileName        As String  '上一张工作表名
Public FirstCell       As Range   '

'====================================================================================================================
'功能:插入一个外部工作簿中指定的工作表
'参数:sNewWorkBookPath-外部工作簿路径，SaveSheetsName-要保留的工作表名称序列
'返值:True;False
'作者:常曦
'时间:2009-5-13
'====================================================================================================================
Function InsertOutsideSheets(sOpenWorkBookPath As String, SaveSheetsName As String) As Boolean
    On Error GoTo er
'    Dim xlAppOut         As Excel.Application
    Dim xlWorkBook       As Excel.Workbook
    Dim xlSheet          As Excel.Worksheet
    Dim strFilePath      As String
    Dim strSheetName     As String
    Dim str()            As String
    Dim sName            As String
    Application.ScreenUpdating = False
    str = Split(SaveSheetsName, ",")
    strFilePath = Trim(sOpenWorkBookPath)
'    Set xlAppOut = CreateObject("Excel.application")
    Set xlWorkBook = Workbooks.Open(strFilePath)
    
    '插入表
    Windows(myExcel.FileName).Activate
    Application.Run "DisAlert"
    Dim i As Integer, j As Integer, isSome As Boolean
    For i = 0 To UBound(str)
        For j = 1 To ActiveWorkbook.Sheets.Count
            If str(i) = ActiveWorkbook.Sheets(j).Name Then
                isSome = True
                Exit For
            End If
        Next j
        If isSome = False Then
            '插入表
            xlWorkBook.Sheets(str(i)).Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            'ThisWorkbook.ActiveSheet.Move After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count) '将当前工作表移至工作表的最后
        Else
            '处理同名表
            If MsgBox("工作簿中已存在名为“" & str(i) & "”的工作表，将会被新插入表替换，仍然继续吗？     ", vbQuestion + vbOKCancel) = vbOK Then
                '删除原表
                Windows(myExcel.FileName).Activate
                ActiveWorkbook.Sheets(j).Delete
                '插入表
                xlWorkBook.Sheets(str(i)).Copy ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'                ActiveSheet.Move After:=ActiveWorkbook.Sheets(j - 1) '将当前工作表移至同名工作表位置
            End If
        End If
    Next i
    xlWorkBook.Close False
    Set xlSheet = Nothing
    Set xlWorkBook = Nothing
    InsertOutsideSheets = True
    Application.ScreenUpdating = True
    Exit Function
er:
    Application.ScreenUpdating = False
    InsertOutsideSheets = False
    MsgBox Err.Description, vbExclamation
    RecordErrInfo "ShowOutsideSheets(" & sOpenWorkBookPath & ") ", Err.Description, 3
    xlWorkBook.Close False
    Set xlSheet = Nothing
    Set xlWorkBook = Nothing
'    Set xlAppOut = Nothing
    On Error GoTo 0
End Function

'在此处理所有工作表初始化操作
Sub WithAllSheets()
    On Error Resume Next
    Dim i As Integer
    Application.ScreenUpdating = False
    For i = 2 To Sheets.Count
        '=================================================
        '1、插入背景图,只运行一次的临时代码，取代手工操作。
'        Sheets(i).SetBackgroundPicture "" '"E:\MyProject\项目管理\工程源码\国防动员信息综合管理系统\项目代码\支撑项目\模块_数据采集\Tab\Excel\背景.JPG" '""
        
        '=========================
        '2、隐藏表格
        Sheets(i).Visible = xlSheetVeryHidden '使用xlSheetVeryHidden常量来隐藏工作表，将不能通过“取消隐藏”命令来取消隐藏
    Next i
'        Sheets(MainSheet).SetBackgroundPicture "E:\MyProject\项目管理\工程源码\国防动员信息综合管理系统\项目代码\支撑项目\模块_数据采集\Tab\Excel\背景.JPG"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'==============================================================================
'功能:隐藏或显示所有用户表格
'参数:vl-表格是否显示,True-显示,False-隐藏，vShowAll-是否显示模板表,可选,默认否
'返值:无
'作者:常曦
'时间:2008-11-5
'==============================================================================
Function IsShowSheets(vl As Boolean, Optional vShowAll As Boolean = False)
    On Error Resume Next
    Dim i As Integer
    Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> MainSheet Then
            If vShowAll = False Then                        '只显示用户表格
                If vl = True Then
                    If IsModSheet(Sheets(i).Name) = False Then
                        Sheets(i).Visible = vl
                        Sheets(i).Tab.ColorIndex = i + 1
                    End If
                Else
                        Sheets(i).Visible = vl
                        Sheets(i).Tab.ColorIndex = i + 1
                End If
            Else                                            '显示所有工作表
                    Sheets(i).Visible = vl
                    Sheets(i).Tab.ColorIndex = i + 1
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Function

'===============================================================
'功能:设置右键菜单状态
'参数:sName-菜单项名称;vl-状态标识
'返值:无
'作者:常曦
'时间:2008-11-5
'===============================================================
Public Function DelRightMenuItem(sName As String, vl As Boolean)
  On Error Resume Next
  Dim a, b
  Dim sItemName() As String
  Dim i As Integer
  If Trim(sName) = vbNullString Then Exit Function
   GetItemName sName, sItemName
   For i = 1 To UBound(sItemName)
        Set a = Application.CommandBars.FindControls()
        For Each b In a
            If b.Caption = Trim(sItemName(i)) Then b.Enabled = vl
        Next
    Next i
  End Function
  
'====================================================================
'功能:获取菜单元素名称
'参数:sName-菜单项名称;ResultArry-包含元素名称结果的数组
'返值:无
'作者:常曦
'时间:2008-11-5
'====================================================================
Private Function GetItemName(sName As String, ResultArry() As String)
    On Error Resume Next
    Dim sTemp As String
    Dim i As Integer, j As Integer
    sTemp = Trim(sName)
    If sTemp = vbNullString Then Exit Function
    j = 0
    
nNext:
        i = InStr(1, sTemp, ",")
        If i <> 0 Then
            j = j + 1
            ReDim Preserve ResultArry(j) As String
            ResultArry(j) = Trim(Left(sTemp, i - 1))
            sTemp = Mid(sTemp, i + 1, Len(sTemp))
            GoTo nNext
        Else
            j = j + 1
            ReDim Preserve ResultArry(j) As String
            ResultArry(j) = Trim(sTemp)
        End If
End Function

'=========================================================
'功能:回到目录列表
'参数:无
'返值:无
'作者:常曦
'时间:2008-11-5
'=========================================================
Public Function MoveDirList()
    On Error Resume Next
    If AppExcel.ActiveSheet.Name <> MainSheet Then AppExcel.ActiveSheet.Visible = False
    Sheets(MainSheet).Activate '回到目录列表
End Function

'======================================================
'功能:判断当前表格是否为数据集模板表
'参数:sName-表名
'返值:Ture;False
'作者:常曦
'时间:2008-11-11
'======================================================
Public Function IsModSheet(sName As String) As Boolean
    On Error Resume Next
    If UCase(Left(Trim(sName), 2)) = UCase("M_") Then
        IsModSheet = True
    Else
        IsModSheet = False
    End If
End Function

Sub Test()
    Nextcol = Cells(1, 255).End(xlToLeft).Column '取从cells(1,255)向左查找到的第一个非空值单元格的列数，不含cells(1,255)，与连续与否无关，没查到时返回第一列列号
    Nextcol = Cells(1, 1).End(xlToRight).Column '取从cells(1,1)向右查找到的第一个非空值单元格的列数，不含cells(1,1)，与连续与否无关，没查到时返回最后一列列号
    Nextcol = Cells(65536, 1).End(xlUp).Row '取从cells(65536,1)向上查找到的第一个非空值单元格的行数，不含cells(65536,1)，与连续与否无关，没查到时返回第一行行号
    Nextcol = Cells(1, 1).End(xlDown).Row '取从cells(1,1)向下查找到的第一个非空值单元格的行数，不含cells(1,1)，与连续与否无关，没查到时返回最后一行行号
End Sub

'==========================================================
'取从cells(1,1)向下查找到的第一个非空值单元格的行数，不含
'cells(1,1)，与连续与否无关，没查到时返回最后一行行号
'获取工作表最大有效数据行值
'==========================================================
Public Function LastDataRow() As Long
    LastDataRow = ActiveSheet.Cells(1, 1).End(xlDown).Row
End Function

'==========================================================
'取从cells(1,1)向右查找到的第一个非空值单元格的列数，不含
'cells(1,1)，与连续与否无关，没查到时返回最后一列列号
'获取工作表最大数据列值
'==========================================================
Public Function LastDataCol() As Long
    LastDataCol = ActiveSheet.Cells(LastDataRow, 255).End(xlToLeft).Column
End Function

'获取工作表最大有效数据行值
Public Function SheetLastRow() As Long
'    SheetLastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row     '最大行数
    SheetLastRow = ActiveSheet.UsedRange.Rows.Count
End Function

'获取工作表最大列值
Public Function LastSheetCol() As Long
    LastSheetCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column     '最大列数
End Function

'添加新行
Public Sub AddNewLine()
    Rows("10:10").Select
'    Range("C10").Activate
    Selection.Copy
    Rows("11:11").Select
'    Range("C11").Activate
    Selection.PasteSpecial Paste:=xlPasteAll ', Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False '带格式复制一行单元格
'    Application.CutCopyMode = False
    Selection.ClearContents
End Sub

Private Sub AppExcel_SheetActivate(ByVal sh As Object)
'    MsgBox Sh.Name & " SheetActivate"
    If LastSheet <> vbNullString Then
        If LastSheet <> sh.Name Then
            PreviousSheet = LastSheet
            LastSheet = sh.Name
        End If
    Else
        LastSheet = sh.Name
        PreviousSheet = sh.Name
    End If
End Sub

Private Sub Class_Initialize()
    On Error Resume Next
    Set AppExcel = Application
    Path = ResumePath(ThisWorkbook.Path)
    SheetCount = ThisWorkbook.Sheets.Count
    FileName = ThisWorkbook.Name
End Sub

Private Sub Class_Terminate()

End Sub

'分离所有工作表
Public Function SaveAsForAllSheets(Optional sName As String = vbNullString, Optional DelSheet As Boolean = False)
    Dim s As Worksheet
    sName = Trim(sName)
    If Trim(sName) = vbNullString Then
        For Each s In Worksheets
            s.SaveAs Path & s.Name & ".xls"
            If DelSheet = True Then s.Delete
        Next
    Else
        For Each s In Worksheets
            If Trim(s.Name) = sName Then
                s.SaveAs Path & s.Name & ".xls"
                If DelSheet = True Then s.Delete
                Exit Function
            End If
        Next
    End If
End Function

'在单元格中插入图片
Sub InsertImage(sRange As String, sImgPath As String)
    Sheet1.Range(sRange).Select
    Sheet1.Pictures.Insert(sImgPath).Select
End Sub

'休复程序在根目录下运行的路径错误
Public Function ResumePath(sPath As String) As String
    On Error Resume Next
    If Right(sPath, 1) = "\" Then
        ResumePath = sPath
    Else
        ResumePath = sPath & "\"
     End If
End Function

Public Sub MovePrevious()
    If Trim(PreviousSheet) <> vbNullString Then AppExcel.Sheets(PreviousSheet).Visible = True: AppExcel.Sheets(PreviousSheet).Activate
End Sub

Public Sub MoveNext()
    If Trim(LastSheet) <> vbNullString Then AppExcel.Sheets(LastSheet).Visible = True: AppExcel.Sheets(LastSheet).Activate
End Sub

'====================================================================================================================
'功能:删除一个外部工作簿中的工作表
'参数:sNewWorkBookPath-外部工作簿路径，sNewWorkBookName-外部工作簿名称；SaveSheetsName-要保留的工作表名称序列
'返值:True;False
'作者:常曦
'时间:2009-5-13
'====================================================================================================================
Function DelOutsideSheets(sNewWorkBookPath As String, sNewWorkBookName As String, SaveSheetsName As String) As Boolean
    On Error GoTo er
    Dim xlApp            As Excel.Application
    Dim xlWorkBook       As Excel.Workbook
    Dim xlSheet          As Excel.Worksheet
    Dim strFilePath      As String
    Dim strSheetName     As String
    Dim str() As String
    str = Split(SaveSheetsName, ",")
    
    strFilePath = sNewWorkBookPath & sNewWorkBookName
    Set xlApp = CreateObject("Excel.application")
    Set xlWorkBook = xlApp.Workbooks.Open(strFilePath)
    
    '删除表
    xlApp.Run "DisAlert"
    Dim i As Integer, isDel As Boolean
    For Each xlSheet In xlWorkBook.Sheets
        isDel = True
        For i = 0 To UBound(str)
            If str(i) = xlSheet.Name Or InStr(1, xlSheet.Name, "M_") <> 0 Then
                isDel = False
                Exit For
            End If
        Next i
        If xlSheet.Name = MainSheet Then isDel = False
        xlApp.Visible = False
        If isDel = True Then xlSheet.Visible = True: xlSheet.Delete
    Next

    xlWorkBook.Save
    xlWorkBook.Close False
    Set xlSheet = Nothing
    Set xlWorkBook = Nothing
    Set xlApp = Nothing
    DelOutsideSheets = True
    Exit Function
er:
    DelOutsideSheets = False
    MsgBox Err.Description, vbExclamation
    RecordErrInfo "DelOutsideSheets(" & sNewWorkBookPath & ";" & sNewWorkBookName & ";" & SaveSheetsName & ") ", Err.Description, 3
    On Error GoTo 0
End Function

'====================================================================================================================
'功能:展示一个外部工作簿中所有的工作表
'参数:sNewWorkBookPath-外部工作簿路径，sNewWorkBookName-外部工作簿名称；SaveSheetsName-要保留的工作表名称序列
'返值:True;False
'作者:常曦
'时间:2009-5-13
'====================================================================================================================
Function ShowOutsideSheets(sOpenWorkBookPath As String) As Boolean
    On Error GoTo er
'    Dim xlAppOut         As Excel.Application
    Dim xlWorkBook       As Excel.Workbook
    Dim xlSheet          As Excel.Worksheet
    Dim strFilePath      As String
    Dim strSheetName     As String
    Dim str()            As String
    Dim sName            As String
'    str = Split(SaveSheetsName, ",")
    
    strFilePath = Trim(sOpenWorkBookPath)
    Set xlWorkBook = Workbooks.Open(strFilePath)
    Dim i As Integer, isDel As Boolean
    With frmIntoSheet.lstSheet
        For Each xlSheet In xlWorkBook.Sheets
            sName = Trim(xlSheet.Name)
            If sName <> MainSheet And UCase(Left(sName, 2)) <> UCase("M_") Then
                .AddItem sName
            End If
        Next
        xlWorkBook.Close False
        Set xlSheet = Nothing
        Set xlWorkBook = Nothing
        frmIntoSheet.txtSavePath = sOpenWorkBookPath
        frmIntoSheet.Show vbModal
    End With
    ShowOutsideSheets = True
    Exit Function
er:
    ShowOutsideSheets = False
    MsgBox Err.Description, vbExclamation
    RecordErrInfo "ShowOutsideSheets(" & sOpenWorkBookPath & ") ", Err.Description, 3
    xlWorkBook.Close False
    Set xlSheet = Nothing
    Set xlWorkBook = Nothing
'    Set xlAppOut = Nothing
    On Error GoTo 0
End Function



'=========================================================================================
'功能:弹出文件选择对话框
'参数:sType-选择文件类型(可选)，sTitle-对话框标题(可选)
'     iHeight-控件高度;iWidth-控件宽度
'返值:True;False
'作者:常曦
'时间:2008-11-12
'=========================================================================================
Function SelectOpenFile(Optional sType As String = "所有文件(*.*),*.*", Optional sTitle As String = "打开文件", Optional ResultPath As String, Optional ResultName As String) As String
'    Dim FileName As Variant
     '打开文件对话框返回的文件名，是一个全路径文件名，其值也可能是False，因此类型为Variant
'    Dim ResultName As String                         '从FileName中提取的文件名
'    Dim ResultPath As String                         '从FileName中提取的路径名
    Dim aFile As Variant                            '数组，提取文件名ResultName时使用
    Dim ws As Worksheet                             '存储文件路径名和文件名的工作表
'    Set ws = ActiveSheet                            '设置工作表
    Dim i As Integer
'    Application.DefaultFilePath = ThisWorkbook.Path 'ActiveWorkbook.FullName
'    ChDrive Left(ThisWorkbook.Path, 1)
'    ChDir ThisWorkbook.Path
    sOpenFileName = Application.GetOpenFilename(sType, , sTitle) '("视频文件(*.mpg),*.mpg", , "选择文件")

    If sOpenFileName = "False" Then
        sOpenFileName = vbNullString
        Exit Function
    End If
'    '调用Windows打开文件对话框
'    If FileName <> False Then                       '如果未按“取消”键
        aFile = Split(sOpenFileName, "\")                '在全路径中，以“\”为分隔符，分成数据
        ResultPath = aFile(0)                        '取盘符
        For i = 1 To UBound(aFile) - 1              '循环合成路径名
            ResultPath = ResultPath & "\" & aFile(i)
        Next
        ResultPath = ResultPath & "\"
        ResultName = aFile(UBound(aFile))            '数组的最后一个元素为文件名
'        sOpenFileName = ResultPath                   '保存路径名
'        sOpenFileName = ResultName                   '保存文件名
        SelectOpenFile = ResultPath & ResultName
'    End If
End Function

Function SelectSaveFile(Optional sFileName As String = "", Optional sType As String = "所有文件(*.*),*.*", Optional sTitle As String = "保存文件", Optional ResultPath As String, Optional ResultName As String) As String
    Dim aFile As Variant                            '数组，提取文件名ResultName时使用
    Dim ws As Worksheet                             '存储文件路径名和文件名的工作表
    Dim i As Integer
    ChDrive Left(Path, 1)
    ChDir Path
    sOpenFileName = Application.GetSaveAsFilename(sFileName, sType, , sTitle)   '("视频文件(*.mpg),*.mpg", , "选择文件")
    If sOpenFileName = "False" Then
        sOpenFileName = vbNullString
        Exit Function
    End If
    aFile = Split(sOpenFileName, "\")                '在全路径中，以“\”为分隔符，分成数据
    ResultPath = aFile(0)                        '取盘符
    For i = 1 To UBound(aFile) - 1              '循环合成路径名
        ResultPath = ResultPath & "\" & aFile(i)
    Next
    
    ResultPath = ResultPath & "\"
    ResultName = aFile(UBound(aFile))            '数组的最后一个元素为文件名
    SelectSaveFile = ResultPath & ResultName
End Function

Function SaveAll(sPath As String)
    sPath = Trim(sPath)
    ActiveWorkbook.SaveCopyAs sPath
End Function

Function myWorkNames(sPath As String) As Boolean
    Dim sName As String
    sPath = Trim(sPath)
    GetFileName Trim(sPath), sName
    sName = GetFileNameNoExt(sName)
    Select Case Trim(sName)
        Case "综合情况"
            myWorkNames = True
            Exit Function
        Case "人民武装"
            myWorkNames = True
            Exit Function
        Case "经济动员"
            myWorkNames = True
            Exit Function
        Case "人民防空"
            myWorkNames = True
            Exit Function
        Case "交通战备"
            myWorkNames = True
            Exit Function
        Case "政治动员"
            myWorkNames = True
            Exit Function
        Case "科技信息动员"
            myWorkNames = True
            Exit Function
        Case "医疗救护"
            myWorkNames = True
            Exit Function
        Case "军工生产"
            myWorkNames = True
            Exit Function
        Case "装备动员"
            myWorkNames = True
            Exit Function
        Case Else
            myWorkNames = False
            Exit Function
    End Select
End Function

'获取数据区第一行所在单元格值
Function DataFirstCol(Optional ResultRange As Range) As String
    On Error Resume Next
    Dim C As Range
    Set C = Sheets("M_数据输出").[a:b].Find(ThisWorkbook.ActiveSheet.Name, , , 1)
    If Not C Is Nothing Then
           DataFirstCol = C.Offset(0, 10)
           Set FirstCell = ThisWorkbook.ActiveSheet.Range(DataFirstCol)
           Set ResultRange = FirstCell
    Else
           DataFirstCol = vbNullString
    End If
End Function

'获取数据区第一行所在行值
Function DataFirstRow() As Long
   On Error Resume Next
    Dim C As Range, D As Range, sCol As String, iCol As Long
    Set C = Sheets("M_数据输出").[a:b].Find(ThisWorkbook.ActiveSheet.Name, , , 1)
    Set D = Sheets("M_数据输出").[a:ZZ].Find("数据区启始单元格", , , 1)
    iCol = D.Column - C.Column
    If Not C Is Nothing Then
           sCol = C.Offset(0, iCol)
           Set FirstCell = ThisWorkbook.ActiveSheet.Range(sCol)
           DataFirstRow = FirstCell.Row
    Else
           DataFirstRow = -1
    End If
End Function

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
Option Explicit

Public WithEvents myApp As Application '声明myApp为一个带有事件的 Application 类型对象
Attribute myApp.VB_VarHelpID = -1
Public myWorkBookName As String, mySheetName As String, myPreviousSheet As String

Private Sub myApp_SheetActivate(ByVal sh As Object)
    myWorkBookName = sh.Parent.Name                  '当前工作簿
    mySheetName = sh.Name                            '当前工作表
    Call myExcel.DelRightMenuItem(sDelMenuName, False)
End Sub

Private Sub Workbook_Activate()
    On Error GoTo er
    Application.EnableEvents = False
    Call WithDir
    Call WithMyMenu                 '初始化自定义菜单
    Call AddNavBar
    Application.EnableEvents = True
    Exit Sub
er:
    Exit Sub
End Sub

'第一入口
Private Sub Workbook_Open()
    On Error Resume Next
    MainSheet = "目录" ' & GetFileNameNoExt(myExcel.FileName)
'    Application.Visible = False
    Call DelSheetsDir
    myExcel.IsShowSheets False
    Call Loadfrmlogin
'    Set myExcel.AppExcel = Application  '实例化当前工作簿
'    myExcel.AppExcel.EnableEvents = True
    If UserName = ProjectManage Or UserName = ProjectUpdate Then
        SetUserMenuState True
    Else
        SetUserMenuState False
    End If
    Set myApp = Application
    Call myExcel.DelRightMenuItem(sDelMenuName, False)
'    Call DelMainMenu(False)
    Call RegMyDllAndTemplate
    Call WorkAllTo
    Call WithProjectCopy              '版本信息
    Call WithDir
End Sub

Sub Loadfrmlogin()
    With frmlogin
        .MultiPage1.Value = 0
        .MultiPage1.Pages(1).Enabled = False
        .MultiPage1.Pages(0).Enabled = True
        .Show
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
    Call myExcel.DelRightMenuItem(sDelMenuName, True)
    Call DelMainMenu(True)
    Call ResumeExcelMenu                              '恢复Excel默认界面风格
'ThisWorkbook.Close '考虑到用户可能打开了多个Excel对象,所以只针对本系统退出
End Sub

Private Sub Workbook_Deactivate()
On Error Resume Next
    Call myExcel.DelRightMenuItem(sDelMenuName, True)
    Call ResumeExcelMenu
    Call DelNavBar
End Sub

'===================================================================
'功能:将源码插入到工作表中,用在设计模式下,可省去对重复代码的拷贝工作
'参数:iSheet-工作表索引号
'返值:无
'作者:常曦
'时间:2008-11-5
'===================================================================
Function InsertCodeToSheet(iSheet As Integer)
    With ActiveWorkbook.VBProject.VBComponents(iSheet + 1).CodeModule
     .INSERTLINES 1, "Private Sub Worksheet_Change(ByVal Target As Range)"
     .INSERTLINES 2, "If Target.Column = 2 And Target.Row > 1 And Target.Value <> """" Then"
     .INSERTLINES 3, "Target.Offset(0, -1) = Len(Target.Text)"
     .INSERTLINES 4, "ElseIf Target.Column = 3 And Target.Row > 1 And Target.Value <> """" Then"
     .INSERTLINES 5, "Target.Offset(0, -2) = Len(Target.Offset(0, -1).Text)"
     .INSERTLINES 6, "End If"
     .INSERTLINES 7, "End Sub"
    End With
End Function

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
    Call DelSheetsDir
End Sub





Attribute VB_Name = "Sheet2"
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

Attribute VB_Name = "Sheet21"
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
Attribute VB_Control = "imgCutSheet, 10, 4, MSForms, Image"
Attribute VB_Control = "imgAddSheet, 11, 5, MSForms, Image"
Attribute VB_Control = "imgSetAuth, 12, 6, MSForms, Image"
Attribute VB_Control = "imgSysHelp, 13, 7, MSForms, Image"
Option Explicit

Private EditLoca As CellInfo '单元格位置信息对象

Private Sub imgAddSheet_Click()
    On Error Resume Next
    Dim sFiles As String
    Dim sPath As String
    Dim sName As String
    sFiles = myExcel.SelectOpenFile("Excel 工作簿(*.xls),*.xls", "插入工作表", sPath, sName)
    If Trim(sFiles) = vbNullString Then Exit Sub
'    If Dir(sFiles, vbNormal + vbReadOnly + vbHidden + vbSystem) <> vbNullString Then
'        If MsgBox("指定文件已存在，是否替换原有文件？　　　", vbOKCancel + vbInformation) = vbCancel Then Exit Sub
'    End If
    '保存文件
'    txtSavePath.Text = sFiles
    '检查当前要打开文件是否为同名文件
    If CheckSomeName(sFiles) = True Then
        MsgBox "不能打开与当前工作簿同名的文件，请将该文件更名后再执行此操作！     ", vbInformation, "文件名称冲突"
        Exit Sub
    Else
        myExcel.ShowOutsideSheets sFiles
    End If
End Sub

Private Sub imgCutSheet_Click()
 '    Call myExcel.DelOutsideSheets(myExcel.Path, "OK.XLS", "武装机构")   'DelNothingSheets
    frmExportSheet.Show vbModal 'vbModeless
End Sub

Private Sub imgSetAuth_Click()
        With frmlogin
'''        .MultiPage1.Value = 1
'''        .MultiPage1.Pages(0).Enabled = False
'''        .MultiPage1.Pages(1).Enabled = True
        .labTab.Visible = True
        .lblUser.Visible = True
        .Label4.Visible = True
        .Label5.Visible = True
        .Label6.Visible = True
        .txtNewPwd1.Visible = True
        .txtNewPwd2.Visible = True
        .txtOldPwd.Visible = True
        .txtOldPwd.SetFocus
        .Show
    End With
'    Cells.Hyperlinks.Delete
End Sub

Private Sub imgSysHelp_Click()
    Call RunHelp
    
    'AppActivate (Shell("C:\Windows\System32\notepad.exe")) '("C:\Program Files\Microsoft Office\OFFICE11\2052\msohelp.exe"))
''    frmTop.Show vbModeless
''    Application.CommandBars("Task Pane").Visible = False
''    Application.CommandBars("Task Pane").Visible = True
'    Application.Dialogs(302).Show
End Sub

Private Sub Worksheet_Activate()
    Call WithMe
    '日期控件无效
'    DTPicker1.Visible = False
'    GetLastCell EditLoca.iLastRow, EditLoca.iLastCol, False
'    Application.StatusBar = "本表用户编辑区域起始行、列为 (" & EditLoca.iFirstRow & "," & EditLoca.iFirstCol & ") 终止行、列为(" & EditLoca.iLastRow - 1 & "," & EditLoca.iLastCol & ")"
End Sub

Private Sub Worksheet_Deactivate()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Set ChkData = New CCheckData
'ChkData.IsType ActiveCell.Text
    On Error GoTo er
    Call WithMe
    '用户右键点击时不作处理
    If GetAsyncKeyState(&H2) <> 0 Then
'        myExcel.DelRightMenuItem "剪切(&T),粘贴(&P)", False
        Exit Sub
    Else
'        myExcel.DelRightMenuItem "剪切(&T),粘贴(&P)", True
    End If
        
    If Target.Column = 2 And Target.Row = 1 Then
        Call RefreshSheet
    End If
    
    Application.ScreenUpdating = False
    If Target.Application.ActiveCell = "显示所有工作表" And (Application.ActiveCell.Row = EditLoca.iLastRow And Application.ActiveCell.Column = 1) Then
        If UserName = ProjectManage Then
            myExcel.IsShowSheets True, True '显示用户及模板表格
        Else
            myExcel.IsShowSheets True, False '显示用户及模板表格
        End If
        Target.Application.ActiveCell = "隐藏所有工作表"
    ElseIf Application.ActiveCell.Row = EditLoca.iLastRow And Application.ActiveCell.Column = 1 Then
            Target.Application.ActiveCell = "显示所有工作表"
            myExcel.IsShowSheets False
    End If
    ActiveSheet.Range("A1").Select '切出焦点，为响应下一次点击同一单元格作准备

    If Application.Intersect(Target, [B2:B18]) Is Nothing Then '如果没有点击在包含表格名称的列上则不处理。
        Exit Sub
    End If
    Sheets(CStr(Target)).Visible = True
    Sheets(CStr(Target)).Activate
    Application.ScreenUpdating = True

Exit Sub
er:
    Exit Sub
End Sub

Sub WithMe()
    EditLoca.iFirstRow = 0
    EditLoca.iFirstCol = 0
    EditLoca.iLastRow = 19
    EditLoca.iLastCol = 1
End Sub
''===================================
''功能:当前单元格是否为最后有效单元格
''参数:iRow-;iCol-;
''返值:Ture;False
''作者:常曦
''时间:2008-11-5
''===================================
'Function IsLastCell(iRow As Integer, Optional iCol As Integer) As Boolean
''    Dim iLastRow As Integer
''    Dim iLastCol As Integer
''    iLastRow = Selection.SpecialCells(xlCellTypeLastCell).Row     '当前表最后有效单元格所在行
''    iLastCol = Selection.SpecialCells(xlCellTypeLastCell).Column  '当前表最后有效单元格所在列
''    Selection.SpecialCells(xlCellTypeLastCell).Select
'    If iRow = 22 And iCol = 1 Then
'        IsLastCell = True
'    Else
'        IsLastCell = False
'    End If
'End Function






Attribute VB_Name = "frmIntoSheet"
Attribute VB_Base = "0{098D323E-7B14-49A0-BD50-610F3CEE5A76}{8AB983C3-E1DF-4BEB-A83C-06BDF5040217}"
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 cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdMoveToLeft_Click()
    Dim i As Integer
    With lstSheetSave
nNext:
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                lstSheet.AddItem .List(i)
                .RemoveItem i
                GoTo nNext
            End If
        Next i
    End With
    Call EnabledCmd
End Sub

Private Sub cmdMoveToRight_Click()
    Dim i As Integer
    With lstSheet
nNext:
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                lstSheetSave.AddItem .List(i)
                .RemoveItem i
                GoTo nNext
            End If
        Next i
    End With
    Call EnabledCmd
End Sub

Sub EnabledCmd()
    With cmdOK
        .Enabled = CBool(lstSheetSave.ListCount)
    End With
End Sub

Private Sub cmdOK_Click()
    If InStr(1, txtSavePath.Text, ":") = 0 Or InStr(1, txtSavePath.Text, "\") = 0 Then
        MsgBox "无效路径！请检查后重新输入。     ", vbExclamation, MyAppTitle
        Exit Sub
    End If

    Dim i As Integer, sSheets As String
    For i = 0 To lstSheetSave.ListCount - 1
        sSheets = sSheets & lstSheetSave.List(i) & ","
    Next i
    sSheets = Left(sSheets, Len(sSheets) - 1)
    If myExcel.InsertOutsideSheets(Trim(txtSavePath.Text), sSheets) = True Then
        MsgBox "插入表成功。     ", vbInformation, MyAppTitle
        Unload Me
    End If
End Sub

Private Sub UserForm_Click()

End Sub

Attribute VB_Name = "frmExportSheet"
Attribute VB_Base = "0{8B267BF4-3213-4D33-BDB7-D68E8C4E27CA}{29E1943A-FE98-41C0-A277-5F4F0031E0FD}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False




Option Explicit

Public sFilesPath As String
Public sFilesName As String

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdMoveToLeft_Click()
    Dim i As Integer
    With lstSheetSave
nNext:
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                lstSheet.AddItem .List(i)
                .RemoveItem i
                GoTo nNext
            End If
        Next i
    End With
    cmdOK.Enabled = CBool(lstSheetSave.ListCount)
End Sub

Private Sub cmdMoveToRight_Click()
    Dim i As Integer
    With lstSheet
nNext:
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                lstSheetSave.AddItem .List(i)
                .RemoveItem i
                GoTo nNext
            End If
        Next i
    End With
    Call EnabledCmd
End Sub

Function IsSelected(lstBox As ListBox) As Boolean
    IsSelected = False
    With lstBox
        Dim i As Integer
        For i = 0 To .ListCount - 1
            If .Selected(i) = True Then
                IsSelected = True
                Exit For
            End If
        Next i
    End With
End Function

Private Sub cmdOK_Click()
    If Trim(txtSavePath.Text) = vbNullString Then
        MsgBox "请为新建工作簿指定保存路径与名称。     ", vbInformation, MyAppTitle
        Exit Sub
    End If
    If InStr(1, txtSavePath.Text, ":") = 0 Or InStr(1, txtSavePath.Text, "\") = 0 Then
        MsgBox "无效路径！请检查后重新输入。     ", vbExclamation, MyAppTitle
…