Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 eebfdc8f9c6deea6…

MALICIOUS

Office (OLE)

1.20 MB Created: 2008-04-24 05:04:04 Authoring application: Microsoft Excel First seen: 2018-06-21
MD5: b7eb30ab514ecd3f076cd35315f25b16 SHA-1: 180fd6e4b32308636a91e1643abf365b5223b708 SHA-256: eebfdc8f9c6deea6c7ed1009b38b3be81b6194e9c74e843d14c5701b73f3a7f6
220 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment T1203 Exploitation for Client Execution

The sample is an Excel document containing VBA macros. Heuristics indicate the presence of CreateProcess and ShellExecute APIs, and a specific lure to copy/paste content into a command-line interface. This suggests the macro is designed to execute arbitrary commands, likely to download and run a second-stage payload. The document body contains Japanese text related to company and social insurance data, which may serve as a lure.

Heuristics 6

  • x86 GetPC stub (CALL $+5; POP EBP) high SC_GETPC_CALL
    x86 GetPC stub (CALL $+5; POP EBP)
    Disassembly
    Attempted x86 opcode disassembly
    0002DBC2  e800000000        call 0x2dbc7
0002DBC7  5d                pop ebp
0002DBC8  00f2              add dl, dh
0002DBCA  04d8              add al, 0xd8
0002DBCC  0100              add dword ptr [eax], eax
0002DBCE  00f2              add dl, dh
0002DBD0  04f0              add al, 0xf0
0002DBD2  0100              add dword ptr [eax], eax
0002DBD4  0000              add byte ptr [eax], al
0002DBD6  00e0              add al, ah
0002DBD8  0008              add byte ptr [eax], cl
0002DBDA  003400            add byte ptr [eax + eax], dh
0002DBDD  208374834881      and byte ptr [ebx - 0x7eb77c8c], al
0002DBE3  5b                pop ebx
0002DBE4  83802b8365834c    add dword ptr [eax - 0x7c9a7cd5], 0x4c
0002DBEB  83588367          sbb dword ptr [eax - 0x7d], 0x67
0002DBEF  837b8362          cmp dword ptr [ebx - 0x7d], 0x62
0002DBF3  834e8358          or dword ptr [esi - 0x7d], 0x58
0002DBF7  82cc4c            or ah, 0x4c
0002DBFA  6566742c          je 0x2dc2a
0002DBFE  54                push esp
0002DBFF  6f                outsd dx, dword ptr [esi]
0002DC00  7092              jo 0x2db94
0002DC02  6c                insb byte ptr es:[edi], dx
0002DC03  82a982e788ca92    sub byte ptr [ecx - 0x3577187e], 0x92
0002DC0A  7582              jne 0x2db8e
0002DC0C  f0                .byte 0xf0
0002DC0D  94                xchg esp, eax
0002DC0E  bb92e80000        mov ebx, 0xe892
0002DC13  0000              add byte ptr [eax], al
0002DC15  0000              add byte ptr [eax], al
0002DC17  2000              and byte ptr [eax], al
0002DC19  ff                .byte 0xff
0002DC1A  ff21              jmp dword ptr [ecx]
0002DC1C  00dc              add ah, bl
0002DC1E  00                .byte 0x00
0002DC1F  b600              mov dh, 0
0002DC21  04                .byte 0x04
  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • Clipboard command execution lure high SE_CLIPBOARD_COMMAND_LURE
    Document tells the user to copy or paste clipboard content into Run, PowerShell, cmd, or another shell-like execution context
  • VBA macros detected medium 1 related finding OLE_VBA_MACROS
    Document contains VBA macro code
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set FSO = CreateObject("Scripting.FileSystemObject")
    Folname = fPath

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 238413 bytes
SHA-256: e659bb3165d201cfe00b81a0dc43df10f0741395c204faf1e7b47fe3533d40db
Preview script
First 1,000 lines of the extracted script
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_BeforeClose(Cancel As Boolean)
'    ThisWorkbook.Saved = True
'End Sub
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'   MsgBox "このファイルは保存することができません。", 16, "保存不可"
'   Cancel = True
'End Sub
'

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


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


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


Attribute VB_Name = "設置届"
Attribute VB_Base = "0{16C8647E-9A95-4B91-9096-092B729CB12B}{B6102A3E-52C0-4BAC-84FC-80FB64808450}"
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
Dim i           As Integer

