Malicious Office (OLE) — 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
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{631245D0-6848-4992-91DB-37F270AE6ACE}{07502F52-9D47-4995-B85D-BD3E44DFA46A}"
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
'27178 0325 hara 薬局の項目を追加したため以下の行をコメントアウト
'            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
            '薬局追加につき、出力セルを1行ずらす
            Cells(30, 4).Value = Cells(7, 4).Value
            Cells(29, 4).Value = .Cells(n, 7).Value & " " & .Cells(n, 8).Value
            Cells(32, 5).Value = .Cells(n, 34).Value
            Cells(33, 4).Value = .Cells(n, 35).Value
            Cells(31, 4).Value = .Cells(n, 13).Value
            Cells(31, 12).Value = IIf(.Cells(n, 9).Value = 2, "女", "男")
            Cells(34, 4).Value = .Cells(n, 33).Value
'27178 end
             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.TextBox24.Value = Workbooks(da).Worksheets("個人情報").Cells(Val(ListBox1.Value), 35).Value '住所
        作成166.TextBox25.Value = Mid(ListBox1.Text, 8) '名前
        作成166.TextBox26.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 印刷()

    'YBNO 25999  ito 20140901
    If ActiveSheet.Name <> "死傷病報告" Then
        If Len(Range("状況欄")) > 70 And InStr(Range("状況欄"), vbLf) = 0 Then
            Dim msg As VbMsgBoxResult
            msg = MsgBox("災害の原因発生状況に改行が含まれていません。" & vbCrLf & "文字数が多い場合、1行に縮小されて印刷されます。文字数によっては縮小された文字が見えない場合があります。" & vbCrLf & "戻って修正しますか？", 4 + 48, "改行の確認")
            If msg = vbYes Then
                Range("状況欄").Select
                Exit Sub
            End If
        End If
    End If

    'ito 電話番号にハイフンが２つ入っていないとメッセージ
    If ActiveSheet.Name = "死傷病報告" Then
        If Len(Worksheets("死傷病報告").Cells(32, 12).Value) < 12 Then
            MsgBox "電話番号は、市外局番から入力してください。また２箇所ハイフン（-）で区切ってください。", 16, "電話番号"
            Exit Sub
        End If
        
        'YBNO 25806  ito 20140731　全角ハイフンが入っている場合はメッセージ
        If InStr(Cells(32, 12).Value, "－") > 0 Or InStr(Cells(32, 12).Value, "―") > 0 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 保存()
'YBNO 25887  ito 20150129　保存フォームにコード移行
保存F.Show
'    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
'    '8号16号6平均賃金追加 ito 20130523
'    If ActiveSheet.Name = "様式8号" Then
'        MyP2 = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name & "\" & "平均賃金" & Fname
'    ElseIf ActiveSheet.Name = "様式16号6" 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
'    ActiveWorkbook.Close False
'
'    '8号平均賃金追加 ito 20130523
'    If ActiveSheet.Name = "様式8号" Then
'        ThisWorkbook.Sheets("平均賃金8").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
'
'    '16号6平均賃金追加 ito 20130528
'    If ActiveSheet.Name = "様式16号6" Then
'        ThisWorkbook.Sheets("平均賃金166").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("様式16号6").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 保存データ読込()
    'YBNO 23040  ito 20130911　2013対策
    '保存読込.Show
    保存読込.Show 0
