Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 e90310393d0f984e…

MALICIOUS

Office (OLE)

757.0 KB Created: 2012-01-26 22:31:48 Authoring application: Microsoft Excel First seen: 2018-07-18
MD5: a1c24450652efdb0f2e8452798d69b65 SHA-1: a28007f5c5d508c2e19e588d6566aa1c40ab5f0b SHA-256: e90310393d0f984ece697ec95c10bbbd6d47ff4c0fec80d73968f93b97b96211
142 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1059 Command and Scripting Interpreter T1204.002 Malicious File T1566.001 Spearphishing Attachment

The file is an Excel document containing VBA macros. The macros reference CreateProcess and ShellExecute APIs, indicating an intent to execute external commands. While the document body contains Japanese text related to insurance claims, the presence of these API calls suggests the macros are likely used to download and execute a secondary payload. The benign URL found is not directly related to the malicious behavior.

Heuristics 5

  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • 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
            Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim n As Long
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://get.adobe.com/jp/reader/ In document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 169639 bytes
SHA-256: 5799461959714cf8c641626da510ef2cfabdcc682ddddde2af00930ec1308507
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 = "Sheet7"
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 = "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
Option Explicit


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


Attribute VB_Name = "Sheet6"
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 = "Module2"
Option Explicit
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type
Private Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
   hObject As Long) As Long
Private 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
Public Tmargin As Double
Public Lmargin As Double
Public hName As String
Public huki As Integer
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&
Sub 作成死傷病へ()
    作成死傷病.Show
End Sub

Public Function GetProgramFolder() As String
    Dim str As String

    str = PathCombine(ThisWorkbook.Path, "PDF")
    GetProgramFolder = str

End Function
Public Sub ExecCmd(ByVal cmdline As String, Optional ByVal WaitFlg As Boolean = True)
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ReturnValue As Long
    Dim hwnd As Long

    '初期化
    start.cb = Len(start)

    'コマンド発行
    ReturnValue = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, _
       NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)

    '終了まで待つ
    Do
        ReturnValue = WaitForSingleObject(proc.hProcess, 0)
        DoEvents
        If WaitFlg = False Then
            Exit Do
        End If
    Loop Until ReturnValue <> 258
    
    ReturnValue = CloseHandle(proc.hProcess)

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
Sub PDFを開く()
    Dim URL As String, rc
    URL = "http://get.adobe.com/jp/reader/"
    rc = ShellExecute(0, "Open", URL, "", "", 1)
End Sub

Sub manual()
    PDF (ThisWorkbook.Path & "\マニュアル\新労災申請.pdf")
End Sub
Sub PDF(strPath)
    Dim lngRet As Long

    lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            MsgBox "PDFファイルを開くことができません。", 16, "有給管理"
        Case ERROR_FILE_NOT_FOUND
            MsgBox "PDFファイルはありません。", 16, "有給管理"
    End Select
End Sub



Attribute VB_Name = "個人情報"
Attribute VB_Base = "0{D3B3F464-3E15-4B44-8C4B-ACBF34B75573}{FBCBBA80-3291-4821-B07E-4A0B3EBE53F2}"
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 da As String

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim n As Long
    n = 0
    ListBox1.Clear
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If Format(.Cells(i, 2).Value, "000000") & .Cells(i, 5).Value & .Cells(i, 6).Value Like "*" & TextBox1.Value & "*" Then '退職日にデータがあれば
                ListBox1.AddItem i
                ListBox1.List(n, 1) = Format(.Cells(i, 2).Value, "000000") & " " & .Cells(i, 5).Value & " " & .Cells(i, 6).Value
                n = n + 1
            End If
        Next
    End With
    If n = 0 Then
        MsgBox "見つかりませんでした。", 16, "検索"
        Exit Sub
    End If
    
End Sub

