Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "FrmUp"
Attribute VB_Base = "0{08F728B3-C769-406B-BC72-5EB3BF45B8F0}{E9CBF2BC-1FC4-4649-8A60-853E08ECFB01}"
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

Private Sub UserForm_Activate()
    Me.Caption = "台帳バージョンアップ" & vChk
    Call update
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_Control = "CommandButton1, 7, 0, MSForms, CommandButton"
Attribute VB_Control = "CommandButton2, 8, 1, MSForms, CommandButton"
Option Explicit
Private Sub CommandButton1_Click()
    If Not IsExistRibbon("セルズサポート") Then
        
    Else
        Call 開く
    End If
    
End Sub

Private Sub CommandButton2_Click()
    Call 終了
End Sub


Private Sub CommandButton3_Click()
    OpenTxt (ThisWorkbook.Path & "\UpFile\使用許諾について.txt")
End Sub

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
Private Sub Workbook_Open()
    
    Dim i As Long
    Dim Wb As Workbook
    Dim strpath As String
    Dim MyStr3 As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    i = 0
    For Each Wb In Workbooks
        If Wb.Name Like "DaMenu*" Then
            i = 1
            Exit For
        End If
    Next
    
    If i = 0 Then
        MsgBox "現在の「台帳」を起動して実行してください。", 16, "アップ"
        ThisWorkbook.Close False
    End If

    If Workbooks("DaMenu.xls").ReadOnly Then
        MsgBox "他のパソコンで「台帳ＭＥＮＵ」が起動しています。" & vbCr _
        & "終了してからバージョンアップを行ってください。", vbCritical, "アップ"
        ThisWorkbook.Close False
        Exit Sub
    End If
    
    Range("A1").ClearContents
    
    strpath = PathCombine(Workbooks("DaMenu.xls").Path, "ver.txt")
        
    Open strpath For Input As #1
        Input #1, MyStr3
    Close #1

    'バージョン番号取得
    ThisWorkbook.Worksheets("MENU").Shapes("VerNo").TextFrame.Characters.Text = vChk
    'バージョン番号取得
    ThisWorkbook.Worksheets("MENU").Shapes("VerNo2").TextFrame.Characters.Text = vChk

      'アップ対象判別
    If Not Left(MyStr3, 1) <> "V" Then
        MyStr3 = Mid(MyStr3, 2) & ".00"
    End If
   
    If Replace(MyStr3, ".", "") < Replace(Replace(oChk, ".", ""), "V", "") Or Replace(MyStr3, ".", "") > Replace(Replace(vChk, ".", ""), "V", "") Then
        MsgBox "お使いのバージョンは、こちらのバージョンアップをお使いいただくことができません。" & vbCr & "ご確認ください。", vbCritical, "アップ"
        Application.DisplayAlerts = False
        Call Endrtn
        Exit Sub
    End If
       
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    

End Sub







Attribute VB_Name = "Module1"
Option Explicit
#If Win64 Then
#Else
Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Public Const vChk = "V9.00.29"
Public Const oChk = "V9.00.28"

Public Const vName = "90029"
Public Fname1(2)         As String
Dim aFile(2)            As String
Dim dPath       As String
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&
Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" ( _
    ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long
    
Private Const NEW_DLL_VER As String = "2.11.0.5"
Private Const EGOV_DLL_PATH As String = "cells\台帳電子申請ツール\egov.dll"
Private Const ROLE_SYSTEM_PAGETABLIST = &H3C
Private Const ROLE_SYSTEM_PAGETAB = &H25
Private Const CHILDID_SELF = 0&

Sub 開く()
    If MsgBox("バージョンアップを開始します。よろしいですか？", 1 + 32, "アップ") <> 1 Then Exit Sub
    FrmUp.Show
End Sub
Sub 終了()
    If MsgBox("バージョンアップを終了しますか？", vbYesNo, "バージョンアップ") = vbYes Then
        Call Endrtn
        Exit Sub
    End If
End Sub
Sub Endrtn()
    Dim Fcnt        As Integer
    Dim Wb          As Workbook

    '開いているブック数
    Fcnt = Workbooks.Count
    'PERSONAL.XLSを探して、見つかったら数に入れない
    For Each Wb In Workbooks
        If StrConv(Wb.Name, vbUpperCase) = "PERSONAL.XLSB" Then
            Fcnt = Fcnt - 1
        End If
    Next Wb
    Application.DisplayAlerts = False
    If Fcnt = 1 Then
        Application.Quit
        Exit Sub
    Else
        Workbooks("バージョンアップ.xls").Close False
        Exit Sub
    End If