Private Sub CommandButton1_Click()
        '会社情報データ取り込み
        If MsgBox("会社情報データを読み込みます。よろしいですか？", 1 + 32, "読込") <> 1 Then Exit Sub
        
        Call クリア
        With Worksheets("DATA")
            Text1.Value = StrConv(.Cells(109, 2).Value, vbNarrow) 'フリガナ
            Text14.Value = StrConv(.Cells(109, 2).Value, vbNarrow) 'フリガナ
            Text3.Value = .Cells(38, 2).Value '会社名（漢字）
            Text15.Value = .Cells(38, 2).Value
            Text5.Value = .Cells(39, 2).Value '郵便番号
            Text6.Value = .Cells(40, 2).Value '所在地
            Text13.Value = .Cells(40, 2).Value
            Text9.Value = .Cells(43, 2).Value '電話番号
            Text17.Value = .Cells(42, 2).Value '氏名
            Text18.Value = .Cells(45, 2).Value '業務の概要
            Text25.Value = .Cells(63, 2).Value '締
            Text26.Value = .Cells(64, 2).Value '締
            Text27.Value = .Cells(65, 2).Value '支払日
            
            If .Cells(30, 2).Value <> "" Then '社会保険加入状況
                Text30.Value = True
                Text31.Value = True
            End If
            If .Cells(131, 2).Value <> "" Then '労災保険加入状況
                Text32.Value = True
            End If
            
            Text38.Value = .Cells(460, 2).Value '法人番号　'YBNO 29514  ito 20151201
            
        End With
            
End Sub

'Private Sub UserForm_Initialize()
Private Sub UserForm_Activate()
        If ActiveSheet.Name = "設置届" Then
            lNo.Visible = True
        End If
'カレンダーコントロール関係
        Controls("Text10").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text19").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text20").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        
        '労働者数
        For i = 1 To 999
            Text22.AddItem i
            Text23.AddItem i
            Text24.AddItem i
        Next
        '賃金支払い
        Text26.AddItem "当"
        Text26.AddItem "翌月"
        'YBNO 29514  ito 20160205　追加　------
        For i = 1 To 30
            Text25.AddItem i
        Next
        Text25.AddItem "末"
        'YBNO 29514  ito 20160205　ここまで　---
        For i = 1 To 30
            Text27.AddItem i
        Next
        'YBNO 29514  ito 20160205
        'Text27.Text = "末"
        Text27.AddItem "末"
        
        '労働保険番号
        With Worksheets("DATA")
            For i = 131 To 181 Step 10
                Text11.AddItem .Cells(i, 2).Value
            Next
        End With
        
        '保存データシートから読み込み
        Call シートから読込
        
End Sub
Private Sub Text10_DropButtonClick()
        Call カレ表示("10", "設置年月日")
End Sub
Private Sub Text19_DropButtonClick()
        Call カレ表示("19", "事業の開始年月日")
End Sub
Private Sub Text20_DropButtonClick()
        Call カレ表示("20", "事業の廃止年月日")
End Sub
Private Sub カレ表示(No As String, Title As String)
        'カレンダー設定
        Dim lngLeft As Long, lngTop As Long
        ' フォーム+テキストボックスのLeft,Top値から位置を判定
        lngLeft = Me.Left + Controls("Text" & No).Left + 20
        lngTop = Me.Top + Controls("Text" & No).Top - 100
        With カレンダー
            .Caption = Title
            .Label8.Caption = "Text" & No
            .Label9.Caption = Me.Name
                .Left = lngLeft
                .Top = lngTop
            ' カレンダーフォームを表示
            .Show
        End With