Private Sub CommandButton2_Click()
    Dim n As Long
    
    If ListBox1.ListIndex = -1 Then
        MsgBox "リストを選択して下さい。", 16, "リスト"
        Exit Sub
    End If
    With Workbooks(da).Worksheets("個人情報")
        If ActiveWorkbook.Name = "労災報告.xls" Then
            n = Val(ListBox1.Value)
            Cells(7, 4).Value = .Cells(n, 5).Value & " " & .Cells(n, 6).Value
            Cells(29, 4).Value = Cells(7, 4).Value
            Cells(28, 4).Value = .Cells(n, 7).Value & " " & .Cells(n, 8).Value
            Cells(31, 5).Value = .Cells(n, 34).Value
            Cells(32, 4).Value = .Cells(n, 35).Value
            Cells(30, 4).Value = .Cells(n, 13).Value
            Cells(30, 12).Value = IIf(.Cells(n, 9).Value = 2, "女", "男")
            Cells(33, 4).Value = .Cells(n, 33).Value
             Unload Me
            Exit Sub
        End If
    End With
    
    If 個人 = 1 Then '被災労働者
        作成.La行 = ListBox1.Value '個人情報の行番号
        作成.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 2 Then '現認者
        作成.TextBox5.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 32).Value '職種
        作成.TextBox6.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 3 Then '被災労働者
        作成7.La行 = ListBox1.Value '個人情報の行番号
        作成7.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 4 Then '現認者
        作成7.TextBox5.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 32).Value '職種
        作成7.TextBox6.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 5 Then '被災労働者
        作成163.La行 = ListBox1.Value '個人情報の行番号
        作成163.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 6 Then '現認者
        作成163.TextBox5.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 35).Value '住所
        作成163.TextBox6.Value = Mid(ListBox1.Text, 8) '名前
        作成163.TextBox13.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 33).Value '電話
    ElseIf 個人 = 7 Then '被災労働者
        作成165.La行 = ListBox1.Value '個人情報の行番号
        作成165.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 8 Then '現認者
        作成165.TextBox5.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 35).Value '住所
        作成165.TextBox6.Value = Mid(ListBox1.Text, 8) '名前
        作成165.TextBox19.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 33).Value '電話
    ElseIf 個人 = 9 Then  '死傷病報告
        作成死傷病.La行.Caption = ListBox1.Value '個人情報の行番号
        作成死傷病.TextBox4.Value = Mid(ListBox1.Text, 8)   '名前
        If IsDate(Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 14).Value) Then '経験年数のために在職年数を参考データとして表示する
        作成死傷病.Label25.Caption = Format(Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 14).Value, "参考：ge/m/d入社 在職") & Int((Date - Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 14).Value) / 356.25) & "年" '入社
        End If
    '8号追加  ito 20130301
    ElseIf 個人 = 10 Then '被災労働者
        作成8.La行 = ListBox1.Value '個人情報の行番号
        作成8.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    '16号6追加  ito 20130408
    ElseIf 個人 = 11 Then '被災労働者
        作成166.La行 = ListBox1.Value '個人情報の行番号
        作成166.TextBox4.Value = Mid(ListBox1.Text, 8) '名前
    ElseIf 個人 = 12 Then '現認者
        作成166.TextBox5.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 35).Value '住所
        作成166.TextBox6.Value = Mid(ListBox1.Text, 8) '名前
        作成166.TextBox19.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 33).Value '電話
    End If
    Unload Me
End Sub

Private Sub ListBox1_Click()
NAMAE.Caption = ListBox1.Text
End Sub

Private Sub OptionButton1_Click()
    Dim i As Long
    Dim n As Long
    n = 0
    ListBox1.Clear
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If Trim(.Cells(i, 15).Value) = "" Then '退職日にデータがなければ
                ListBox1.AddItem i
                ListBox1.List(n, 1) = Format(.Cells(i, 2).Value, "000000") & " " & .Cells(i, 5).Value & " " & .Cells(i, 6).Value
                n = n + 1
            End If
        Next
    End With
End Sub
Private Sub OptionButton2_Click()
    Dim i As Long
    Dim n As Long
    n = 0
    ListBox1.Clear
    With Workbooks(da).Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            If IsDate(.Cells(i, 15).Value) = True Then '退職日にデータがあれば
                ListBox1.AddItem i
                ListBox1.List(n, 1) = Format(.Cells(i, 2).Value, "000000") & " " & .Cells(i, 5).Value & " " & .Cells(i, 6).Value
                n = n + 1
            End If
        Next
    End With
End Sub

Private Sub UserForm_Activate()
    da = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value
    OptionButton1.Value = True
End Sub


Attribute VB_Name = "Module1"
Option Explicit
Public 個人 As Long
Public da As String
Sub 初期処理()
    
    With Sheets("DATA")
        .Cells(5, 1).Value = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(154, 7).Value '氏名
        .Cells(6, 1).Value = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(155, 7).Value '電話番号
        'TextBox6.Value = .Cells(7, 1).Value '提出代行
        .Cells(8, 1).Value = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(162, 12).Value '作成日
    End With

    Worksheets("MENU").Select
    Cells(11, 8).Select
