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

#If VBA7 Then
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
#Else
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
#End If
    

Private Sub Workbook_Open()
    Dim ws As Worksheet
    Dim objWSH As Object
    Dim Ans As Integer
    Dim path As String
    Dim FSO As Object
    Dim rd_btn As Boolean
    
    Set ws = ActiveWorkbook.Worksheets("設定")
    
    '今日の日付（年）を「対象年」セルにセット       2021/04/23
    ws.Range("対象年").Value = Format(Date, "yyyy")
    
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    path = FSO.GetSpecialFolder(2) & "\" & CMD_FILE_NAME_TEST
    
    'バッチファイル作成
    Call MakeFile(TST_CMD_START, path)
    
    'バッチファイル実行
    Set objWSH = CreateObject("WScript.Shell")
    Ans = objWSH.Run(path, vbHide, True)               '同期（コマンドプロンプトを見せない）

    rd_btn = False
    
    If Ans <> 0 Then
        ws.Shapes("BTN_WRIGHT").Visible = False
    Else
        ws.Shapes("BTN_WRIGHT").Visible = True
        If GetKeyState(vbKeyShift) < 0 Then
            rd_btn = True
        End If
    End If

    ws.Shapes("BTN_READ").Visible = rd_btn

    Set objWSH = Nothing
    Set ws = Nothing
    Set FSO = Nothing

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 = "Sheet1"
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
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
'    If Application.Intersect(Target, Range("法定外休日")) Is Nothing And _
'       Application.Intersect(Target, Range("例外営業日")) Is Nothing And _
'       Application.Intersect(Target, Range("恒例休日")) Is Nothing Then
'        Exit Sub
'    End If
'
'    If Len(Target.Value) <> 10 Then
'        Call MsgBox("存在しない日付です。", vbOKOnly + vbExclamation, TOOL_NAME)
'        Target.Activate
'    End If
End Sub


Attribute VB_Name = "Sheet3"
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 = "Module1"
Option Explicit

Public Const TST_CMD_START = 1
Const DEL_CMD_START = 7
Const DEL_SQL_START = 15
Const WRT_CMD_START = 27
Const READ_CMD_START = 34

Const BEGIN_LINE = 30
Const COLUMN1 = 1
Const COLUMN2 = 9
Const COLUMN3 = 17

Const COUNTMAX = 20