End Sub
Sub シートへ書き出す()
    With Worksheets("保存データ")
        'YBNO 29514  ito 20151201
        'For i = 1 To 37
        For i = 1 To 38
            If i = 10 And i = 19 Then
                .Cells(i, 2).Value = Format(Controls("Text" & i).Value, "yyyy/mm/dd")
            Else
                .Cells(i, 2).Value = Controls("Text" & i).Value
            End If
        Next
    End With
    With Worksheets("印刷DATA")
        'YBNO 29514  ito 20151201
        'For i = 1 To 32
        For i = 1 To 38
            If i = 19 Then
                Worksheets("設置届").Cells(.Cells(i + 15, 3).Value, .Cells(i + 15, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i = 21 Then
                Worksheets("設置届").Cells(.Cells(i + 9, 3).Value, .Cells(i + 9, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i >= 22 And i <= 26 Then
                Worksheets("設置届").Cells(.Cells(i + 1, 3).Value, .Cells(i + 1, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i = 27 Then
                Worksheets("設置届").Cells(.Cells(i + 22, 3).Value, .Cells(i + 22, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i >= 28 And i <= 29 Then
                Worksheets("設置届").Cells(.Cells(i, 3).Value, .Cells(i, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i >= 30 And i <= 32 Then
                Worksheets("設置届").Cells(.Cells(i + 6, 3).Value, .Cells(i + 6, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            'YBNO 29514  ito 20151201
            'ElseIf i = 20 Then
            ElseIf i = 38 Then
                Worksheets("設置届").Cells(.Cells(i + 12, 3).Value, .Cells(i + 12, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            ElseIf i = 20 Or i >= 33 And i <= 37 Then
            '何もしない
            Else
                Worksheets("設置届").Cells(.Cells(i + 3, 3).Value, .Cells(i + 3, 4).Value).Value = Worksheets("保存データ").Cells(i, 2).Value
            End If
        Next
    End With
    
End Sub
Sub シートから読込()

     With Worksheets("保存データ")
        'YBNO 29514  ito 20151201
        'For i = 1 To 37
        For i = 1 To 38
                         
            Select Case i
            Case 1, 2, 10, 11, 14, 16, 12
                If Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 3, 3).Value, Worksheets("印刷DATA").Cells(i + 3, 4).Value).Value = "" Then
                    Controls("Text" & i).Value = .Cells(i, 2).Value
                Else
                    Controls("Text" & i).Value = Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 3, 3).Value, Worksheets("印刷DATA").Cells(i + 3, 4).Value).Value
                End If
            Case 22, 23, 24
                If Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 1, 3).Value, Worksheets("印刷DATA").Cells(i + 1, 4).Value).Value = "" Then
                    Controls("Text" & i).Value = .Cells(i, 2).Value
                Else
                    Controls("Text" & i).Value = Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 1, 3).Value, Worksheets("印刷DATA").Cells(i + 1, 4).Value).Value
                End If
            Case 28, 29
                If Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i, 3).Value, Worksheets("印刷DATA").Cells(i, 4).Value).Value = "" Then
                    Controls("Text" & i).Value = .Cells(i, 2).Value
                Else
                    Controls("Text" & i).Value = Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i, 3).Value, Worksheets("印刷DATA").Cells(i, 4).Value).Value
                End If
            Case 30, 31, 32
                If Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 6, 3).Value, Worksheets("印刷DATA").Cells(i + 6, 4).Value).Value = "" Then
                    Controls("Text" & i).Value = .Cells(i, 2).Value
                Else
                    Controls("Text" & i).Value = Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 6, 3).Value, Worksheets("印刷DATA").Cells(i + 6, 4).Value).Value
                End If
            Case 21
                If Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 9, 3).Value, Worksheets("印刷DATA").Cells(i + 9, 4).Value).Value = "" Then
                    Controls("Text" & i).Value = .Cells(i, 2).Value
                Else
                    Controls("Text" & i).Value = Worksheets("設置届").Cells(Worksheets("印刷DATA").Cells(i + 9, 3).Value, Worksheets("印刷DATA").Cells(i + 9, 4).Value).Value
                End If

            Case Else
                Controls("Text" & i).Value = .Cells(i, 2).Value
            End Select
        Next
    End With
End Sub
Sub クリア()
    'YBNO 29514  ito 20151201
    'For i = 1 To 37
     For i = 1 To 38
             Controls("Text" & i).Value = ""
        Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     Call シートへ書き出す
End Sub





Attribute VB_Name = "シート選択"
Option Explicit
Public Nusi As String
Public Const AAA As String = "労働保険　新規適用関係処理"

Sub 初期処理()
    Dim s As Worksheet
    Dim i               As Integer
    Dim j               As Integer
    Dim k               As Integer
    Dim Myfile          As String
    Dim DaFile          As String
    Dim MyStr           As String
    Dim TextFilename    As String
    Dim MyData(1)       As String
    
    For Each s In Worksheets
        With s
            .Activate
            ActiveWindow.DisplayHeadings = False
            .EnableSelection = xlUnlockedCells
            .Protect UserInterfaceOnly:=True
        End With
    Next
    
    Nusi = False '事業主はそのまま、trueになると予備を使う
    Myfile = Worksheets("DATA").Cells(1, 1).Value
    With Workbooks(Myfile).Worksheets("会社情報")
        'YBNO 29514  ito 20151201
        'Worksheets("DATA").Range("B34:B190").Value = .Range("B4:B160").Value2
        Worksheets("DATA").Range("B34:B460").Value = .Range("B4:B430").Value2
        j = Val(.Cells(25, 2).Value) '料率パターン
        j = 71 + 11 * (j - 1) '料率パターンの行番号
        If j < 71 Then j = 71
        k = Val(.Cells(73, 2).Value) '端数処理パターン
        k = 292 + 4 * (k - 1)     '端数パターンの行番号
        If k < 292 Then k = 292
    End With
    
    Sheets("DATA").Select
    With Workbooks("DaMenu.xls").Worksheets("標準報酬月額")
    Range("I4:I13").Value = .Range("C" & j & ":C" & (j + 9)).Value '現在料率
    Range("I17").Value = .Range("C70").Value '児童手当
    Range("I18:I21").Value = .Range("C" & k & ":C" & (k + 3)).Value '端数処理
        i = 4
        TextFilename = ThisWorkbook.Path & "\MyTool\Todouhuken.dat" '都道府県
        Open TextFilename For Input As #1
            Do Until EOF(1)
                Input #1, MyData(1)
                Cells(i, 11).Value = MyData(1)
                i = i + 1
            Loop
        Close #1
        Dim MyData2(1) As String
            i = 24
            TextFilename = ThisWorkbook.Path & "\MyTool\ZimukumiaiJoho.dat" '組合
            Open TextFilename For Input As #1
                Do Until EOF(1)
                    Input #1, MyData2(1)
                    Cells(i, 9).Value = MyData2(1)
                    i = i + 1
                Loop
            Close #1
    End With
    Worksheets("MENU").Select
    
    