End Sub
Sub 作成へ()
    作成.Show
End Sub
Sub 作成7へ()
    作成7.Show
End Sub
Sub 作成165へ()
    作成165.Show
End Sub
Sub 作成163へ()
    作成163.Show
End Sub
Sub 様式5()
Sheets("様式5号").Select
Cells(2, 6).Select
End Sub
Sub MENUへ()
Sheets("MENU").Select
End Sub
Sub 様式7()
Sheets("様式7号").Select
Cells(2, 6).Select
End Sub
Sub 様式163()
Sheets("様式16号3").Select
Cells(2, 6).Select
End Sub
Sub 様式165()
Sheets("様式16号5").Select
Cells(2, 6).Select
End Sub
Sub 様式6()
    Call 起動("様式第6号.xls", "様式第6号")
End Sub
Sub 様式164()
    Call 起動("様式第16号の4.xls", "様式第16号の4")
End Sub
Sub 労災報告()
    Call 起動("労災報告.xls", "労災報告")
End Sub
Sub 通災報告()
    Call 起動("労災報告.xls", "通勤災害")
End Sub
Sub 出力へ()
出力.Show
End Sub
Private Sub 起動(w As String, s As String)
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = w Then
            wb.Activate
            Sheets(s).Select
            Exit Sub
        End If
    Next
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\新労災申請\" & w
    Sheets(s).Select
    Worksheets("DATA").Cells(1, 1).Value = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value
    Application.Run w & "!初期処理"
End Sub
Sub 印刷()
    'ito 電話番号にハイフンが２つ入っていないとメッセージ
    If ActiveSheet.Name = "死傷病報告" Then
        If Len(Worksheets("死傷病報告").Cells(32, 12).Value) < 12 Then
            MsgBox "電話番号は、市外局番から入力して下さい。また２箇所ハイフン（-）で区切って下さい。", 16, "電話番号"
            Exit Sub
        End If
    End If
    
    'YBNO 20869  ito 20130204　提出代行・社労士記載欄を表示しないようにしました
    If ActiveSheet.Name = "死傷病報告" Then
        Load 印刷F
        印刷F.Label18.Top = 印刷F.Frame1.Top
        印刷F.Label16.Top = 105
        印刷F.TxtTop.Top = 100
        印刷F.Label20.Top = 105
        印刷F.Label17.Top = 105
        印刷F.TxtLeft.Top = 100
        印刷F.Label19.Top = 105
        印刷F.Frame1.Visible = False
        印刷F.Height = 160
    End If