End Sub
Sub update()

    Dim ファイル        As String
    Dim Wb              As Workbook
    Dim myFSO             As Object
    Dim IsFileExists    As Boolean
    Dim myPath          As String
    Dim mCnt            As Integer
    Dim i               As Long
    Dim MyFolder As Folder
    Dim MyAry() As Variant
    

    Application.DisplayAlerts = False
    
    ThisWorkbook.Worksheets("MENU").Cells(1, 2).Value = Workbooks("DaMenu.xls").Path
    dPath = ThisWorkbook.Worksheets("MENU").Cells(1, 2).Value
    
    Application.EnableEvents = False
    
    Workbooks("DaMenu.xls").Close
    
    On Error Resume Next
    Workbooks("DaAddin.xla").Close
    Workbooks("Addtin.xls").Close
    Workbooks("CellsSupport.xlam").Close
    Workbooks("EAppCom.xla").Close
    Workbooks("業務日誌.xlam").Close
    Workbooks("cellsdrive.xlam").Close
    On Error GoTo 0
    Application.EnableEvents = True
    
    For Each Wb In Workbooks
        If StrConv(Wb.Name, vbUpperCase) = "ツール.XLS" Then
            Workbooks("ツール.xls").Close
        End If
    Next Wb
    
    
   'バックアップを取る
    Call バックアップ("DaProcess", 1)
'    Call バックアップ("DaProcess\書式集", 2)
'    Call バックアップ("業務日誌", 3)
'    Call バックアップ("DaProcess\賃金管理", 4)
'    Call バックアップ("MNRelevance", 5)
'    Call バックアップ("DaProcess\就業規則", 6)
'    Call バックアップ("DaProcess\DaData", 7)

    'ファイルの入替
    Set myFSO = New Scripting.FileSystemObject
    
    ファイル = Dir(ThisWorkbook.Path & "\UpFile\*")
    Do While ファイル <> ""
        If ファイル <> "バージョンアップ.xls" Then
            FrmUp.Label1.Caption = ファイル & "をコピーしています。"
            myFSO.CopyFile ThisWorkbook.Path & "\UpFile\" & ファイル, dPath & "\" & ファイル
            DoEvents
        End If
        ファイル = Dir()
    Loop
    i = 0
    'フォルダの入替
    mCnt = 0
    myPath = ThisWorkbook.Path & "\UpFile"
'    Set myFSO = CreateObject("Scripting.FileSystemObject")
        With myFSO
            With .GetFolder(myPath)
                If .SubFolders.Count <> 0 Then
                    ReDim MyAry(1 To .SubFolders.Count, 1 To 1)
                    For Each MyFolder In .SubFolders
                        i = i + 1
                        MyAry(i, 1) = MyFolder.Name
                    Next
                    mCnt = 1
                End If
            End With
        End With
    If mCnt <> 0 Then
        For i = LBound(MyAry, 1) To UBound(MyAry, 1)

'            If MyAry(i, 1) <> "業務日誌" And MyAry(i, 1) <> "MNRelevance" Then
                myFSO.CopyFolder myPath & "\" & MyAry(i, 1), dPath & "\" & MyAry(i, 1)
                FrmUp.Label1.Caption = MyAry(i, 1) & "をコピーしています。"
'            End If
        Next i
        Erase MyAry
    End If
        
    '台帳フォルダ内にある、パスワードのファイルをTEMPにうつす
    'もし同名ファイルがTEMPにあったら、台帳フォルダ内のファイルは削除
    MoveNumericFile ThisWorkbook.Worksheets("MENU").Cells(1, 2).Value

   
    FrmUp.Label1.Caption = ""
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "バージョンアップは終了しました。 " & vbCrLf & "バージョンアップ内容は台帳サポートホームページにてご確認ください。 ", vbOKOnly, "バージョンアップ"
    
    Call Endrtn
        
End Sub

Sub モジュール入替()
    Dim n           As Integer
    Dim MyArray()   As String
    Dim sCnt        As Integer
    Dim i           As Integer
    Dim Fcnt        As Integer
    Dim Wb          As Workbook
    Dim maxCnt      As Long
    
    
    On Error GoTo Error_Rtn
    maxCnt = 1
    
    For sCnt = 0 To maxCnt