End Sub
Sub 設置届フォームへ()
    設置届.Show
End Sub
Sub 成立届フォームへ()
    成立届.Show
End Sub
Sub 設置届へ()
    Worksheets("設置届").Select
End Sub
Sub 設置届印刷シートへ()
    Dim n   As Integer
    Dim wb  As Object
    
    n = 0
    For Each wb In Workbooks
    If wb.Name = "雇用保険設置届印刷シート.xls" Then
        n = 1
        wb.Activate
    End If
    Next
    If n = 0 Then
        Workbooks.Open ThisWorkbook.Path & "\労働保険新規適用\雇用保険設置届印刷シート.xls"
         '20101028masa 2010問題　閉じるボタンを張り付ける
        Application.ScreenUpdating = False
        If Workbooks("雇用保険設置届印刷シート.xls").BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu10").Copy
        Workbooks("雇用保険設置届印刷シート.xls").Activate
        ActiveSheet.Unprotect
        Range("A1").Select
        DoEvents
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu10").Top = 18
        ActiveSheet.Shapes("Zu10").Left = 117
        Range("A1").Select
        Workbooks("雇用保険設置届印刷シート.xls").BuiltinDocumentProperties("Keywords").Value = 2010
        Application.EnableEvents = False
        ActiveWorkbook.Save
        Application.EnableEvents = True
        Workbooks("閉じるボタン.xls").Close False
    End If
    Application.ScreenUpdating = True
    End If
End Sub
Sub 設置届裏面印刷シートへ()
    Dim n   As Integer
    Dim wb  As Object
    
    n = 0
    For Each wb In Workbooks
    If wb.Name = "雇用保険設置届印刷シート裏.xls" Then
        n = 1
        wb.Activate
    End If
    Next
    If n = 0 Then
        Workbooks.Open ThisWorkbook.Path & "\労働保険新規適用\雇用保険設置届印刷シート裏.xls"
        '20101028masa 2010問題　閉じるボタンを張り付ける
        Application.ScreenUpdating = False
        If Workbooks("雇用保険設置届印刷シート裏.xls").BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu11").Copy
        Workbooks("雇用保険設置届印刷シート裏.xls").Activate
        ActiveSheet.Unprotect
        Range("A1").Select
        DoEvents
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu11").Top = 18
        ActiveSheet.Shapes("Zu11").Left = 138
        Range("A1").Select
        Workbooks("雇用保険設置届印刷シート裏.xls").BuiltinDocumentProperties("Keywords").Value = 2010
        Application.EnableEvents = False
        ActiveWorkbook.Save
        Application.EnableEvents = True
        Workbooks("閉じるボタン.xls").Close False
    End If
    Application.ScreenUpdating = True
    End If
End Sub
Sub 成立届印刷シートへ()
    Dim n   As Integer
    Dim wb  As Object
    
    n = 0
    For Each wb In Workbooks
    If wb.Name = "成立届届印刷シート.xls" Then
        n = 1
        wb.Activate
    End If
    Next
    If n = 0 Then
        Workbooks.Open ThisWorkbook.Path & "\労働保険新規適用\成立届印刷シート.xls"
        '20101028masa 2010問題　閉じるボタンを張り付ける
        Application.ScreenUpdating = False
        If Workbooks("成立届印刷シート.xls").BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu12").Copy
        Workbooks("成立届印刷シート.xls").Activate
        ActiveSheet.Unprotect
        Range("A1").Select
        DoEvents
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu12").Top = 13
        ActiveSheet.Shapes("Zu12").Left = 129
        Range("A1").Select
        Workbooks("成立届印刷シート.xls").BuiltinDocumentProperties("Keywords").Value = 2010
        Application.EnableEvents = False
        ActiveWorkbook.Save
        Application.EnableEvents = True
        Workbooks("閉じるボタン.xls").Close False
    End If
    Application.ScreenUpdating = True


    End If
End Sub
Sub 終了へ()
    If MsgBox("終了しますか？", 1 + 32, AAA) <> 1 Then Exit Sub
    Application.DisplayAlerts = (False)        'メッセージ非表示
    ThisWorkbook.Close
End Sub
Sub 会社Fへ()
    Application.Run "DaAddin.xla!会社Fへ"
End Sub
Sub 給与Fへ()
    Application.Run "DaAddin.xla!給与Fへ"
End Sub
Sub 個人Fへ()
    Application.Run "DaAddin.xla!個人Fへ"
End Sub
Sub 保存Fへ()
    保存F.Show
End Sub
Sub 保存読込へ()
    保存読込.Show
End Sub
Sub 変則的概算保険料へ()
    変則的概算保険料.Show
End Sub
Sub 申告書へ()
    Worksheets("申告書").Select