End Sub
Sub 保存データ読込2(様式 As String) '
    With 保存読込
        .Caption = 様式
        .CommandButton2.Visible = False
        .Label2.Visible = False
        
       'YBNO 25706  ito 20140804　追加
        .Label3.Visible = True
        
        .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{8699BAFF-69A3-4C14-B55C-3F295BBF5944}{AEE6F4B0-7D30-42A5-925B-A18E864DDB7C}"
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  '7号
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        With 作成7
            'YBNO 25706  ito 20140716　新様式対応
            '.TextBox1.Value = Cells(16, 16).Value '負傷年月日
            If Len(Cells(16, 16).Value) = 6 Then
                .TextBox1.Value = "7" + Cells(16, 16).Value '負傷年月日
            Else
                .TextBox1.Value = Cells(16, 16).Value '負傷年月日
            End If
            
            .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 '名前
            
            'YBNO 25706  ito 20140728　改行をなくしてシートに直接戻す
            '.TextBox7.Value = Cells(28, 4).Value '災害発生状況
            .TextBox7.Value = Replace(Replace(Cells(28, 4).Value, vbCrLf, ""), vbLf, "")  '災害発生状況
            ThisWorkbook.ActiveSheet.Cells(70, 4).Value = .TextBox7.Value
            
        'YBNO 25706  ito 20140729　所属事業場もフォームに戻す
        'End With
            'Wh.Cells(63, 14).Value = Cells(39, 8).Value '所属事業場
            'Wh.Cells(64, 14).Value = Cells(40, 8).Value
            .TextBox27.Value = Cells(39, 8).Value '所属事業場
            .TextBox26.Value = Cells(40, 8).Value
            .TextBox101.Value = Cells(43, 4).Value  'YBNO 26617  ito 20150129　監督署追加（フォーム表示はしない）
        End With
            
    '8号用追加  ito 20130301
    ElseIf Me.Caption = "8号用5号様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        With 作成8
            'YBNO 25706  ito 20140716　新様式対応
            '.TextBox1.Value = Cells(16, 16).Value '負傷年月日
            If Len(Cells(16, 16).Value) = 6 Then '負傷年月日
                .TextBox1.Value = "7" + Cells(16, 16).Value
            Else
                .TextBox1.Value = Cells(16, 16).Value
            End If
            
            'YBNO 26438  ito 20141027
            '.ComboBox2.ListIndex = IIf(Cells(22, 28).Value = "午前", 0, 1) '時刻
            .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 '労働者の職種
            
            'YBNO 25706  ito 20140728　改行をなくしてシートに直接戻す
            '.TextBox7.Value = Cells(28, 4).Value '災害発生状況
            .TextBox7.Value = Replace(Replace(Cells(28, 4).Value, vbCrLf, ""), vbLf, "")  '災害発生状況
            ThisWorkbook.ActiveSheet.Cells(66, 4).Value = .TextBox7.Value
            
            'YBNO 26617  ito 20150129　追加（フォーム表示はしない）
            .TextBox101.Value = Cells(43, 4).Value  '監督署
            .TextBox102.Value = Cells(39, 8).Value  '所属事業場名称
            .TextBox103.Value = Cells(40, 8).Value  '所属事業場所在地
            .TextBox104.Value = Cells(40, 29).Value  '所属事業場電話番号
        
        End With
        
    'YBNO 21476  ito 20130625 死傷病用追加
    ElseIf Me.Caption = "死傷病報告　5号様式からの読込" Then
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        With 作成死傷病
            'YBNO 25706  ito 20140716　新様式対応
            '.TextBox1.Value = "7" + Cells(16, 16).Value '負傷年月日
            If Len(Cells(16, 16).Value) = 6 Then '負傷年月日
                .TextBox1.Value = "7" + Cells(16, 16).Value
            Else
                .TextBox1.Value = Cells(16, 16).Value
            End If
            
            'YBNO 23108  ito 20130827　午前でも午後になるエラーを修正
            'If Cells(22, 28).Value = "午前" Then   '時刻
            If Cells(22, 28).Value = "前" Then   '時刻
                .TextBox2.Value = Cells(22, 29).Value
                .TextBox3.Value = Cells(22, 31).Value
            Else
                .TextBox2.Value = Cells(22, 29).Value + 12  '24時間表示に
                .TextBox3.Value = Cells(22, 31).Value
            End If
            .TextBox101.Value = Cells(43, 4).Value  'YBNO 26617  ito 20150129　監督署追加（フォーム表示はしない）
        End With
            Wh.Cells(42, 21).Value = Cells(26, 6).Value '労働者の職種
            Wh.Cells(45, 23).Value = Cells(34, 8).Value '傷病部位
            
            'YBNO 23127  ito 20130827　改行がまだ残っていたので修正
            's = Replace(Cells(28, 4).Value, vbLf, "")
            'YBNO 26085  ito 20140909
            's = Replace(Replace(Cells(28, 4).Value, vbLf, ""), vbCrLf, "")
            s = Replace(Replace(Cells(28, 4).Value, vbCrLf, ""), vbLf, "")
            
            'YBNO 25706  ito 20140728　文字数変更
            'Wh.Cells(49, 3).Value = Mid(s, 1, 20) '発生状況
            'Wh.Cells(50, 3).Value = Mid(s, 21, 20)
            'Wh.Cells(51, 3).Value = Mid(s, 41, 20)
            'Wh.Cells(52, 3).Value = Mid(s, 61, 20)
            'Wh.Cells(53, 3).Value = Mid(s, 81, 20)
            'Wh.Cells(54, 3).Value = Mid(s, 101, 20)
            'Wh.Cells(55, 3).Value = Mid(s, 121, 20)
            'Wh.Cells(56, 3).Value = Mid(s, 141, 20)
            'Wh.Cells(57, 3).Value = Mid(s, 161, 20)
            'Wh.Cells(58, 3).Value = Mid(s, 181, 20)
            'Wh.Cells(59, 3).Value = Mid(s, 201, 20)
            Wh.Cells(49, 3).Value = Mid(s, 1, 25) '発生状況
            Wh.Cells(50, 3).Value = Mid(s, 26, 25)
            Wh.Cells(51, 3).Value = Mid(s, 51, 25)
            Wh.Cells(52, 3).Value = Mid(s, 76, 25)
            Wh.Cells(53, 3).Value = Mid(s, 101, 25)
            Wh.Cells(54, 3).Value = Mid(s, 126, 25)
            Wh.Cells(55, 3).Value = Mid(s, 151, 25)
            Wh.Cells(56, 3).Value = Mid(s, 176, 25)
            Wh.Cells(57, 3).Value = Mid(s, 201, 25)
            Wh.Cells(58, 3).Value = Mid(s, 226, 25)
            Wh.Cells(59, 3).Value = Mid(s, 251, 25)
            
    ElseIf Me.Caption = "様式5号からの読込" Then  '6号
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式5号").Activate
        'YB29842 清水 新様式につきセル番地修正
        Wh.Cells(10, 4).Value = Cells(43, 4).Value '監督署
        Wh.Cells(12, 41).Value = Cells(43, 18).Value  '〒
        Wh.Cells(13, 41).Value = Cells(43, 29).Value 'tel
        Wh.Cells(15, 39).Value = Cells(44, 17).Value '住所
        Wh.Cells(18, 39).Value = Cells(45, 17).Value '名前
        n = 3 '労働保険番号
        For i = 1 To 3
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        n = 10
        For i = 4 To 14
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        Wh.Cells(22, 39).Value = Cells(21, 6).Value '名前
        Wh.Cells(22, 53).Value = IIf(Cells(16, 4).Value = 1, "男", "女") '性別
        Wh.Cells(24, 39).Value = IIf(Left(Cells(16, 6).Value, 1) = "7", "H", "S") & Mid(Cells(16, 6).Value, 2, 2) '生年月日
        Wh.Cells(24, 45).Value = Mid(Cells(16, 6).Value, 4, 2) '生年月日
        Wh.Cells(24, 48).Value = Mid(Cells(16, 6).Value, 6, 2) '生年月日
        Wh.Cells(24, 52).Value = Cells(21, 22).Value '年齢
        Wh.Cells(25, 39).Value = Cells(23, 6).Value '住所
        Wh.Cells(27, 39).Value = Cells(26, 6).Value '職種
        
        'YBNO 25706  ito 20140716　新様式対応
        '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) '負傷年月日
        If Len(Cells(16, 16).Value) = 6 Then
            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) '負傷年月日
        Else '7桁だったら
            Dim HI As Long
            HI = Right(Cells(16, 16).Value, 6)
            Wh.Cells(23, 56).Value = Mid(HI, 1, 2) '負傷年月日
            Wh.Cells(23, 60).Value = Mid(HI, 3, 2) '負傷年月日
            Wh.Cells(23, 63).Value = Mid(HI, 5, 2) '負傷年月日
        End If
        
        Wh.Cells(26, 56).Value = "午" & Cells(22, 28).Value '負傷時刻
        Wh.Cells(26, 59).Value = Cells(22, 29).Value '負傷時刻
        Wh.Cells(26, 62).Value = Cells(22, 31).Value '負傷時刻
        Wh.Cells(35, 30).Value = Cells(36, 8).Value '事業所名
        Wh.Cells(36, 25).Value = Cells(37, 29).Value '〒
        Wh.Cells(36, 39).Value = Cells(36, 29).Value 'TEL
        Wh.Cells(38, 30).Value = Cells(37, 8).Value '住所
        Wh.Cells(40, 30).Value = Cells(38, 8).Value  '事業主
        Wh.Cells(42, 26).Value = Cells(32, 10).Value '病院名称
        Wh.Cells(44, 26).Value = Cells(33, 10).Value '所在地
        Wh.Cells(57, 26).Value = Cells(34, 8).Value '傷病名
        
        'YBNO 25706  ito 20140728　改行を全て取る
        's = Replace(Cells(28, 4).Value, vbLf, "")
        'YBNO 26085  ito 20140909
        's = Replace(Replace(Cells(28, 4).Value, vbLf, ""), vbCrLf, "")
        s = Replace(Replace(Cells(28, 4).Value, vbCrLf, ""), vbLf, "")
        
        'YBNO 25821  ito 20140806　縮小されない文字数で戻す
        'Wh.Cells(29, 13).Value = Mid(s, 1, 60)  '発生状況 20131114 ishikawa YB23740
        'Wh.Cells(30, 13).Value = Mid(s, 61, 60)
        'Wh.Cells(31, 13).Value = Mid(s, 121, 60)
        'Wh.Cells(32, 13).Value = Mid(s, 181, 60)
        Wh.Cells(28, 21).Value = Mid(s, 1, 37)  '発生状況
        Wh.Cells(29, 3).Value = Mid(s, 38, 49)
        Wh.Cells(30, 3).Value = Mid(s, 87, 49)
        Wh.Cells(31, 3).Value = Mid(s, 136, 49)
        Wh.Cells(32, 3).Value = Mid(s, 185, 49)
        
    ElseIf Me.Caption = "様式16号の3からの読込" Then  '16号4
        Workbooks(ListBox1.Value & ".xls").Worksheets("様式16号3").Activate
        'YB29842 清水 新様式につきセル番地修正
        'YBNO 25821  ito 20140807　セル番地修正
        Wh.Cells(10, 4).Value = Cells(43, 4).Value '監督署
        Wh.Cells(12, 41).Value = Cells(43, 18).Value  '〒
        Wh.Cells(13, 41).Value = Cells(43, 29).Value 'tel
        Wh.Cells(15, 39).Value = Cells(44, 17).Value '住所
        Wh.Cells(18, 39).Value = Cells(45, 17).Value '名前
        n = 3 '労働保険番号
        For i = 1 To 3
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        n = 10
        For i = 4 To 14
            Wh.Cells(24, n).Value = Mid(Cells(13, 4).Text, i, 1)
            n = n + 2
        Next
        
        
        Wh.Cells(22, 39).Value = Cells(21, 6).Value '名前
        Wh.Cells(22, 53).Value = IIf(Cells(16, 4).Value = 1, "男", "女") '性別
        Wh.Cells(24, 39).Value = IIf(Left(Cells(16, 6).Value, 1) = "7", "H", "S") & Mid(Cells(16, 6).Value, 2, 2) '生年月日
        Wh.Cells(24, 45).Value = Mid(Cells(16, 6).Value, 4, 2) '生年月日
        Wh.Cells(24, 48).Value = Mid(Cells(16, 6).Value, 6, 2) '生年月日
        Wh.Cells(24, 52).Value = Cells(21, 22).Value '年齢
        Wh.Cells(25, 39).Value = Cells(23, 6).Value '住所
        Wh.Cells(27, 39).Value = Cells(26, 6).Value '職種
        
        'YBNO 25706  ito 20140716　新様式対応
        '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) '負傷年月日
        If Len(Cells(16, 16).Value) = 6 Then
            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) '負傷年月日
        Else '7桁だったら
            Dim HI2 As Long
            HI2 = Right(Cells(16, 16).Value, 6)
            Wh.Cells(23, 56).Value = Mid(HI2, 1, 2) '負傷年月日
            Wh.Cells(23, 60).Value = Mid(HI2, 3, 2) '負傷年月日
            Wh.Cells(23, 63).Value = Mid(HI2, 5, 2) '負傷年月日
        End If
        
        Wh.Cells(26, 56).Value = "午" & Cells(51, 28).Value '負傷時刻
        Wh.Cells(26, 59).Value = Cells(51, 29).Value '負傷時刻
        Wh.Cells(26, 62).Value = Cells(51, 31).Value '負傷時刻
        Wh.Cells(35, 30).Value = Cells(36, 8).Value '事業所名
        Wh.Cells(36, 25).Value = Cells(37, 29).Value '〒
        Wh.Cells(36, 39).Value = Cells(36, 29).Value 'TEL
        Wh.Cells(38, 30).Value = Cells(37, 8).Value '住所
…