nextF:
        DoEvents
        FrmUp.Label1.Caption = Fname1(sCnt) & "を処理しています。"
        FrmUp.Repaint

        If Dir(dPath & "\DaProcess\" & Fname1(sCnt), vbNormal) <> "" Then
            Workbooks.Open ThisWorkbook.Path & "\モジュール入替\" & "A" & Fname1(sCnt)
            Workbooks.Open dPath & "\DaProcess\" & Fname1(sCnt)
            Workbooks(Fname1(sCnt)).Activate
                
            n = Worksheets.Count
            ReDim MyArray(1 To n)
            
            For i = 1 To n
                MyArray(i) = Worksheets(i).Name
            Next
            
            Workbooks(Fname1(sCnt)).Activate
            Sheets(MyArray).Move Before:=Workbooks("A" & Fname1(sCnt)).Sheets(1)
            Workbooks("A" & Fname1(sCnt)).Activate
            Sheets("Dummy").Delete
            Application.EnableEvents = False
            ActiveWorkbook.Save
            Workbooks("A" & Fname1(sCnt)).Close
            Workbooks.Open ThisWorkbook.Path & "\モジュール入替\" & "A" & Fname1(sCnt)
            ActiveWorkbook.SaveAs dPath & "\DaProcess\" & Fname1(sCnt)
            Workbooks(Fname1(sCnt)).Close
            
'            ActiveWorkbook.Close
            Application.EnableEvents = True
        
        End If
    Next sCnt
    ThisWorkbook.Activate
    Exit Sub
Error_Rtn:
    On Error Resume Next

    '開いているブック数
    Fcnt = Workbooks.Count
    'PERSONAL.XLSを探して、見つかったら数に入れない
    For Each Wb In Workbooks
        If StrConv(Wb.Name, vbUpperCase) = Fname1(sCnt) Then
            Workbooks(Fname1(sCnt)).Close False
        ElseIf StrConv(Wb.Name, vbUpperCase) = "A" & Fname1(sCnt) Then
            Workbooks("A" & Fname1(sCnt)).Close False
        End If
    Next Wb
    sCnt = sCnt + 1
    If sCnt > maxCnt Then
        Exit Sub
    End If
    GoTo nextF
End Sub

Sub バックアップ(fPath, rCnt)
    Dim i As Integer
    
'処理ファイルのバックアップ(ユーザー定義ファイル）-----------------------------------------------
    If Dir(dPath & "\Temp", vbDirectory) = "" Then 'Tempフォルダを作成
        MkDir dPath & "\Temp"
    End If
    
    For i = 100 To Cells(1000, rCnt).End(xlUp).Row
        If Dir(dPath & "\" & fPath & "\" & Cells(i, rCnt).Value) <> "" Then  'バックアップするファイルがあれば（念のため）
            If Dir(dPath & "\Temp\" & vName & Cells(i, rCnt).Value) = "" Then    '初めてのバックアップだったら（2回目以降は上書きできないように)
                FileCopy dPath & "\" & fPath & "\" & Cells(i, rCnt).Value, dPath & "\Temp\" & vName & Cells(i, rCnt).Value
                FrmUp.Label1.Caption = Cells(i, 1).Value & "をバックアップしています。"
                DoEvents
            End If
        End If
    Next


''今回だけ追加
'FileCopy dPath & "\" & "\個人情報取込.xls", dPath & "\Temp\" & vName & "個人情報取込.xls"

End Sub
Public Function PathCombine(ByVal path1 As String, ByVal path2 As String) As String

    If Right(path1, 1) = "\" Then
        PathCombine = path1 & path2
    Else
        PathCombine = path1 & "\" & path2
    End If

End Function
Private Function IsFolderExist(ByVal FolderName As String, Optional ByVal Sw As Boolean = False) As Boolean

    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(FolderName) Then
        IsFolderExist = True
    Else
        If Sw Then
            FSO.CreateFolder FolderName
            IsFolderExist = True
        Else
        IsFolderExist = False
        End If
    End If
    
    Set FSO = Nothing

End Function
Sub WRITE_TextFile(FileNam)
    Dim FSO As New FileSystemObject ' FileSystemObject
    Dim GYO As Long                 ' 収容するセルの行
    Dim GYOMAX As Long              ' データが収容された最終行
    Dim OldstrREC() As String
    Dim intFF As Integer            ' FreeFile値
    Dim X(2) As String
    Dim i As Long
    
    ' 最終行の取得
    ' 指定ファイルをOPEN(出力モード)
    

    ' FreeFile値の取得(以降この値で入出力する)
    GYO = 1
    GYOMAX = 2201
    ReDim OldstrREC(GYOMAX, 2)
    
    intFF = FreeFile
    Open FileNam For Input As #intFF
    Do Until GYOMAX < GYO
        If EOF(intFF) Then
            GYOMAX = GYO
            Exit Do
        End If
        Input #intFF, X(1)
        Input #intFF, X(2)
        
        OldstrREC(GYO, 1) = X(1)
        OldstrREC(GYO, 2) = X(2)
        
        GYO = GYO + 1
    Loop
    ' 指定ファイルをCLOSE
    Close #intFF
    
    GYO = 1
    intFF = FreeFile
    Open FileNam For Output As #intFF
    Do Until GYOMAX < GYO
        
        If GYO = 1 Then
            Write #intFF, "1.5", "1.3"
        Else
            Write #intFF, OldstrREC(GYO, 1), OldstrREC(GYO, 2)
        End If
        GYO = GYO + 1
    Loop
    
    Close intFF

End Sub

Sub OpenTxt(strpath)
    Dim lngRet As Long
    
    lngRet = ShellExecute(0, "Open", strpath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            MsgBox "ファイルを開くことができません。", 16, "利用許諾"
        Case ERROR_FILE_NOT_FOUND
            MsgBox "ファイルがありません。", 16, "利用許諾"
    End Select
End Sub
Public Sub MoveNumericFile(ByVal str As String)

    Dim FSO As Object
    Dim Folder As Object
    Dim FileObj As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(str)
    
    For Each FileObj In Folder.Files
        If IsNumeric(FSO.GetBaseName(FileObj.Path)) And _
            LCase(FSO.GetExtensionName(FileObj.Path)) = "exe" Then
'            Debug.Print FileObj.Name
            On Error GoTo ERR_ROUTIN
            FSO.MoveFile FileObj.Path, Environ("TEMP")
            On Error GoTo 0
'            FSO.CopyFile FileObj.Path, Environ("TEMP"), True
'            FSO.DeleteFile FileObj.Path
        End If
    Next
    
    Set FSO = Nothing

    Exit Sub
ERR_ROUTIN:
    Select Case Err.Number
        Case 58 '同名ファイルがある
            FSO.DeleteFile FileObj.Path
        Case Else
    End Select
    Resume Next
End Sub
'''
''' ファイルのバージョンを調べる
'''
Public Function GetFileVersion(ByVal fname As String)

    Dim objFso As Object
    
    Set objFso = CreateObject("Scripting.FileSystemObject")
    
    If objFso.FileExists(fname) Then
        GetFileVersion = objFso.GetFileVersion(fname)
    Else
        GetFileVersion = vbNullString
    End If

    Set objFso = Nothing

End Function
Public Function GetEGovDLLFileVersion() As String

    Dim EgovDllPath As String

    EgovDllPath = PathCombine(VBA.Interaction.Environ("ProgramFiles"), EGOV_DLL_PATH)
    
    GetEGovDLLFileVersion = GetFileVersion(EgovDllPath)

End Function
'''
''' 一括申請ツールをインストールが必要か返す
'''
Public Function IsInstallEgovDll() As Boolean
 
    If NEW_DLL_VER > GetEGovDLLFileVersion Then
        IsInstallEgovDll = True
    Else
        IsInstallEgovDll = False
    End If

End Function
Public Sub DllRemove()

    Dim EgovDllPath As String

    EgovDllPath = PathCombine(VBA.Interaction.Environ("ProgramFiles"), "cells\台帳電子申請ツール\egovunreg.bat")
    
    Shell EgovDllPath

End Sub

Public Function IsExistRibbon(ByVal myTabName As String) As Boolean
    
    Dim ret As Boolean
    Dim myAcc As Office.IAccessible
    
    Set myAcc = Application.CommandBars("Ribbon")
    Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
    
    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
    
    If myAcc Is Nothing Then
        ret = False
    Else
        ret = True
    End If
    
    Set myAcc = Nothing
    IsExistRibbon = ret
End Function
Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
    Dim ReturnAcc As Office.IAccessible
    Dim ChildAcc As Office.IAccessible
    Dim List() As Variant
    Dim Count As Long
    Dim i As Long

    If (myAcc.accState(CHILDID_SELF) <> 32769) And _
       (myAcc.accName(CHILDID_SELF) = myAccName) And _
       (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
        Set ReturnAcc = myAcc
    Else
        Count = myAcc.accChildCount
        If Count > 0& Then
            ReDim List(Count - 1&)
            If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
                For i = LBound(List) To UBound(List)
                    If TypeOf List(i) Is Office.IAccessible Then
                        Set ChildAcc = List(i)
                        Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
                        If Not ReturnAcc Is Nothing Then Exit For
                    End If
                Next
            End If
        End If
    End If
    Set GetAcc = ReturnAcc
End Function
#End If