End Sub
'Sub 保存データ作成()
'    Da保存.Show 0
'End Sub
'Sub 保存データ読込()
'    Da保存読込.Show
'End Sub
Sub メニューへ()
    Worksheets("MENU").Select
End Sub

Attribute VB_Name = "Class1"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private WithEvents clsBTN As MSForms.CommandButton
Attribute clsBTN.VB_VarHelpID = -1

Public Property Set Object(setObject As MSForms.CommandButton)
    Set clsBTN = setObject
End Property

Public Property Get Object() As MSForms.CommandButton
    Set Object = clsBTN
End Property

Private Sub clsBTN_Click()   'インスタンスのClickイベント
    Dim Temp1 As Integer
    Dim Temp2 As Integer
    With カレンダー.SpinButton1
        Temp1 = (.Value - 1) \ 12 + 1
        Temp2 = (.Value - 1) Mod 12 + 1
    End With
    If カレンダー.Label9.Caption = "設置届" Then
'        設置届.Controls(カレンダー.Label8.Caption).Value = Format(DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption), "gemmdd")
        設置届.Controls(カレンダー.Label8.Caption).Value = Format(DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption), "gemmdd")
    
    End If
    If カレンダー.Label9.Caption = "成立届" Then
        If カレンダー.Label8.Caption = "Text60" Or カレンダー.Label8.Caption = "Text61" Then
            成立届.Controls(カレンダー.Label8.Caption).Value = Format(DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption), "7-e-mm-dd")
        Else
            成立届.Controls(カレンダー.Label8.Caption).Value = Format(DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption), "gemmdd")
        End If
    End If
    
    
    
   
    
    Unload カレンダー
End Sub




Attribute VB_Name = "カレンダー"
Attribute VB_Base = "0{DAE4E7C2-3CD0-4C9A-BD16-2FD5DF41D569}{D3E23358-127C-41EF-A4B1-0467FA4CE573}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False







Dim clsCmd() As Class1   'クラスオブジェクトを格納する動的配列
Private Sub 日付表示(MyDay As Integer)
'20080605　kon
'設置届.Controls(カレンダー.Label8.Caption).Value = Format(Date + MyDay, "gemmdd")

    If Label9.Caption = "設置届" Then
        設置届.Controls(Label8.Caption).Value = Format(Date + MyDay, "gemmdd")
    ElseIf Label9.Caption = "成立届" Then
        If Label8.Caption = "Text60" Or Label8.Caption = "Text61" Then
            成立届.Controls(Label8.Caption).Value = "7-" & Format(Date + MyDay, "e-mm-dd")
        Else
            成立届.Controls(Label8.Caption).Value = Format(Date + MyDay, "gemmdd")
        End If
    End If

Unload Me
End Sub

Private Sub ComboBox1_Change()
    SpinButton1.Value = (ComboBox1.ListIndex + 1926 - 1) * 12 + Val(ComboBox2.Value)
End Sub

Private Sub ComboBox2_Change()
    SpinButton1.Value = (ComboBox1.ListIndex + 1926 - 1) * 12 + Val(ComboBox2.Value)
End Sub

Private Sub CommandButton38_Click()
Call 日付表示(-1)
End Sub

Private Sub CommandButton39_Click()
Call 日付表示(0)
End Sub
Private Sub CommandButton40_Click()
Call 日付表示(1)
End Sub
Private Sub CommandButton42_Click()
Dim Myd As Date
'20080605 kon
'Myd = DateSerial(ComboBox1.ListIndex + 1926, ComboBox2.Value, ComboBox3.Value)
'選択.TextBox6.Value = Format(Myd, "GGGE年M月D日")
    
    Myd = DateSerial(ComboBox1.ListIndex + 1926, ComboBox2.Value, ComboBox3.Value)
    If Label9.Caption = "成立届" Then
        If Label8.Caption = "Text60" Or Label8.Caption = "Text61" Then
            成立届.Controls(Label8.Caption).Value = Format(Myd, "7-e-mm-dd")
        Else
            成立届.Controls(Label8.Caption).Value = Format(Myd, "gemmdd")
        End If
    ElseIf Label9.Caption = "設置届" Then
        設置届.Controls(Label8.Caption).Value = Format(Myd, "gemmdd")
    End If

Unload Me
End Sub

Private Sub UserForm_Activate()
    ReDim clsCmd(1 To 37)   '動的配列の再定義
    For i = 1 To 37
        Set clsCmd(i) = New Class1
        Set clsCmd(i).Object = Me.Controls("CommandButton" & CStr(i))
    Next i
    SpinButton1.Min = 1899 * 12 + 1                           '1900年の1月の総月数
    SpinButton1.Max = 2100 * 12                               '2100年の12月の総月数
    For i = 1 To 63
        ComboBox1.AddItem "昭和" & i
    Next
    For i = 1 To 30
        ComboBox1.AddItem "平成" & i
    Next
    For i = 1 To 12
        ComboBox2.AddItem i
    Next
    For i = 1 To 31
        ComboBox3.AddItem i
    Next
    ComboBox1.ListIndex = Year(Date) - 1926
    ComboBox2.Value = Month(Date)
    ComboBox3.Value = Day(Date)
    SpinButton1.Value = (Year(Date) - 1) * 12 + Month(Date)   '今日の月の総月数
    Display_Calendar