印刷F.Show
End Sub
Sub 保存()
    Dim Fda As String
    Dim Fdb As String
    Dim MyP As String
    Dim MyP2 As String
    Dim Fname As String
    Dim s As Shape
    Dim aw As String
    aw = ActiveWorkbook.Name
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    If MsgBox("このデータを保存しますか？", 4 + 32, "保存") <> 6 Then Exit Sub
    
    If ActiveSheet.Name = "様式5号" Or ActiveSheet.Name = "様式16号3" Then
        Fname = "作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(21, 6).Value & ".xls"
        ElseIf ActiveSheet.Name = "様式7号" Or ActiveSheet.Name = "様式16号5" Then
        Fname = "No" & Cells(6, 19).Value & " 作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(21, 6).Value & ".xls"
        ElseIf ActiveSheet.Name = "様式第6号" Then
        Fname = "作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(22, 45).Value & ".xls"
        ElseIf ActiveSheet.Name = "様式第16号の4" Then
        Fname = "作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(22, 44).Value & ".xls"
        ElseIf ActiveSheet.Name = "死傷病報告" Then
        Fname = "作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(42, 5).Value & ".xls"
        '8号追加  ito 20130301
        ElseIf ActiveSheet.Name = "様式8号" Then
        Fname = "No" & Cells(6, 19).Value & " 作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(22, 6).Value & ".xls"
        '16号6追加  ito 20130408
        ElseIf ActiveSheet.Name = "様式16号6" Then
        Fname = "No" & Cells(6, 19).Value & " 作成 " & Format(Now, "yyyymmdd_hhmm  ") & Cells(22, 6).Value & ".xls"
     End If
    
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4) 'daをフォルダ名にする
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) '処理ファイルをフォルダ名にする
    '\DaProcess\台帳名\処理ファイル名\シート名　フォルダに保存する
    If Dir(ThisWorkbook.Path & "\Da保存", 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存"
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name & "\" & Fname
    If ActiveSheet.Name = "様式8号" Then
        MyP2 = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name & "\" & "平均賃金" & Fname
    End If
    
    Application.Calculation = xlCalculationManual
    ActiveSheet.Copy
    ActiveSheet.Unprotect
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Application.Calculation = xlCalculationAutomatic
    DoEvents
    For Each s In ActiveSheet.Shapes
''' YBNO20780 苦しいがRNで
        On Error Resume Next
        If s.Type = msoFormControl Or s.OnAction <> "" Or s.Top < 40 Then 'マクロ付きと上の方のオブジェクトとフォームコントロール
        On Error GoTo 0
            s.Delete
        End If
''' END YBNO20780
    Next
    Application.CutCopyMode = False
    Cells(1, 1).Select
    If CSng(Application.Version) > 11 = True Then
        ActiveWorkbook.SaveAs MyP, FileFormat:=56 '2007以上
    Else
        ActiveWorkbook.SaveAs MyP '2003
    End If
    
    '8号平均賃金追加 ito 20130523
    If ActiveSheet.Name = "様式8号" Then
        ThisWorkbook.Sheets("平均賃金").Activate
        ActiveSheet.Copy
        ActiveSheet.Unprotect
        Cells.Copy
        Cells.PasteSpecial Paste:=xlPasteValues
        Application.Calculation = xlCalculationAutomatic
        DoEvents
        For Each s In ActiveSheet.Shapes
'    ''' YBNO20780 苦しいがRNで
'            On Error Resume Next
'            If s.Type = msoFormControl Or s.OnAction <> "" Or s.Top < 40 Then 'マクロ付きと上の方のオブジェクトとフォームコントロール
'            On Error GoTo 0
'                s.Delete
'            End If
    ''' END YBNO20780
        Next
        Application.CutCopyMode = False
        Cells(1, 1).Select
        If CSng(Application.Version) > 11 = True Then
            ActiveWorkbook.SaveAs MyP2, FileFormat:=56 '2007以上
        Else
            ActiveWorkbook.SaveAs MyP2 '2003
        End If
        ActiveWorkbook.Close False
        ActiveWorkbook.Sheets("様式8号").Activate
    End If
    
    
    
    Workbooks(aw).Activate
    Cells(1, 1).Select
    MsgBox "ファイル名「" & Left(Fname, Len(Fname) - 4) & "」で保存しました。", 64, "保存"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Sub 保存データ読込()
    保存読込.Show
End Sub
Sub 保存データ読込2(様式 As String) '
    With 保存読込
        .Caption = 様式
        .CommandButton2.Visible = False
        .Label2.Visible = False
        .Show
    End With
End Sub

Sub 終了へ()
    Application.DisplayAlerts = False
    Application.DisplayStatusBar = True
    Dim wb As Object, ブックの数 As Integer
    ブックの数 = 0
    For Each wb In Application.Workbooks
        If UCase(wb.Name) Like "PERSONAL*" Then
            Else
            ブックの数 = ブックの数 + 1
        End If
    Next
    If MsgBox("終了しますか", 4 + 32, "終了") <> 6 Then Exit Sub
    On Error Resume Next
    Application.ScreenUpdating = False
    Workbooks("様式第6号.xls").Close False
    Workbooks("様式第16号の4.xls").Close False
    Workbooks("労災報告.xls").Close False
    If ブックの数 = 1 Then
        Application.Quit
    Else
        Application.OnTime Now + TimeValue("00:00:01"), "CloseThisWorkbook"
    End If

End Sub
Sub CloseThisWorkbook()
   ThisWorkbook.Close False
End Sub
Function mojiChk(tMoji, tCnt) As Boolean

    Dim lstrBuf As String
    lstrBuf = Len(tMoji) - Len(Replace(tMoji, "-", ""))
    
    If tCnt = lstrBuf Then
        mojiChk = True
    Else
        mojiChk = False
    End If
End Function
Sub 個人情報へ()
個人情報.Show
End Sub
Sub 死傷病へ()
Sheets("死傷病報告").Select
Cells(2, 6).Select
End Sub
Sub 様式8()
Sheets("様式8号").Select
End Sub
Sub 作成8へ()
    作成8.Show
End Sub
Sub 様式166()
Sheets("様式16号6").Select
End Sub
Sub 作成166へ()
    作成166.Show
End Sub
Sub 作成平均賃金表へ()
    If ActiveSheet.Cells(1, 49).Value = 0 Then
        MsgBox "作成ボタンで被保険者を選択してから行ってください。", 16, "平均賃金"
        Exit Sub
    End If
    MENUF.Show
End Sub
Sub 作成平均賃金裏へ()
    If ActiveSheet.Cells(1, 49).Value = 0 Then
        MsgBox "作成ボタンで被保険者を選択してから行ってください。", 16, "平均賃金"
        Exit Sub
    End If
    別紙裏.Show
End Sub

Sub 同上1()
If MsgBox("労働者の直接所属事業場名称所在地が事業主証明の名称所在地の場合「同上」と記載します。記載しますか？", 1 + 32, "労働者の直接所属事業場名称所在地") <> 1 Then Exit Sub
    Worksheets("様式8号").Cells(37, 15).Value = ""
    Worksheets("様式8号").Cells(38, 29).Value = ""
    Worksheets("様式8号").Cells(38, 15).Value = "同上"
End Sub
Sub 同上2()
If MsgBox("労働者の直接所属事業場名称所在地が事業主証明の名称所在地の場合「同上」と記載します。記載しますか？", 1 + 32, "労働者の直接所属事業場名称所在地") <> 1 Then Exit Sub
    Worksheets("様式16号6").Cells(37, 15).Value = ""
    Worksheets("様式16号6").Cells(38, 29).Value = ""
    Worksheets("様式16号6").Cells(38, 15).Value = "同上"
End Sub


Attribute VB_Name = "Sheet8"
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{94980686-C941-45AD-AD4A-A8653268F04E}{9CEC1A68-3328-498C-8C41-E3707D55009F}"
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 MyP As String

Private Sub CommandButton1_Click()
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim Wh As Worksheet
    Set Wh = ActiveWorkbook.ActiveSheet
    
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, "読込"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Workbooks.Open MyP & "\" & ListBox1.Value & ".xls"
    If Me.Caption = "5号様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        With 作成7
            .TextBox1.Value = Cells(16, 16).Value '負傷年月日
            .ComboBox2.ListIndex = IIf(Cells(22, 28).Value = "前", 0, 1) '時刻
            .TextBox2.Value = Cells(22, 29).Value
            .TextBox3.Value = Cells(22, 31).Value
            .TextBox5.Value = Cells(25, 28).Value '現認者職名
            .TextBox6.Value = Cells(26, 28).Value '名前
            .TextBox7.Value = Cells(28, 4).Value '災害発生状況
            
        End With
            Wh.Cells(63, 14).Value = Cells(39, 8).Value '所属事業場
            Wh.Cells(64, 14).Value = Cells(40, 8).Value
    '8号用追加  ito 20130301
    ElseIf Me.Caption = "8号用5号様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        With 作成8
            .TextBox1.Value = Cells(16, 16).Value '負傷年月日
            .ComboBox2.ListIndex = IIf(Cells(22, 28).Value = "午前", 0, 1) '時刻
            .TextBox2.Value = Cells(22, 29).Value
            .TextBox3.Value = Cells(22, 31).Value
            .TextBox5.Value = Cells(26, 6).Value '労働者の職種
            .TextBox7.Value = Cells(28, 4).Value '災害発生状況
        End With
        
    ElseIf Me.Caption = "様式5号からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        Wh.Cells(10, 4).Value = Cells(43, 4).Value '監督署
        Wh.Cells(12, 56).Value = Cells(43, 18).Value  '〒
        Wh.Cells(14, 58).Value = Cells(43, 29).Value 'tel
        Wh.Cells(15, 44).Value = Cells(44, 17).Value '住所
        Wh.Cells(18, 44).Value = Cells(45, 17).Value '名前
        n = 13 '労働保険番号
        For i = 1 To 3
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        n = 20
        For i = 4 To 14
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        Wh.Cells(22, 45).Value = Cells(21, 6).Value '名前
        Wh.Cells(22, 53).Value = IIf(Cells(16, 4).Value = 1, "男", "女") '性別
        Wh.Cells(24, 45).Value = IIf(Left(Cells(16, 6).Value, 1) = "7", "H", "S") & Mid(Cells(16, 6).Value, 2, 2) '生年月日
        Wh.Cells(24, 48).Value = Mid(Cells(16, 6).Value, 4, 2) '生年月日
        Wh.Cells(24, 50).Value = Mid(Cells(16, 6).Value, 6, 2) '生年月日
        Wh.Cells(24, 53).Value = Cells(21, 22).Value '年齢
        Wh.Cells(25, 45).Value = Cells(23, 6).Value '住所
        Wh.Cells(23, 56).Value = Mid(Cells(16, 16).Value, 1, 2) '負傷年月日
        Wh.Cells(23, 60).Value = Mid(Cells(16, 16).Value, 3, 2) '負傷年月日
        Wh.Cells(23, 63).Value = Mid(Cells(16, 16).Value, 5, 2) '負傷年月日
        Wh.Cells(26, 56).Value = "午" & Cells(22, 28).Value '負傷時刻
        Wh.Cells(26, 59).Value = Cells(22, 29).Value '負傷時刻
        Wh.Cells(26, 63).Value = Cells(22, 31).Value '負傷時刻
        Wh.Cells(27, 45).Value = Cells(26, 6).Value '職種
        Wh.Cells(35, 40).Value = Cells(36, 8).Value '事業所名
        Wh.Cells(36, 41).Value = Cells(37, 29).Value '〒
        Wh.Cells(37, 59).Value = Cells(36, 29).Value 'TEL
        Wh.Cells(38, 40).Value = Cells(37, 8).Value '住所
        Wh.Cells(40, 40).Value = Cells(38, 8).Value  '事業主
        Wh.Cells(42, 36).Value = Cells(32, 10).Value '病院名称
        Wh.Cells(44, 36).Value = Cells(33, 10).Value '所在地
        Wh.Cells(55, 36).Value = Cells(34, 8).Value '傷病名
        s = Replace(Cells(28, 4).Value, vbLf, "")
        Wh.Cells(29, 13).Value = Mid(s, 1, 52) '発生状況
        Wh.Cells(30, 13).Value = Mid(s, 53, 52)
        Wh.Cells(31, 13).Value = Mid(s, 105, 52)
        Wh.Cells(32, 13).Value = Mid(s, 157, 52)
    
    ElseIf Me.Caption = "様式16号の3からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式16号3").Activate
        Wh.Cells(10, 4).Value = Cells(43, 4).Value '監督署
        Wh.Cells(12, 56).Value = Cells(43, 18).Value  '〒
        Wh.Cells(14, 58).Value = Cells(43, 29).Value 'tel
        Wh.Cells(15, 44).Value = Cells(44, 17).Value '住所
        Wh.Cells(18, 44).Value = Cells(45, 17).Value '名前
        n = 13 '労働保険番号
        For i = 1 To 3
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        n = 20
        For i = 4 To 14
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        Wh.Cells(22, 44).Value = Cells(21, 6).Value '名前
        Wh.Cells(22, 52).Value = IIf(Cells(16, 4).Value = 1, "男", "女") '性別
        Wh.Cells(24, 44).Value = IIf(Left(Cells(16, 6).Value, 1) = "7", "H", "S") & Mid(Cells(16, 6).Value, 2, 2) '生年月日
        Wh.Cells(24, 47).Value = Mid(Cells(16, 6).Value, 4, 2) '生年月日
        Wh.Cells(24, 49).Value = Mid(Cells(16, 6).Value, 6, 2) '生年月日
        Wh.Cells(24, 52).Value = Cells(21, 22).Value '年齢
        Wh.Cells(25, 44).Value = Cells(23, 6).Value '住所
        Wh.Cells(23, 55).Value = Mid(Cells(16, 16).Value, 1, 2) '負傷年月日
        Wh.Cells(23, 59).Value = Mid(Cells(16, 16).Value, 3, 2) '負傷年月日
        Wh.Cells(23, 62).Value = Mid(Cells(16, 16).Value, 5, 2) '負傷年月日
        Wh.Cells(26, 55).Value = "午" & Cells(51, 28).Value '負傷時刻
        Wh.Cells(26, 58).Value = Cells(51, 29).Value '負傷時刻
        Wh.Cells(26, 62).Value = Cells(51, 31).Value '負傷時刻
        Wh.Cells(27, 44).Value = Cells(26, 6).Value '職種
        Wh.Cells(35, 39).Value = Cells(36, 8).Value '事業所名
        Wh.Cells(36, 40).Value = Cells(37, 29).Value '〒
        Wh.Cells(37, 58).Value = Cells(36, 29).Value 'TEL
        Wh.Cells(38, 39).Value = Cells(37, 8).Value '住所
        Wh.Cells(40, 39).Value = Cells(38, 8).Value  '事業主
        Wh.Cells(43, 35).Value = Cells(32, 10).Value '病院名称
        Wh.Cells(45, 35).Value = Cells(33, 10).Value '所在地
        Wh.Cells(56, 35).Value = Cells(34, 8).Value '傷病名
        s = Replace(Cells(63, 3).Value, vbLf, "")
        Wh.Cells(29, 12).Value = Mid(s, 1, 52)  '発生状況
        Wh.Cells(30, 12).Value = Mid(s, 53, 52)
        Wh.Cells(31, 12).Value = Mid(s, 105, 52)
        Wh.Cells(32, 12).Value = Mid(s, 157, 52)
    ElseIf Me.Caption = "16号3様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式16号3").Activate
        With 作成165
            .TextBox1.Value = Cells(16, 16).Value '負傷年月日
            .ComboBox2.ListIndex = IIf(Cells(51, 28).Value = "前", 0, 1) '時刻
            .TextBox2.Value = Cells(51, 29).Value
            .TextBox3.Value = Cells(51, 31).Value
            .TextBox5.Value = Cells(64, 9).Value '現認者住所
            .TextBox6.Value = Cells(65, 9).Value '名前
            .TextBox19.Value = Cells(64, 28).Value 'tel
            .TextBox7.Value = Cells(63, 3).Value '災害発生状況
            .ComboBox3.Value = Cells(22, 30).Value '第3者行為届
            .ComboBox4.Value = Cells(50, 11).Value '第3者行為届
            
        End With
            Wh.Cells(64, 9).Value = Cells(39, 8).Value '所属事業場
            Wh.Cells(65, 9).Value = Cells(40, 8).Value
            Wh.Cells(71, 11).Value = Cells(52, 11).Value '発生場所
            Wh.Cells(71, 24).Value = Cells(52, 24).Value '就業場所
            Wh.Range(Wh.Cells(72, 19), Wh.Cells(75, 31)).Value = Range(Cells(53, 19), Cells(56, 31)).Value '年月日時刻データ
            Wh.Cells(81, 29).Value = Cells(61, 29).Value '発生場所
            Wh.Cells(81, 32).Value = Cells(61, 32).Value '就業場所
    '16号6用追加  ito 20130408
    ElseIf Me.Caption = "16号6用16号3様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式16号3").Activate
        With 作成166
            .TextBox1.Value = Cells(16, 16).Value '負傷年月日
            .ComboBox2.ListIndex = IIf(Cells(51, 28).Value = "前", 0, 1) '時刻
            .TextBox2.Value = Cells(51, 29).Value
            .TextBox3.Value = Cells(51, 31).Value
            .TextBox5.Value = Cells(26, 6).Value '職種
            .ComboBox5.Value = Cells(50, 11).Value '通勤の種別
            .TextBox24.Value = Cells(64, 9).Value '現認者住所
            .TextBox25.Value = Cells(65, 9).Value '名前
            .TextBox26.Value = Cells(64, 28).Value 'tel
            .TextBox7.Value = Cells(63, 3).Value '災害発生状況
            .ComboBox6.Value = Cells(22, 30).Value '第3者行為届
            
        End With
            Wh.Cells(65, 8).Value = Cells(52, 11).Value '発生場所
            Wh.Cells(65, 23).Value = Cells(52, 24).Value '就業場所
            Wh.Range(Wh.Cells(66, 19), Wh.Cells(69, 31)).Value = Range(Cells(53, 19), Cells(56, 31)).Value '年月日時刻データ
            Wh.Cells(74, 29).Value = Cells(61, 29).Value '所要時間
            Wh.Cells(74, 32).Value = Cells(61, 32).Value '所要分


    
    Else
        If InStr(ListBox1.Value, "平均賃金") Then
            ThisWorkbook.Sheets("平均賃金").Range("C5:C322").Value = ActiveWorkbook.Sheets("平均賃金").Range("C5:C322").Value
        Else
            Wh.Range(Wh.Cells(1, 1), Wh.Cells(100, 100)).Value = Range(Cells(1, 1), Cells(100, 100)).Value
        End If
    End If
    Workbooks(ListBox1.Value & ".xls").Close False
    Wh.Activate
    Unload Me
    MsgBox "OK", 64, "読込"
    Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, "削除"
        Exit Sub
    End If
    If MsgBox(ListBox1.Value & "を削除してもいいですか？", 1 + 32, "削除") <> 1 Then Exit Sub
    Kill MyP & "\" & ListBox1.Value & ".xls"
    ListBox1.RemoveItem ListBox1.ListIndex
    MsgBox "削除しました", 64, "削除"
End Sub
Private Sub CommandButton3_Click()
    Dim i As Long
    Dim n As Long
    If Trim(TextBox1.Value) = "" Then
        MsgBox "検索する文字列を入力して下さい。", 16, "検索"
        Exit Sub
    End If
    n = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.List(i, 0) Like "*" & TextBox1.Value & "*" Then
            ListBox2.AddItem i
            ListBox2.List(n, 1) = ListBox1.List(i, 0)
            n = n + 1
        End If
    Next
    If n = 0 Then
        MsgBox "見つかりません。", 64, "検索"
    Else
    ListBox2.ListIndex = 0
    End If

End Sub

Private Sub CommandButton4_Click()
    Dim i As Long
    Dim n As Long

    n = 0
    For i = 0 To ListBox1.ListCount - 1
        If DateValue(ListBox1.List(i, 1)) >= (Date - 60) Then '最近更新ファイル
            ListBox2.AddItem i
            ListBox2.List(n, 1) = ListBox1.List(i, 0)
            n = n + 1
        End If
    Next
    If n = 0 Then
        MsgBox "2ヶ月以内の更新されたファイルは見つかりません。", 64, "検索"
    Else
    ListBox2.ListIndex = 0
    End If

End Sub

Private Sub ListBox2_Click()
ListBox1.ListIndex = ListBox2.Value
End Sub

Private Sub UserForm_Activate()
    Dim Fda As String
    Dim Fdb As String
    Dim Fn As String
        Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim n As Long
    n = 0

    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4)
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    '8号用追加  ito 20130301
    '    If Me.Caption = "5号様式からの読込" Or Me.Caption = "様式5号からの読込" Then '様式5号からの読込は6号で読み込むもの
    If Me.Caption = "5号様式からの読込" Or Me.Caption = "様式5号からの読込" Or Me.Caption = "8号用5号様式からの読込" Then '様式5号からの読込は6号で読み込むもの
        MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\様式5号"
    '16号6用追加  ito 20130408
    'ElseIf Me.Caption = "16号3様式からの読込" Or Me.Caption = "様式16号の3からの読込"  Then

    ElseIf Me.Caption = "16号3様式からの読込" Or Me.Caption = "様式16号の3からの読込" Or Me.Caption = "16号6用16号3様式からの読込" Then
        MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\様式16号3"
    Else
        MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    End If
    
    Fn = Dir(MyP & "\*.*")
    Do While Fn <> ""
        With ListBox1
            .AddItem Left(Fn, Len(Fn) - 4)   '
            .List(n, 1) = FSO.GetFile(MyP & "\" & Fn).DateLastModified '最終更新日時
            n = n + 1
            Fn = Dir()
        End With
    Loop
    Set FSO = Nothing
End Sub

Attribute VB_Name = "作成7"
Attribute VB_Base = "0{93A0A3BD-539B-459D-9C5A-F3AAE9AC9BDC}{79411A57-036D-4014-BF69-F3487C0310CD}"
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 CommandButton1_Click()
    個人 = 3
    個人情報.Show
End Sub
Private Sub CommandButton2_Click()
    個人 = 4
    個人情報.Show
End Sub
Private Sub CommandButton3_Click()
    Dim MyD
    Dim 負傷年月日 As Date
    Dim 年号 As String
    Dim n As Long
    Dim k As Long

    If Len(ComboBox1.Text) <> 14 Then
        MsgBox "労働保険番号は枝番含めて14桁です。", 16, "労働保険番号"
        Exit Sub
    End If
    If Len(TextBox1.Value) <> 6 Then
        MsgBox "負傷年月日は半角数値で6桁です。", 16, "負傷年月日"
        Exit Sub
    End If
    
    n = Val(La行.Caption)
    If n = 0 Then
        MsgBox "個人情報から社員を選択して下さい。", 16, "個人情報"
        Exit Sub
    End If
    If Trim(Cells(57, 17).Value) <> "" Then 'すでに一度適用していたら
        If MsgBox("現在のデータに上書きします。よろしいですか？", 4 + 32, "上書き") <> 6 Then Exit Sub
    End If

    MyD = Range(Cells(6, 3), Cells(80, 34)).Value '配列に格納
…

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