Const DQ = """"                 'ダブルクォーテーション

Public Const CMD_FILE_NAME_TEST = "ConnectionCheck.cmd"
Const CMD_FILE_NAME1 = "DataDelete.cmd"
Const SQL_FILE_NAME1 = "DataDelete.sql"
Const CMD_FILE_NAME2 = "DataUpdate.cmd"
Const CSV_FILE_NAME2 = "DataUpdate.csv"
Const CMD_FILE_NAME3 = "ReadData.cmd"
Const CSV_FILE_NAME3 = "ReadData.csv"

Const OUTPUT_CSV_NAME = "休日計画.csv"

Public Const TOOL_NAME = "休日計画"

'ファイル作成（スクリプトファイル／バッチファイル）
Public Function MakeFile(s_row As Long, path As String, Optional Param1 As String = "") '第1引数：呪文開始行、第2引数：ファイル名
    Dim i As Long
    Dim ws As Worksheet
    Dim buf As String
    
    Set ws = ActiveWorkbook.Worksheets("WORK")

    Open path For Output As #1
 
    i = s_row
    Do While ws.Cells(i, 1).Value <> ""
        buf = ws.Cells(i, 1).Value
        If buf <> "" Then
            buf = Replace(buf, "($Param1)", Param1)
        End If
        Print #1, buf
        i = i + 1
    Loop
 
    Close #1

    Set ws = Nothing
End Function

Function WriteCsv(ws As Worksheet, fullpath As String, kbn As Boolean)
    Dim MaxRow As Long
    Dim i As Long
    Dim buf As String
    
    Open fullpath For Output As #1
    
    '法定外休日
    If ws.Range("COUNT1").Value <> 0 Then
        MaxRow = BEGIN_LINE + ws.Range("COUNT1").Value - 1
    
        i = BEGIN_LINE
    
        Do While i <= MaxRow
    
            If Cells(i, COLUMN1 + 1).Value <> "" Then
                buf = DQ & Format(Cells(i, COLUMN1 + 3).Value, "yyyy/mm/dd") & DQ & "," & _
                      DQ & "1" & DQ & "," & _
                      DQ & Cells(i, COLUMN1).Value & DQ & "," & _
                      DQ & Cells(i, COLUMN1 + 4).Value & DQ
                If kbn Then
                    buf = buf & "," & DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & "admin" & DQ & "," & _
                                      DQ & "KanameTool" & DQ
                    buf = Replace(buf, ",", vbTab)
                    buf = Replace(buf, DQ, "")
                End If
                
                Print #1, buf
            Else
                Exit Do
            End If
            
            i = i + 1
        Loop
    End If
    
    '例外営業日
    If ws.Range("COUNT2").Value <> 0 Then
        MaxRow = BEGIN_LINE + ws.Range("COUNT2").Value - 1
    
        i = BEGIN_LINE
    
        Do While i <= MaxRow
    
            If Cells(i, COLUMN2 + 1).Value <> "" Then
                buf = DQ & Format(Cells(i, COLUMN2 + 3).Value, "yyyy/mm/dd") & DQ & "," & _
                      DQ & "2" & DQ & "," & _
                      DQ & Cells(i, COLUMN2).Value & DQ & "," & _
                      DQ & Cells(i, COLUMN2 + 4).Value & DQ
                If kbn Then
                    buf = buf & "," & DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & "admin" & DQ & "," & _
                                      DQ & "KanameTool" & DQ
                    buf = Replace(buf, ",", vbTab)
                    buf = Replace(buf, DQ, "")
                End If
                
                Print #1, buf
            Else
                Exit Do
            End If
            
            i = i + 1
        Loop
    End If

    '恒例休日
    If ws.Range("COUNT3").Value <> 0 Then
        MaxRow = BEGIN_LINE + ws.Range("COUNT3").Value - 1
    
        i = BEGIN_LINE
    
        Do While i <= MaxRow
    
            If Cells(i, COLUMN3 + 1).Value <> "" Then
                buf = DQ & Format(Cells(i, COLUMN3 + 3).Value, "yyyy/mm/dd") & DQ & "," & _
                      DQ & "3" & DQ & "," & _
                      DQ & Cells(i, COLUMN3).Value & DQ & "," & _
                      DQ & Cells(i, COLUMN3 + 4).Value & DQ
                If kbn Then
                    buf = buf & "," & DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & Format(Date, "yyyy-mm-dd hh:mm:ss.000") & DQ & "," & _
                                      DQ & "admin" & DQ & "," & _
                                      DQ & "KanameTool" & DQ
                    buf = Replace(buf, ",", vbTab)
                    buf = Replace(buf, DQ, "")
                End If
                
                Print #1, buf
            Else
                Exit Do
            End If
            
            i = i + 1
        Loop
    End If

    Close #1

End Function

'データを、csvとして出力（データ追加）
Sub OutputCSV()
    Dim fullpath As String
    Dim i As Long
    Dim cnt1 As Long, cnt2 As Long, cnt3 As Long
    Dim WSH As Variant
    Dim ws As Worksheet
    Dim MaxRow As Long
    Dim Ans As Integer

    If Range("ALERT1").Value + Range("ALERT2").Value + Range("ALERT3").Value > 0 Then
        Call MsgBox("アラートが残っています。データを確認してください。", vbExclamation + vbOKOnly, TOOL_NAME)
        Exit Sub
    End If

    Ans = MsgBox("デスクトップに、下記項目をCSVファイルとして出力します。" & vbCrLf & "よろしいですか？", vbQuestion + vbYesNo, TOOL_NAME)
    If Ans = vbNo Then Exit Sub

    Set ws = ActiveWorkbook.Worksheets("設定")
    
    If (ws.Range("COUNT1").Value = 0) And (ws.Range("COUNT2").Value = 0) And (ws.Range("COUNT3").Value = 0) Then
        Call MsgBox("出力すべきデータがありません。", vbOKOnly + vbExclamation, TOOL_NAME)
        Set ws = Nothing
        Exit Sub
    End If

    Set WSH = CreateObject("WScript.Shell")
    fullpath = WSH.SpecialFolders("Desktop") & "\" & OUTPUT_CSV_NAME
    Set WSH = Nothing

    '出力!!
    Call WriteCsv(ws, fullpath, False)

    Call MsgBox("出力が終了しました。（" & OUTPUT_CSV_NAME & "）", vbOKOnly + vbInformation, TOOL_NAME)

    Set ws = Nothing
End Sub

'直接DB更新
Sub UpdateDB()
    Dim fullpath1 As String, fullpath2 As String
    Dim i As Long
    Dim cnt1 As Long, cnt2 As Long, cnt3 As Long
    Dim ws As Worksheet
    Dim MaxRow As Long
    Dim FSO As Object
    Dim objWSH As Object
    Dim cmdLine As String
    Dim Ans As Integer

    If Range("ALERT1").Value + Range("ALERT2").Value + Range("ALERT3").Value > 0 Then
        Call MsgBox("アラートが残っています。データを確認してください。", vbExclamation + vbOKOnly, TOOL_NAME)
        Exit Sub
    End If

    Ans = MsgBox(ActiveWorkbook.Worksheets("設定").Range("対象年").Text & "年の法定外休日、および例外営業日、すべての恒例休日を削除してから更新します。" & _
                "よろしいですか？", vbQuestion + vbYesNo, TOOL_NAME)
    If Ans = vbNo Then Exit Sub

    Set ws = ActiveWorkbook.Worksheets("設定")
    If (ws.Range("COUNT1").Value = 0) And (ws.Range("COUNT2").Value = 0) And (ws.Range("COUNT3").Value = 0) Then
        Set ws = Nothing
        Call MsgBox("出力すべきデータがありません。", vbOKOnly + vbExclamation, TOOL_NAME)
        Exit Sub
    End If

    Set FSO = CreateObject("Scripting.FileSystemObject")

    '削除用バッチファイル作成
    fullpath1 = FSO.GetSpecialFolder(2) & "\" & CMD_FILE_NAME1
    Call MakeFile(DEL_CMD_START, fullpath1)
    
    '削除用スクリプトファイル作成
    fullpath2 = FSO.GetSpecialFolder(2) & "\" & SQL_FILE_NAME1
    Call MakeFile(DEL_SQL_START, fullpath2, ws.Range("対象年").Text)
    
    Set objWSH = CreateObject("WScript.Shell")
    
    Open fullpath2 For Append As #1
    
    '恒例休日
    If ws.Range("COUNT3").Value <> 0 Then
        Print #1, "DELETE FROM [dbo].[MstOtherHoliday] WHERE NonTargetKbn = '3'"
        
'        MaxRow = BEGIN_LINE + ws.Range("COUNT3").Value - 1
'
'        i = BEGIN_LINE
'
'        Do While i <= MaxRow
'            If Cells(i, COLUMN3 + 1).Value <> "" Then
'                Print #1, "DELETE FROM [dbo].[MstOtherHoliday] WHERE NonTargetKbn = '3'"
'            Else
'                Exit Do
'            End If
'
'            i = i + 1
'        Loop
    End If

    Close #1

    '★★★　重複しそうなデータ削除　★★★
    cmdLine = fullpath1 & " " & ws.Range("対象年").Value
    objWSH.Run cmdLine, vbHide, True                    '同期（コマンドプロンプトを見せない）

    
    '更新用バッチファイル作成
    fullpath1 = FSO.GetSpecialFolder(2) & "\" & CMD_FILE_NAME2
    Call MakeFile(WRT_CMD_START, fullpath1)

    '更新用CSVファイル作成
    fullpath2 = FSO.GetSpecialFolder(2) & "\" & CSV_FILE_NAME2
    Call WriteCsv(ws, fullpath2, True)

    '★★★　更新　★★★
    cmdLine = fullpath1
    objWSH.Run cmdLine, vbHide, True                    '同期（コマンドプロンプトを見せない）

    Call MsgBox("DBの更新が完了しました。", vbOKOnly + vbInformation, TOOL_NAME)

    Set ws = Nothing
    Set FSO = Nothing
    Set objWSH = Nothing
End Sub

'【隠しコマンド】DBから直接csvファイルに書き込み→セルに落とす
Sub ImportDB()
    Dim fullpath As String
    Dim i As Long
    Dim ws As Worksheet
    Dim MaxRow As Long
    Dim FSO As Object
    Dim objWSH As Object
    Dim cmdLine As String
    Dim Ans As Integer
    Dim buf As String, buf2 As String
    Dim tmp As Variant

    Ans = MsgBox("DBから直接データを読み込みます。" & vbCrLf & "下表のデータはクリアされます。よろしいですか？", vbQuestion + vbYesNo, TOOL_NAME)
    If Ans = vbNo Then Exit Sub

    Set ws = ActiveWorkbook.Worksheets("設定")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objWSH = CreateObject("WScript.Shell")

    '読込用バッチファイル作成
    fullpath = FSO.GetSpecialFolder(2) & "\" & CMD_FILE_NAME3
    Call MakeFile(READ_CMD_START, fullpath)

    '★★★　DB→CSV　★★★
    cmdLine = fullpath
    objWSH.Run cmdLine, vbHide, True                    '同期（コマンドプロンプトを見せない）

    'データが存在すれば一旦クリア
    If ws.Range("COUNT1").Value <> 0 Then
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN1), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN1 + 1)).ClearContents
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN1 + 4), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN1 + 4)).ClearContents
    End If

    If ws.Range("COUNT2").Value <> 0 Then
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN2), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN2 + 1)).ClearContents
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN2 + 4), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN2 + 4)).ClearContents
    End If

    If ws.Range("COUNT3").Value <> 0 Then
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN3), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN3 + 1)).ClearContents
        ws.Range(ws.Cells(BEGIN_LINE, COLUMN3 + 4), ws.Cells(BEGIN_LINE + COUNTMAX - 1, COLUMN3 + 4)).ClearContents
    End If

    Dim n1 As Long, n2 As Long, n3 As Long

    n1 = BEGIN_LINE
    n2 = BEGIN_LINE
    n3 = BEGIN_LINE

    fullpath = FSO.GetSpecialFolder(2) & "\" & CSV_FILE_NAME3
    
    Open fullpath For Input As #1  'csvファイルをオープン

    Do Until EOF(1)
        Line Input #1, buf
        tmp = Split(buf, vbTab)

        If tmp(1) = 1 Then
            ws.Cells(n1, COLUMN1).Value = tmp(2)
            ws.Cells(n1, COLUMN1 + 1).Value = tmp(0)
            ws.Cells(n1, COLUMN1 + 4).Value = tmp(3)
            n1 = n1 + 1
        ElseIf tmp(1) = 2 Then
            ws.Cells(n2, COLUMN2).Value = tmp(2)
            ws.Cells(n2, COLUMN2 + 1).Value = tmp(0)
            ws.Cells(n2, COLUMN2 + 4).Value = tmp(3)
            n2 = n2 + 1
        ElseIf tmp(1) = 3 Then
            ws.Cells(n3, COLUMN3).Value = tmp(2)
            ws.Cells(n3, COLUMN3 + 1).Value = tmp(0)
            ws.Cells(n3, COLUMN3 + 4).Value = tmp(3)
            n3 = n3 + 1
        End If
    Loop

    Close #1

    Call MsgBox("DBからの読込が完了しました。", vbOKOnly + vbInformation, TOOL_NAME)

    Set ws = Nothing
    Set FSO = Nothing
    Set objWSH = Nothing
End Sub


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