End Sub
Private Sub SpinButton1_Change()
    Display_Calendar   'サブルーチン
End Sub
Sub Display_Calendar()
Dim iBlank_Days As Integer    '1日以前の曜日の空白日数（日曜日始まり）
Dim iExtend_Days As Integer   '空白日数を含めた月末の日までの日数

    With SpinButton1
        Temp1 = CStr((.Value - 1) \ 12) + 1     '総月数から求めた年数
        Temp2 = CStr((.Value - 1) Mod 12 + 1)   '総月数から求めた月数
        'DisplayMonth.Caption = Temp1 & "年" + Temp2 & "月"
        temp = Temp1 & "/" & Temp2 & "/1"
        DisplayMonth.Caption = Format(temp, "ggge年m月")
        iBlank_Days = Weekday(temp) - 1
        iExtend_Days = Num_of_Days() + iBlank_Days   'FunctionプロシージャNum_of_Days
    End With
        
    For i = 1 To iBlank_Days   '月初の空白を設定
        clsCmd(i).Object.Visible = False
    Next i
    
    For i = iBlank_Days + 1 To iExtend_Days   '1～末日の日を設定
        clsCmd(i).Object.Visible = True
        clsCmd(i).Object.Caption = CStr(i - iBlank_Days)
    Next i

    For i = iExtend_Days + 1 To 37   '月末の空白を設定
        clsCmd(i).Object.Visible = False
    Next i
End Sub

Function Num_of_Days() As Integer
    With SpinButton1
        iTemp = (.Value - 1) Mod 12 + 1
        Select Case iTemp
        Case 1, 3, 5, 7, 8, 10, 12
            Num_of_Days = 31   '戻り値を設定
        Case 4, 6, 9, 11
            Num_of_Days = 30   '戻り値を設定
        Case 2   '2月の日数を計算
            iTemp = (.Value - 1) \ 12 + 1
            Start_Date = CStr(iTemp) & "/2/1"
            End_Date = CStr(iTemp) & "/3/1"
            Num_of_Days = DateDiff("d", Start_Date, End_Date)   '戻り値を設定
        End Select
    End With
End Function


Attribute VB_Name = "成立届"
Attribute VB_Base = "0{5E482945-8618-4177-8F4B-D33FC2F92A8A}{1F5FDE21-74C0-49C9-B90E-0BA79FAF034D}"
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
Dim i       As Integer
Dim n       As Integer
Dim nn      As Integer
Dim nnn     As Integer

'Private Sub UserForm_Initialize()
Private Sub UserForm_Activate()
'カレンダーコントロール関係
        Controls("Text37").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text38").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text50").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text51").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text60").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        Controls("Text61").ShowDropButtonWhen = fmShowDropButtonWhenAlways
        '種別
        Text1.AddItem "0"
        Text1.List(0, 1) = "0 成立届（継続）"
        Text1.AddItem "1"
        Text1.List(1, 1) = "1 成立届（有期）"
        Text1.AddItem "2"
        Text1.List(2, 1) = "2 任意加入申請書"
       
        
        '保存データシートから読み込み
        Call シートから読込
End Sub
Private Sub Text37_DropButtonClick()
        Call カレ表示("37", "労災成立年月日")
End Sub
Private Sub Text38_DropButtonClick()
        Call カレ表示("38", "雇用保険設立年月日")
End Sub
Private Sub Text50_DropButtonClick()
        Call カレ表示("50", "事業の開始年月日")
End Sub
Private Sub Text51_DropButtonClick()
        Call カレ表示("51", "事業の廃止年月日")
End Sub
Private Sub Text60_DropButtonClick()
        Call カレ表示("60", "保険関係成立年月日")
End Sub
Private Sub Text61_DropButtonClick()
        Call カレ表示("61", "事務処理委託年月日")
End Sub
Private Sub カレ表示(No As String, Title As String)
        'カレンダー設定
        Dim lngLeft As Long, lngTop As Long
        ' フォーム+テキストボックスのLeft,Top値から位置を判定
        lngLeft = Me.Left + Controls("Text" & No).Left + 20
        lngTop = Me.Top + Controls("Text" & No).Top - 100
        With カレンダー
            .Caption = Title
            .Label8.Caption = "Text" & No
            .Label9.Caption = Me.Name
                .Left = lngLeft
                .Top = lngTop
            ' カレンダーフォームを表示
            .Show
        End With
End Sub
Sub シートへ書き出す()
    With Worksheets("保存データ")
        For i = 1 To 75
            .Cells(i + 49, 2).Value = Controls("Text" & i).Value
        Next
    End With
