Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "FrmUp"
Attribute VB_Base = "0{DA0DEC1A-4DA2-45E8-8393-EB42D0E4236A}{933A24A4-0BAA-4B64-91A2-B5C580595D27}"
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"
Attribute VB_Control = "CommandButton3, 1701, 2, MSForms, CommandButton"
Option Explicit
Private Sub CommandButton1_Click()
    Call 開く
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 Integer
    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
    
'    If MsgBox("バージョンアップ前に、バージョンアップ内容を確認しますか？", vbYesNo, "確認") = vbYes Then
'        バージョンアップ内容
'    End If
End Sub







Attribute VB_Name = "Module1"
Option Explicit
Public Const vChk = "V8.46.01"
Public Const oChk = "V8.45.00"
Public Const eAdd = "http://plus-samurai.jp/daityo/?p=16716"

Public Const vName = "84601"
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


Sub バージョンアップ内容()
    On Error GoTo err_rtn
    Application.ScreenUpdating = False
    Range("U1").Select
    With ActiveSheet
        .Hyperlinks.Add Anchor:=Selection, Address:=eAdd
        .Hyperlinks(1).Follow NewWindow:=True
    End With
    Range("U1").ClearContents
    Application.ScreenUpdating = True
    Exit Sub
err_rtn:
'    MsgBox "インターネットに接続できませんでした。", vbInformation
    Application.ScreenUpdating = True
End Sub
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.XLS" 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
    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 バックアップ("DaProcess\就業規則", 3)
'    Call バックアップ("DaProcess\MyTool", 4)
   
    'ファイルの入替
    
    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)
            myFSO.CopyFolder myPath & "\" & MyAry(i, 1), dPath & "\" & MyAry(i, 1)
            FrmUp.Label1.Caption = MyAry(i, 1) & "をコピーしています。"
        
        Next i
        Erase MyAry
    End If
        
    Set myFSO = Nothing

    '台帳フォルダ内にある、パスワードのファイルをTEMPにうつす
    'もし同名ファイルがTEMPにあったら、台帳フォルダ内のファイルは削除
    MoveNumericFile ThisWorkbook.Worksheets("MENU").Cells(1, 2).Value

'台帳フォルダから印刷と印字設定の有るファイルを取り出す
''    Dim Shell, Folder, buf As String
''    Dim ファイル名 As String
''    Dim os As String
''    Dim nNo As Integer
    
    
''    os = Application.OperatingSystem                        'OSのバージョン情報
''    If Right(os, 4) = "6.00" Or Right(os, 4) = "6.01" Then
''        nNo = 24 'Vista 7 コメント
''    Else
''        nNo = 14 'XP コメント
''    End If
''
''    Set Shell = CreateObject("Shell.Application")
''    Set Folder = Shell.Namespace(dPath & "\DaProcess\")
''
''    If Dir(dPath & "\役所用紙\", vbDirectory) = "" Then
''        MkDir (dPath & "\役所用紙\")
''    End If
''    ファイル名 = Dir(dPath & "\DaProcess\" & "*.xls")
''
''    Do While ファイル名 <> ""
''
''        If Folder.GetDetailsOf(Folder.ParseName(ファイル名), nNo) = "印字" Or Folder.GetDetailsOf(Folder.ParseName(ファイル名), nNo) = "DATA" Then
''            FrmUp.Repaint
''            FrmUp.Label1.Caption = ファイル名 & "をコピーしています。"
''            FileCopy dPath & "\DaProcess\" & ファイル名, dPath & "\役所用紙\" & ファイル名
''        End If
''        ファイル名 = Dir()
''    Loop
''    Set Folder = Nothing
''    Set Shell = Nothing



    
''    If Dir(dPath & "\DaProcess\介護休業給付印刷.xls", vbNormal) <> "" Then
''        On Error Resume Next
''        Application.EnableEvents = False
''        Workbooks.Open dPath & "\DaProcess\介護休業給付印刷.xls"
''        Worksheets("新介護休業").Range("Z5").FormulaR1C1 = "=IF(INDIRECT(""[育児介護給付.xls]新介護休業!R5C26"",0)="""","""",INDIRECT(""[育児介護給付.xls]新介護休業!R5C26"",0))"
''        Workbooks("介護休業給付印刷.xls").Save
''        Workbooks("介護休業給付印刷.xls").Close
''        Application.EnableEvents = True
''        On Error GoTo 0
''    End If
    
    'バックアップにこのファイルがあったらやらない
    'モジュール入替
'    Fname1(0) = "総括表役所用紙.xls"
'    Fname1(1) = "労災16号の6.xls"
'
'    Call モジュール入替
    
    
    FrmUp.Label1.Caption = ""
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
'    If MsgBox("バージョンアップは終了しました。バージョンアップ内容を確認しますか？", vbYesNo, "バージョンアップ") = vbYes Then
'        バージョンアップ内容
'    End If
    
    MsgBox "バージョンアップは終了しました。", vbInformation, "バージョンアップ"

    
    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

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