End Sub
Sub シートから読込()
     With Worksheets("保存データ")
        For i = 1 To 75
             Controls("Text" & i).Value = .Cells(i + 49, 2).Value
        Next
    End With
End Sub
Sub クリア()
     For i = 1 To 75
             Controls("Text" & i).Value = ""
        Next
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     Call シートへ書き出す
End Sub
Private Sub TEL(Denwa As String, n, nn, nnn)
            Dim j As Integer
            Dim k As Integer
            Dim l As Integer
            j = 0
            k = 0
            With Worksheets("DATA")
                For l = 1 To Len(Denwa)
                    If Mid(Denwa, l, 1) = "-" Then
                        If j = 0 Then
                            j = l
                            Else
                            k = l
                        End If
                    End If
                Next
                If j = 0 Then 'ＴＥＬ１
                    Controls("Text" & n).Value = Denwa
                    Exit Sub
                    Else
                    Controls("Text" & n).Value = Mid(Denwa, 1, j - 1)
                End If
                If k = 0 Then 'ＴＥＬ2
                    Controls("Text" & nn).Value = Mid(Denwa, j + 1, Len(Denwa) - j)
                    Exit Sub
                    Else
                    Controls("Text" & nn).Value = Mid(Denwa, j + 1, k - j - 1)
                End If
                Controls("Text" & nnn).Value = Mid(Denwa, k + 1, Len(Denwa) - k) 'ＴＥＬ3
            End With
End Sub
Private Sub CommandButton7_Click()
'名称氏名フリガナ入力
        成立届入力.Caption = "⑲名称氏名<カナ>を入力して下さい"
        成立届入力.Label1.Caption = 16
        成立届入力.Show
End Sub
Private Sub CommandButton1_Click()
'住所カナフリガナ入力
        成立届入力.Caption = "⑰住所<カナ>を入力して下さい"
        成立届入力.Label1.Caption = 8
        成立届入力.Show
End Sub
Private Sub OptionButton1_Click()
'事務組合データを表示
        With Worksheets("DATA")
            Text42.Value = .Cells(24, 9).Value
            Text43.Value = .Cells(25, 9).Value
            Call TEL(.Cells(29, 9), 44, 45, 46)
            Text47.Value = .Cells(26, 9).Value
            Text48.Value = .Cells(27, 9).Value & .Cells(28, 9).Value
        End With
End Sub
Private Sub OptionButton2_Click()
'事務組合データを非表示
        For i = 0 To 6
            Controls("Text" & 42 + i).Value = ""
        Next
End Sub
Private Sub CommandButton5_Click()
'会社情報データ取り込み
        If MsgBox("会社情報データを読み込みます。よろしいですか？", 1 + 32, "読込") <> 1 Then Exit Sub
        
        Call クリア
         With Worksheets("DATA")
            Text2.Value = .Cells(68, 2).Value '局長
            Text6.Value = Mid(.Cells(39, 2).Value, 1, 3) '郵便番号
            Text7.Value = Mid(.Cells(39, 2).Value, 5, 4)
            Text27.Value = .Cells(39, 2).Value '郵便番号
            
'20091021masa
            Text12.Value = .Cells(40, 2).Value '事業主住所
            Text25.Value = .Cells(40, 2).Value '事業主住所
            Text28.Value = .Cells(40, 2).Value '事業主住所
'20091021masa
            Text22.Value = .Cells(38, 2).Value '名称
            Text26.Value = .Cells(38, 2).Value '名称
            Text32.Value = .Cells(38, 2).Value '名称
            
            Call TEL(.Cells(43, 2), 19, 20, 21)
            Call TEL(.Cells(43, 2), 29, 30, 31)
            
             Text33.Value = .Cells(45, 2).Value '事業概要
            
        End With
End Sub



Attribute VB_Name = "Sheet5"
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 = "成立届入力"
Attribute VB_Base = "0{A4201FCB-F311-4C48-AE6E-982D7691A263}{97B85422-8B0A-4795-8579-1B7D493CF33D}"
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
Dim i As Integer
Dim n As Integer

Private Sub CommandButton1_Click()
    n = 0
    If Label1.Caption = 8 Then
        For i = 0 To 3
            If i = 0 Then
                成立届.Controls("Text" & Label1.Caption + i).Value = Mid(TextBox1.Value, 1, 10)
            Else
                成立届.Controls("Text" & Label1.Caption + i).Value = Mid(TextBox1.Value, 11 + n, 20)
                n = n + 20
            End If
        Next
    Else
        For i = 0 To 2
            成立届.Controls("Text" & Label1.Caption + i).Value = Mid(TextBox1.Value, 11 + n, 20)
        Next
    End If
    
        
    Unload Me
End Sub


Attribute VB_Name = "保存F"
Attribute VB_Base = "0{BEC24049-803C-493E-B5AA-FD059023215C}{D889D5DC-AD96-4662-9310-BD8E06DA2A93}"
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
Dim msg As Integer
Dim SS As Worksheet, ファイル名 As String
Private Sub CommandButton1_Click()
    Dim Check As Boolean
    Dim Myfile As String
    Dim Mysheet As String
    Dim 保存ファイル名 As String
    Check = False '上書きのチェック
    'シートをコピーして作成する、そのためリンクがかかるが、問題ないでしょう
    Application.DisplayAlerts = (False)
    With ThisWorkbook.Worksheets("DATA")
        If TextBox1.Value = "" Then
            MsgBox "ファイル名が入力されていません。", 16, AAA
            Exit Sub
        End If
        
        msg = MsgBox("よろしいですか？", 1 + 32, AAA)
        If msg = 1 Then
            If Dir(ActiveWorkbook.Path & "\労働保険新規適用\Da保存", 16) = "" Then MkDir ActiveWorkbook.Path & "\労働保険新規適用\Da保存" '保存台帳フォルダがなかったら作成する
                Myfile = ActiveWorkbook.Name
                Mysheet = ActiveSheet.Name
                If Mysheet = "設置届" Then
                    保存ファイル名 = TextBox1.Value & " " & Mysheet & " " & Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 4) & ".xls"
                Else
                    '例えば、ファイル名が○○○でセルズda.xlsから読込んだ労災○○.xlsで保存したら　「○○○　労災○号　セルズda」となる
                    保存ファイル名 = TextBox1.Value & " " & Left(Myfile, Len(Myfile) - 4) & " " & Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 4) & ".xls"
                End If
            Dim フルパス As String
            フルパス = ActiveWorkbook.Path & "\労働保険新規適用\Da保存\" & 保存ファイル名
            If 保存ファイル名 = Dir(フルパス) Then 'すでにあるかチェック
                If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, AAA) <> 1 Then
                    MsgBox "処理を中止します。", 64, AAA
                    Exit Sub
                Else
                    '20131017 kon YBNO 22398
                    On Error Resume Next
                    Kill ActiveWorkbook.Path & "\労働保険新規適用\Da保存\" & Left(保存ファイル名, Len(保存ファイル名) - 6) & ".png"
                    '20131017 kon YBNO 22398
                    On Error GoTo 0
                End If
            End If
                '20131111 ishikawa YB22302で下記いくつか追加
                ThisWorkbook.Worksheets("保存データ").Cells(125, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(9, 10).Value
                ThisWorkbook.Worksheets("保存データ").Cells(1, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(13, 3).Value
                ThisWorkbook.Worksheets("保存データ").Cells(2, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(13, 9).Value
                ThisWorkbook.Worksheets("保存データ").Cells(10, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(34, 3).Value
                ThisWorkbook.Worksheets("保存データ").Cells(11, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(34, 9).Value
                ThisWorkbook.Worksheets("保存データ").Cells(12, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(43, 4).Value
                ThisWorkbook.Worksheets("保存データ").Cells(14, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(45, 4).Value
                ThisWorkbook.Worksheets("保存データ").Cells(16, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(47, 4).Value
                ThisWorkbook.Worksheets("保存データ").Cells(22, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(42, 11).Value
                ThisWorkbook.Worksheets("保存データ").Cells(23, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(43, 12).Value
                ThisWorkbook.Worksheets("保存データ").Cells(24, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(44, 12).Value
                ThisWorkbook.Worksheets("保存データ").Cells(28, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(47, 11).Value
                ThisWorkbook.Worksheets("保存データ").Cells(29, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(48, 11).Value
                ThisWorkbook.Worksheets("保存データ").Cells(21, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(56, 3).Value
                
                ThisWorkbook.Worksheets("保存データ").Cells(126, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(84, 3).Value
                ThisWorkbook.Worksheets("保存データ").Cells(99, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(99, 4).Value
                ThisWorkbook.Worksheets("保存データ").Cells(100, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(103, 4).Value
                
                ThisWorkbook.Worksheets("保存データ").Cells(30, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(49, 11).Value
                ThisWorkbook.Worksheets("保存データ").Cells(31, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(50, 11).Value
                ThisWorkbook.Worksheets("保存データ").Cells(32, 2).Value = ThisWorkbook.Worksheets("設置届").Cells(51, 11).Value
                
                
                Check = True
            
        
            Application.ScreenUpdating = False
            Label2.Visible = True
            Me.Repaint
            '新規ブックにシートをそのままコピーしてオブジェクト（マクロボタン）をクリアする
            '20070803
            Workbooks.Open ThisWorkbook.Path & "\Dummy.xls"
'            Range("C3:C350").Value = .Range("C3:C350").Value2
            ThisWorkbook.Worksheets("保存データ").Range("A1:Z200").Copy
            Range("A1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            
            ActiveSheet.Name = "DATA"
            ActiveWorkbook.SaveAs FileName:=フルパス
            ActiveWorkbook.Close
            
…

Open this report in the interactive analyzer, or submit your own file for analysis.