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
#If Win64 Then
#Else
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Toziru = False Then
    MsgBox "メニュー画面の「終了」ボタンから閉じてください。", 16, "終了"
    Cancel = True
    Exit Sub
    End If
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls("Cells給与").Delete
    Application.CommandBars("Cell").Controls("個人情報").Delete
    Application.CommandBars("Cell").Controls("過去データ").Delete
    ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = True
    MsgBox "このファイルは保存することはできません。", 16, "保存"
End Sub
#End If

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
' taka 20150723
'Private Sub CommandButton1_Click()
'Private Sub TextBox4688_Click()
'Call 終了
'End Sub
Sub Zoom_in()
    ActiveWindow.Zoom = ActiveWindow.Zoom + 5
    MyZoom
End Sub
Sub Zoom_out()
    ActiveWindow.Zoom = ActiveWindow.Zoom - 5
    MyZoom
End Sub


Private Sub MyZoom()
    Dim TextFilename As String
    TextFilename = ThisWorkbook.path & "\MyTool\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & ActiveSheet.Name & "Zoom.dat"
    Open TextFilename For Output As #1
        Write #1, ActiveWindow.Zoom
    Close #1
End Sub


'Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'    With ActiveSheet.ListBox1
'        If .value = 0 Then
'            MsgBox "ファイルを選択して実行してください。", 16, AAA
'            Exit Sub
'        End If
'        If .value <> "" Then
'            Call F読込(.value)
'        Else
'            MsgBox "事業所名をダブルクリックしてください。", vbExclamation, "Cells給与MENU"
'        End If
'    End With
'End Sub

Attribute VB_Name = "Sheet12"
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 = "シート表示"
Option Explicit
Dim msg As Integer

Sub 電卓へ()
    On Error Resume Next
    Dim ReturnValue
    ReturnValue = shell("CALC.EXE", 1)
End Sub
Sub 年齢早見表へ()
    Call フォーム表へ("便利帳.xls", "年齢へ")
End Sub
Sub 基本手当へ()
    Call フォーム表へ("便利帳.xls", "基本手当へ")
End Sub
Sub 通勤手当へ()
    Call フォーム表へ("便利帳.xls", "通勤手当へ")
End Sub
Sub 標準報酬へ()
    Call フォーム表へ("便利帳.xls", "標準報酬へ")
End Sub
Sub 雇用保険へ()
    Call フォーム表へ("便利帳.xls", "雇用保険へ")
End Sub
Sub 税額表へ()
    Workbooks.Open ThisWorkbook.path & "\源泉所得税.xls" '20130107 titti
End Sub
Sub 有給付与表へ()
    Call フォーム表へ("便利帳.xls", "有給付与表へ")
End Sub
Sub 計算チェックへ()
    Call フォーム表へ("計算チェック.xls", "CheckFへ")
End Sub
Private Sub フォーム表へ(ブック As String, マクロ As String)
    Application.ScreenUpdating = False
    Dim s As Workbook
    Set s = ActiveWorkbook
    Workbooks.Open fileName:=ThisWorkbook.path & "\" & ブック
    s.Activate
    Application.Run ブック & "!" & マクロ
    Application.ScreenUpdating = True
    Set s = Nothing
End Sub
Sub バージョンアップへ()
    On Error GoTo ErrorCheck
    Dim fileName As String
    ChDrive "A"
    ChDir "A:\"

    Application.Dialogs(xlDialogOpen).Show
    Exit Sub
ErrorCheck:
    Application.Dialogs(xlDialogOpen).Show
End Sub
Sub バージョン情報へ()
'    Application.DisplayAlerts = False
'    CreateObject("Shell.Application").Open ThisWorkbook.Path & "\Cells給与　バージョン情報.chm"
'    Application.DisplayAlerts = True

    Dim URL As String, IE As Object
    Set IE = CreateObject("InternetExplorer.Application")
    URL = "http://www.cells.co.jp/kyuyo/?cat=7"
    With IE
        .Navigate (URL)
        .Visible = True
    End With
    Set IE = Nothing
End Sub
Sub 行列表示()
    '#35442 hara 20160217
    Dim bookName As String
    Dim sheetName As String
    bookName = ActiveWorkbook.Name
    sheetName = ActiveSheet.Name
    Workbooks(bookName).Worksheets(sheetName).Activate
    
    ActiveSheet.Unprotect
    If ActiveWindow.DisplayHeadings = False Then
        ActiveWindow.DisplayHeadings = True
    Else
        ActiveWindow.DisplayHeadings = False
    End If
    MsgBox "行列を表示しシートの保護を解除しました。", 64, "保護解除・行列表示"
End Sub
Sub A1形式()
    If Application.ReferenceStyle = xlA1 Then
        Application.ReferenceStyle = xlR1C1
    Else
        Application.ReferenceStyle = xlA1
    End If
End Sub
Sub シートの表示()
    シート.Show 0
End Sub
Sub シートMENU()
    Sheets("MENU").Select
End Sub
Sub ツールへ()
    Application.ScreenUpdating = False
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name Like "*kk*" Then
            MsgBox "事業所ファイルが起動しています。これらのファイルを閉じてから実行してください。", 16, AAA
            Exit Sub
        End If
    Next
    For Each wb In Workbooks
        If wb.Name = "ツール.xls" Then
            wb.Activate
            Exit Sub
        End If
    Next
    Workbooks.Open ActiveWorkbook.path & "\ツール.xls"
    Application.Run ActiveWorkbook.Name & "!初期処理"
    Application.ScreenUpdating = True
End Sub
Sub 入力2へ()
    入力.Caption = "賞与入力"
    入力.Show
End Sub
'Sub 台帳適用へ()
'台帳適用.Show
'End Sub
Sub 明細印刷へ()
    明細印刷.Show
End Sub
Sub 台帳の読込()
    On Error GoTo EC
    If Dir(Worksheets("基本項目").Cells(17, 25).value & "\" & Worksheets("基本項目").Cells(15, 25).value & "da.xls") = "" Then
        MsgBox "台帳ファイルが見つかりません。", 16, AAA
        n = 1230
        Exit Sub
    End If
    Workbooks.Open fileName:=Worksheets("基本項目").Cells(17, 25).value & "\" & Worksheets("基本項目").Cells(15, 25).value & "da.xls"
    Exit Sub
EC:
    MsgBox "「台帳」ファイルの登録が不正です。「基本項目」→「その他」で設定してください。", 16, AAA
End Sub
Sub 台帳ファイルの読込()
    Application.ScreenUpdating = False
    Dim myp As String
    Dim ファイル名  As String
    Dim 台帳  As String
    ファイル名 = ActiveWorkbook.Name
    台帳 = Worksheets("基本項目").Cells(15, 25).value & "da.xls"
    myp = Workbooks("Cells給与.xls").Worksheets("表").Cells(32, 22).value
    If Trim(myp) = "" Then
'20161031 kon #33511
        MsgBox "台帳名が登録されていないため実行できません。（システムの起動画面の「ツール」→「台帳パス」で登録してください。）", 16, AAA
'        MsgBox "台帳のパスが登録されていないため実行できません。（システムの起動画面の「ツール」→「台帳パス」で登録してください。）", 16, AAA
        Exit Sub
    End If
    
    'YB34009 ここから
'    If Dir(myp) = "" Then
'        MsgBox "「" & myp & "」は有効なパス、ファイル名ではありません。", 16, AAA
'        Exit Sub
'    End If
'    Dim fso As Object
'    Set fso = CreateObject("Scripting.FileSystemObject")
'    If fso.fileExists(myp) Then
'    Else
'        MsgBox "「" & myp & "」は有効なパス、ファイル名ではありません。", 16, AAA
'        Exit Sub
'    End If
    'taka 20161102
    If Application.Run("Cells給与.xls!PathCheck", myp) = False Then Exit Sub
    
    myp = myp & "\" & 台帳
    If Dir(myp) = "" Then
        MsgBox "「" & myp & "」は有効なパス、ファイル名ではありません。", 16, AAA
        Exit Sub
    End If
    'YB34009 ここまで

    Workbooks.Open myp
    Workbooks.Open ThisWorkbook.path & "\" & "台帳F.xls"
    Worksheets("DATA").Cells(1, 1).value = 台帳
    Worksheets("DATA").Cells(2, 1).value = ファイル名
    Application.Run "台帳F.xls!初期処理"
End Sub
Sub 終了()
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.CellDragAndDrop = True
    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic '計算させて
    Dim wb As Object, ブックの数 As Integer
    ブックの数 = 0
    For Each wb In Application.Workbooks
        If wb.Name Like "ZennenCopy*" Then '前年ファイルがエラー等で非表示で開いたままになっている場合に備えて
            wb.Close False
            ThisWorkbook.Activate
        Else
            If wb.Name Like "*kk*" Then
                MsgBox "事業所ファイル「" & Left(wb.Name, Len(wb.Name) - 6) & "」が起動中のため実行できません。", 16, AAA
                wb.Activate
                Exit Sub
            End If
        End If
        If UCase(wb.Name) Like "PERSONAL*" Then
            Else
            ブックの数 = ブックの数 + 1
        End If
    Next
    Toziru = True '閉じる許可
    
    Workbooks("CellsKyuyoTool.xla").Close False
    Workbooks("fGet.xla").Close False
    
    'サポートバー対策
    If Not IsOpen("DaMenu.xls") And Not IsOpen("最適給与.xls") Then
        Workbooks("CellsSupport.xlam").Close '20111028
    End If
    
    If ブックの数 = 1 Then
        ThisWorkbook.Saved = True
        Application.Quit
    Else
        ThisWorkbook.Activate
        Call End1
    End If
End Sub
Function MyHour(MyRange As Range)
    Dim s As Range
    Dim MyTime As Double
    '10進法になおして集計
    For Each s In MyRange
        If s.value <> "" And IsNumeric(s.value) Then
            MyTime = MyTime + Fix(s.value) + (s.value * 100 Mod 100) / 60
        End If
    Next
    '集計後60進法表示にする
'20100510 kon
'    If FIX(MyTime) = MyTime Then
    If Fix(Val(Format(MyTime, "0.00"))) = Val(Format(MyTime, "0.00")) Then
        MyHour = MyTime
    Else
        MyHour = Fix(MyTime) + (MyTime - Fix(MyTime)) * 0.6
    End If
End Function


Attribute VB_Name = "その他"
Option Explicit
Dim 列 As Integer
Dim 行 As Integer
Dim msg As Integer

Sub 個人情報削除()
Attribute 個人情報削除.VB_ProcData.VB_Invoke_Func = " \n14"
    列 = ActiveCell.Column
    If 列 < 5 Or 列 > 156 Or ActiveCell.row < 5 Or ActiveCell.row > 6 Then
        MsgBox "NO、または氏名の欄にカーソルを置いて実行してください"
        Exit Sub
    End If
    msg = MsgBox("このデータを削除します。" & Chr(13) & _
    "保存データ」にこのデータがあるとエラーになります。" & Chr(13) & _
    "本当に削除してもいいですか？", 1 + 16, "データ削除")
    
    If msg <> 1 Then
        Exit Sub
    End If
    Range(Cells(5, 列), Cells(150, 156)).value = Range(Cells(5, 列 + 1), Cells(150, 157)).Value2
End Sub

Function 半角文字(strg As String)
Attribute 半角文字.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim strg1 As String
    Dim nn As Integer
    Dim ii As Integer
    nn = 0
    For ii = 1 To Len(strg)
        strg1 = Mid(strg, ii, 1)
        If Asc(strg1) < 256 And Asc(strg1) >= 0 Then
            nn = nn + 1
        End If
    Next
    半角文字 = nn
End Function

Sub 幅プラス()
    If ActiveCell.Column < 7 Then
        MsgBox "勤怠項目にカーソルを置いて実行してください", 16, AAA
    Exit Sub
    End If
    ActiveCell.ColumnWidth = ActiveCell.ColumnWidth + 1
End Sub

Sub 幅マイナス()
    If ActiveCell.Column < 7 Then
        MsgBox "勤怠項目にカーソルを置いて実行してください", 16, AAA
        Exit Sub
    End If
    If ActiveCell.ColumnWidth < 1 Then
        ActiveCell.EntireColumn.Hidden = True
        Exit Sub
    End If
    If ActiveCell.ColumnWidth < 1 Then
        Exit Sub
    End If
    ActiveCell.ColumnWidth = ActiveCell.ColumnWidth - 1
End Sub

Sub 右()
    Application.MoveAfterReturnDirection = xlToRight
    MsgBox "「→に移動」に変更しました。", 64, AAA
End Sub

Sub 下()
    Application.MoveAfterReturnDirection = xlDown
    MsgBox "「↓に移動」に変更しました。", 64, AAA
End Sub

Sub 部門入力へ()
    If WorksheetFunction.Count(Columns(3)) + 7 < 8 Then
        MsgBox "データがありません。", 16, AAA
        Exit Sub
    End If
    部門入力.Show
End Sub

Sub リスト作成()
    Workbooks.Open ThisWorkbook.path & "\ファイルリストの作成.xla"
    Application.Run "ファイルリストの作成.xla!初期処理"
End Sub

Sub メニューシート更新()
    Dim kkファイル As String
    kkファイル = ActiveWorkbook.Name
    If Right(kkファイル, 6) = "kk.xls" And ActiveSheet.Name <> "MENU" Then
        MsgBox "この処理は事業所ファイルのメニュー画面で処理してください。", 16, "シート交換"
        Exit Sub
    End If
    If MsgBox("メニューシートを更新しますか？", 1 + 32, "シート交換") <> 1 Then Exit Sub
    Workbooks.Open ThisWorkbook.path & "\新規作成.xls"
    Workbooks(kkファイル).Worksheets("MENU").Activate
    ActiveSheet.Unprotect
    With Workbooks("新規作成.xls").Worksheets("MENU")
        .Range(.Cells(19, 14), .Cells(31, 14)).value = Range(Cells(19, 14), Cells(31, 14)).value
        .Range(.Cells(20, 3), .Cells(25, 10)).value = Range(Cells(20, 3), Cells(25, 10)).value
    End With
    Application.DisplayAlerts = False 'シート削除のメッセージをださない
    Worksheets("MENU").Delete
    Workbooks("新規作成.xls").Activate
    Sheets("MENU").Select
    Sheets("MENU").Move Before:=Workbooks(kkファイル).Sheets(1)
    Range("H2").FormulaR1C1 = "=基本項目!R4C3"
    Range("G2").FormulaR1C1 = "=基本項目!R15C3"
    Cells(7, 5).Select
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect userinterfaceonly:=True
    Workbooks("新規作成.xls").Activate
    Application.EnableEvents = False
    ActiveWorkbook.Close
    Application.EnableEvents = True
    Workbooks(kkファイル).Worksheets("MENU").Activate
    ActiveWorkbook.Save
    MsgBox "メニューシートの入れ替えに成功しました。", 64, "シート更新"
End Sub

Function fncNenrei(ByVal Tanjyobi As Variant, ByVal Kijyunbi As Variant) As Variant
    Dim nOld As Integer         ''年齢(年)
    Dim nTuki As Integer        ''　　(月)
    On Error Resume Next
    Tanjyobi = CVDate(Mid(Tanjyobi, 1, 3) & "/" & Mid(Tanjyobi, 4, 2) & "/" & Mid(Tanjyobi, 6, 2))
    If IsDate(Tanjyobi) = False Then
        fncNenrei = ""
        Exit Function
    Else
        Tanjyobi = CVDate(Tanjyobi)  'gee/mm/dd => yyyy/mm/dd
    End If
    If IsDate(Kijyunbi) = False Then
        fncNenrei = ""
        Exit Function
    Else
        Kijyunbi = CVDate(Kijyunbi)
    End If
    
    If Kijyunbi < Tanjyobi Then
        fncNenrei = ""
        Exit Function
    End If
    '年齢(？歳？カ月)を計算する
    If Kijyunbi = Tanjyobi Then
        nOld = 0
        nTuki = 0
    ElseIf Year(Kijyunbi) <> Year(Tanjyobi) Then
        'DateDiff関数を用いて数え歳-1を求める
        nOld = DateDiff("yyyy", Tanjyobi, Kijyunbi) - 1
        nTuki = Month(Kijyunbi) - Month(Tanjyobi) + 11
        If Day(Kijyunbi) >= Day(Tanjyobi) Then
            nTuki = nTuki + 1
        End If
        If nTuki >= 12 Then
            nOld = nOld + 1
            nTuki = nTuki - 12
        End If
    Else
        nOld = 0
        If Month(Kijyunbi) = Month(Tanjyobi) Then
            nTuki = 0
        ElseIf Month(Kijyunbi) >= Month(Tanjyobi) Then
            If Day(Kijyunbi) >= Day(Tanjyobi) Then
                nTuki = Month(Kijyunbi) - Month(Tanjyobi)
            Else
                nTuki = Month(Kijyunbi) - Month(Tanjyobi) - 1
            End If
        End If
    End If
    '戻り値のセット
    fncNenrei = Format$(CDec(nOld + nTuki * 0.01), "0")
End Function

Sub 退職者の削除(No As Long)
    If カレンダー.Caption = "退社年月日" Then
        If MsgBox("「給与・賞与入力シート」からこのデータをクリアしますか？", 4 + 32, "退職者") = 6 Then
            With Worksheets("給与入力")
                If IsError(Application.Match(No, .Columns(3), 0)) = False Then
                    .Rows(Application.Match(No, .Columns(3), 0)).Delete
                End If
            End With
            With Worksheets("賞与入力")
                If IsError(Application.Match(No, .Columns(3), 0)) = False Then
                    .Rows(Application.Match(No, .Columns(3), 0)).Delete
                End If
            End With
        End If
    End If
End Sub

Sub 個人Fへ()
    個人F.Show
End Sub

Sub 入力表作成()
    Dim MyDATA1 As Integer
    Dim MyData2 As Integer
    Dim MyStr As String
    Dim 入力ファイル名 As String
    Dim ファイル名 As String
    ファイル名 = ActiveWorkbook.Name
    入力ファイル名 = Left(ファイル名, Len(ファイル名) - 6) & "給与入力表.xls"
    
    'YBNO 26965  ito 20150121　kkの別のシートが開いていると範囲が取れないため
    Workbooks(ファイル名).Worksheets("給与入力").Activate
    
    MyDATA1 = WorksheetFunction.Count(Range("C8:C1007")) '登録されている社員数
    Dim n As Integer
'    n = Cells(7, 255).End(xlToLeft).Column'20121203titti
    Workbooks.Open fileName:=ActiveWorkbook.path & "\入力表\" & 入力ファイル名
    Sheets("給与入力").Select
    Application.Run "CellsKyuyoTool.xla!モジュール入替", "給与入力表.xls", ThisWorkbook.path, ActiveWorkbook.path
'    Columns(49).ColumnWidth = 0.08 'これがないと入力表の「ツール」で項目名が表示されない（苦肉の策）20070522 20121203 titti
    Cells(1, 50).value = Workbooks(ファイル名).Worksheets("基本項目").Cells(22, 25).value
    ActiveSheet.Shapes("もどる").Visible = True
    ActiveSheet.Shapes("ツール").Visible = True
    ActiveSheet.Shapes("適用").Visible = True
    Cells(1, 55).value = 1 'ここから読み込んだ印、もし単独で開いた場合は0となる
    MyData2 = WorksheetFunction.Count(Range("C8:C1007"))  '登録されている社員数
    If MyData2 = 0 Then '初めての読込
        If MyDATA1 > 18 Then
            Rows("9:" & (9 + MyDATA1 - 16)).Insert Shift:=xlDown 'その数分+2だけ行を挿入する
        End If
    Else
        If 18 < MyDATA1 Then  '入力表の方の社員数が少なければ
            If MyDATA1 > MyData2 Then
                Rows("9:" & (9 + MyDATA1 - MyData2)).Insert Shift:=xlDown 'その数分だけ行を挿入する
            End If
        End If
    End If
    With Workbooks(ファイル名).Worksheets("給与入力")
        Range(Cells(8, 3), Cells(Cells(2000, 3).End(xlUp).row, 6)).ClearContents '現在のデータをクリアして
        'Noと氏名をコピーする
        
        Range("C8:F" & (MyDATA1 + 7)).value = .Range("C8:F" & (MyDATA1 + 7)).value
        For i = 8 To Cells(2000, 3).End(xlUp).row
            Cells(i, 3).Font.ColorIndex = .Cells(i, 3).Font.ColorIndex '色を一緒に
            Cells(i, 6).Font.ColorIndex = .Cells(i, 6).Font.ColorIndex '色を一緒に
        Next
        If Cells(7, 3).value = "" Then  '（初めての場合）
            Cells(5, 51).value = Workbooks(ファイル名).Worksheets("基本項目").Cells(4, 3).value '会社名
            Cells(1, 50).value = Workbooks(ファイル名).Worksheets("基本項目").Cells(49, 3).value 'アドレス
            Range(Cells(7, 3), Cells(7, 50)).value = .Range(.Cells(7, 3), .Cells(7, 50)).value

            For i = 7 To 50
                Columns(i).Hidden = .Columns(i).Hidden
            Next
            
            If Dir(ThisWorkbook.path & "\MyTool\社労士事務所情報.dat") = "" Then '事務所名をおく
            Else
                Open ThisWorkbook.path & "\MyTool\社労士事務所情報.dat" For Input As #1
                    For i = 1 To 7
                        Input #1, MyStr
                        If i = 3 Then Cells(1, 45).value = MyStr '事務所名
                        If i = 6 Then Cells(1, 48).value = MyStr  'ファックス
                        If i = 7 Then Cells(1, 51).value = MyStr  'メール
                    Next
                Close #1
            End If
        End If
        Cells(4, 6).value = .Cells(4, 6).value + 1 '○月分をプラス1する
        If Cells(4, 6).value = 13 Then '13になったら1月にする
            Cells(4, 6).value = 1
        End If
    End With
End Sub

Sub End1()
    Application.OnTime Now + TimeValue("00:00:1"), "End2"
End Sub

Sub End2()
    ActiveWorkbook.Close False
End Sub



Attribute VB_Name = "部門部課"
Attribute VB_Base = "0{F7D6C38F-D19C-461F-9134-714ABF4BC898}{74B06F89-71AA-4AB1-8905-F37A975F1D0A}"
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 ii As Integer
Dim Bu As Integer
Dim p As Integer
Private Sub chkPDF_Click()
Dim VerNO As String

     'バージョン確認
    VerNO = Application.Version
    If Left(VerNO, 2) < 12 And chkPDF.value Then
        MsgBox "この機能を利用するにはExcel2007 SP2　以上がインストールされている必要が有ります。", vbInformation, "PDF印刷"
        chkPDF.value = False
        Exit Sub
    End If
    If Left(VerNO, 2) = 12 Then
        If Val(Application.Build) < 6425 And chkPDF.value Then
            MsgBox "この機能を利用するにはExcel2007 SP2　以上がインストールされている必要が有ります。", vbInformation, "PDF印刷"
            chkPDF.value = False
            Exit Sub
        End If
    End If
    
    Cells(1, 12).value = chkPDF.value
    Cells(1, 12).Font.ColorIndex = 2
End Sub
Private Sub CommandButton1_Click()
'17582
Dim objWB As Excel.Workbook
Dim strSN As String
Dim vntFileName As Variant
Dim vData As Variant

Application.ScreenUpdating = False
ActiveSheet.Unprotect
Dim Mycount As Integer
n = 0
For ii = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(ii) = True Then
n = 1
Exit For
End If
Next

If n = 0 Then
    MsgBox "リストを選択してください。", 16, AAA
Exit Sub
End If

If OptionButton1.value = True Then '部門
    Bu = 3
    Else
    Bu = 4
End If

If Right(ActiveSheet.Name, 4) = "支給控除" Then
'----支給控除一覧表----------------
    If 給賞 = "給与" Then '賞与だったらやらない
        If CheckBox1.value = False And CheckBox2.value = False And CheckBox3.value = False Then
            MsgBox "印刷する帳票にチェックを入れてください。", 16, AAA
            Exit Sub
        End If

    Cells(1, 13).value = CheckBox1.value '勤怠
    Cells(1, 14).value = CheckBox2.value '支給控除
    Cells(1, 15).value = CheckBox3.value '勤怠付き支給控除

    
    End If
    If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
    vData = Range(Cells(7, 3), Cells(110, 17)).value '現在データを覚える（あとでこれを戻す）
    
    Range("B207:DH207").value = Worksheets(給賞 & "DATA").Range("B7:DH7").value
    Cells(207, 101).value = "扶養人数" 'このセルにデータがないと次のマクロが暴走するため（念のため）
    Range("B208:DH" & Cells(3000, 101).End(xlUp).row + 5).ClearContents '万が一のため（データが残っている場合に備えて）
    '#17582
    If chkPDF Then
        '新規ブックの準備
        strSN = ActiveSheet.Parent.Name
        Set objWB = Workbooks.Add   '新ブックを作る
        Workbooks(strSN).Activate 'ブックを戻す
    End If
    
    For ii = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(ii) = True Then '選択されていたら
            If Val(ListBox1.List(ii, 1)) <> 0 Then '人数が０でなければ
                Range("B208:DH" & Cells(3000, 2).End(xlUp).row + 5).ClearContents
                n = 0
                With Worksheets(給賞 & "DATA") 'データを抽出する
                    For i = 8 To .Cells(3000, 2).End(xlUp).row
                        If .Cells(i, Bu).value = ii + 1 Then
                            Range(Cells(208 + n, 2), Cells(208 + n, 112)).value = .Range(.Cells(i, 2), .Cells(i, 112)).Value2
                            n = n + 1
                        End If
                    Next
                End With
                If 給賞 = "給与" Then
                Range("F206:AH206").FormulaR1C1 = "=IF(R[1]C=0,"""",SUM(R[2]C:R[1001]C))" '合計を出す
                End If
                Range("AO206:CR206").FormulaR1C1 = "=IF(R[1]C=0,"""",SUM(R[2]C:R[1001]C))" '合計を出す
                
                Range("F206:CR206").value = Range("F206:CR206").value
                If 給賞 = "給与" Then
                    For i = 10 To 34 '60進法表示にする 20121219 titti
                        If Worksheets(給賞 & "DATA").Cells(2, i).value = True Then
                            Cells(206, i).value = MyHour(Range(Cells(208, i), Cells(208 + n, i)))
                        End If
                    Next
                End If
                If chkPDF Then
                    'PDFのとき
                    'MsgBox "PDF"
                    If 給賞 = "給与" Then
                    '給与のとき
                        If CheckBox1.value Then '勤怠
                            部門部課別PDF連続支給控除印刷 SIKYUKOJYO_KITAI, KYUSYOKUBN_KYUYO, objWB, strSN
                        End If
                        If CheckBox2.value Then '支給控除
                            部門部課別PDF連続支給控除印刷 SIKYUKOJYO_KITAI_NASHI, KYUSYOKUBN_KYUYO, objWB, strSN
                        End If
                        If CheckBox3.value Then '勤怠付支給控除
                            部門部課別PDF連続支給控除印刷 SIKYUKOJYO_KITAI_ARI, KYUSYOKUBN_KYUYO, objWB, strSN
                        End If
                    Else
                    '賞与のとき
                        部門部課別PDF連続支給控除印刷 SIKYUKOJYO_KITAI_NASHI, KYUSYOKUBN_SYOUYO, objWB, strSN
                    End If
                Else
                    '印刷のとき
                    For n = 1 To Val(ListBox1.List(ii, 2)) '総ページ数
                        頁 (n)
                        
                        If Cells(1, 17).value = True Then 'ページ数を表示しないだったら
                            ActiveSheet.PageSetup.CenterFooter = ""
                        Else
                            ActiveSheet.PageSetup.CenterFooter = "-" & n & "-"
                        End If
                        
                        If 給賞 = "給与" Then
                            If CheckBox1.value = True Then '勤怠
                                PageSet1
                                ActiveSheet.PageSetup.RightFooter = "支給人数  " & ListBox1.List(ii, 1) & "名" '20101206 重
                                DoEvents    '20081015 kon
                                Range(Cells(10, 3), Cells(42, p + 3)).PrintOut '20122224 titti
                                DoEvents    '20081015 kon
                            End If
                            If CheckBox2.value = True Then '支給控除
                                PageSet2
                                ActiveSheet.PageSetup.RightFooter = "支給人数  " & ListBox1.List(ii, 1) & "名" '20101206 重
                                DoEvents    '20081015 kon
                                Range(Cells(47, 3), Cells(Cells(1, 16), p + 3)).PrintOut
                                DoEvents    '20081015 kon
                            End If
                            If CheckBox3.value = True Then '勤怠支給控除
                                PageSet2
                                ActiveSheet.PageSetup.RightFooter = "支給人数  " & ListBox1.List(ii, 1) & "名" '20101206 重
                                勤怠付き調整 (p)
                                勤怠支給控除印刷 (p)
                                勤怠付き戻す (p)
                            End If
                        Else
                            PageSet2
                            ActiveSheet.PageSetup.RightFooter = "支給人数  " & ListBox1.List(ii, 1) & "名" '20101206 重
                            DoEvents    '20081015 kon
                            Range(Cells(47, 3), Cells(Cells(1, 16), p + 3)).PrintOut '賞与だったら支給控除
                            DoEvents    '20081015 kon
                        End If
                    Next
                End If
            End If
        End If
    Next ii
    
   
    If chkPDF Then
        'ファイルを保存するダイアログを開きます
        vntFileName = Application.GetSaveAsFilename("支給控除一覧表", "PDFファイル(*.pdf),*.pdf", 1, "保存先の指定")
        If Not vntFileName <> False Then
            Exit Sub
        End If
        Application.DisplayAlerts = False
        objWB.Worksheets(1).Delete 'デフォルトシートを消す
        Application.DisplayAlerts = True
        On Error GoTo ERR_ROUTIN
        objWB.ExportAsFixedFormat 0, vntFileName, 0
        On Error GoTo 0
        objWB.Close False
        Set objWB = Nothing
    End If
    
    '終わったら戻す
    Range(Cells(7, 3), Cells(110, 17)).value = vData
    
    '抽出したデータをクリアする
    Range("B208:DH" & Cells(3000, 2).End(xlUp).row + 5).ClearContents
ElseIf ActiveSheet.Name Like "*金種*" Then
'-------金種表---------------------
    If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
    For ii = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(ii) = True Then '選択されていたら
            If Val(ListBox1.List(ii, 1)) <> 0 Then '人数が０でなければ
            Range("C16:O" & Cells(2000, 3).End(xlUp).row + 20).Borders(xlInsideHorizontal).LineStyle = xlNone '罫線のクリア
            Range("C16:O" & Cells(2000, 3).End(xlUp).row + 20).ClearContents '現データをクリア（多めに）
                n = 0
                With Worksheets(給賞 & "DATA") 'データを抽出する
                    For i = 8 To .Cells(2000, 2).End(xlUp).row
                        If .Cells(i, 39).value = "" Then Exit For
                        If .Cells(i, Bu).value = ii + 1 And .Cells(i, 96).value > 0 Then '現金支給があったら
                            Cells(16 + n, 3).value = .Cells(i, 39).value 'no
                            Cells(16 + n, 4).value = .Cells(i, 40).value '名前
                            Cells(16 + n, 5).value = .Cells(i, 96).value '現金支給額
                            n = n + 1
                        
                        End If
                     Next
                End With
                If n > 0 Then 'データがあれば数式を代入して、罫線を設定して印刷をおこなう
                行 = n + 15
                Range("F16:O" & 行).FormulaR1C1 = "=INT(MOD(RC5,R1C)/R15C)"
                Range("H16:H" & 行).FormulaR1C1 = "=IF(基本項目!R19C26=TRUE,INT(MOD(RC5,R1C)/R15C),0)"
                Range("I16:I" & 行).FormulaR1C1 = _
                "=IF(基本項目!R19C26=TRUE,MOD(INT(MOD(RC5,5000)/1000),2),INT(MOD(RC5,R1C)/R15C))"
                Range("F12:O12").FormulaR1C1 = "=SUM(R[4]C:R[1005]C)"
                Range("E14").FormulaR1C1 = "=SUM(R[2]C:R[1004]C)"
                Range("F14:O14").FormulaR1C1 = "=R[1]C*R[-2]C"
                Range(Cells(16, 3), Cells(行 + 2, 15)).Borders(xlInsideHorizontal).Weight = xlHairline
                Range("D3").Select
                Application.Calculation = xlAutomatic
                Application.Calculation = xlManual
                Range("E12:O" & 行).value = Range("E12:O" & 行).Value2
                Cells(8, 6).value = IIf(Bu = 3, "部門:", "部課:")
                Cells(8, 7).value = ListBox1.List(ii, 0) '部門または部課名
                DoEvents    '20081015 kon
                Range("C6:O" & Cells(2000, 3).End(xlUp).row).PrintOut
                DoEvents    '20081015 kon
                End If
                 
        End If
      End If

      Next ii
Else
'-------振込---------------------
    If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
    Application.Calculation = xlManual
    For ii = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(ii) = True Then '選択されていたら
            If Val(ListBox1.List(ii, 1)) <> 0 Then '人数が０でなければ
            Range("B15:L" & Cells(2000, 2).End(xlUp).row + 20).ClearContents '現データをクリア（多めに）
                n = 0
                With Worksheets(給賞 & "DATA") 'データを抽出する
                    For i = 0 To 1000
                        If .Cells(8 + i, 39).value = "" Then Exit For
                        If .Cells(8 + i, Bu).value = ii + 1 And .Cells(8 + i, 94).value > 0 Then
                            Cells(15 + n, 2).value = .Cells(8 + i, 39).value 'NO
                            Range(Cells(15 + n, 3), Cells(15 + n, 8)).FormulaR1C1 = "=if(VLOOKUP(RC2,KOZINDATA,R1C,0)=0,"""",VLOOKUP(RC2,KOZINDATA,R1C,0))"
                            Cells(15 + n, 9).value = .Cells(8 + i, 94).value '金額
                            Cells(15 + n, 5).value = IIf(Val(Cells(15 + n, 6).value) <> 0, "普通", "")
                            n = n + 1
                        End If
                        If .Cells(8 + i, Bu).value = ii + 1 And .Cells(8 + i, 95).value > 0 Then
                            Cells(15 + n, 2).value = .Cells(8 + i, 39).value 'NO
                            Cells(15 + n, 9).value = .Cells(8 + i, 95).value '金額
                            Range(Cells(15 + n, 7), Cells(15 + n, 8)).FormulaR1C1 = "=VLOOKUP(RC2,KOZINDATA,R1C,0)"
                            Cells(15 + n, 3).FormulaR1C1 = "=if(VLOOKUP(RC2,KOZINDATA,21,0)=0,"""",VLOOKUP(RC2,KOZINDATA,21,0))" '予備（銀行名)
                            Cells(15 + n, 4).FormulaR1C1 = "=if(VLOOKUP(RC2,KOZINDATA,89,0)=0,"""",VLOOKUP(RC2,KOZINDATA,89,0))" '予備5（支店名)
                            Cells(15 + n, 5).value = "普通"
                            Cells(15 + n, 6).FormulaR1C1 = "=if(VLOOKUP(RC2,KOZINDATA,90,0)=0,"""",VLOOKUP(RC2,KOZINDATA,90,0))" '予備（口座)
                            n = n + 1
                        End If
                    Next
                 End With
            Application.Calculation = xlAutomatic
            Application.Calculation = xlManual
            Cells(8, 9).value = "部門部課 : " & ListBox1.List(ii, 0)
            DoEvents    '20081015 kon
            Range(Cells(5, 2), Cells(Cells(1015, 9).End(xlUp).row, 12)).PrintOut
            DoEvents    '20081015 kon
            Cells(8, 9).value = ""
            End If
        End If
      Next ii
    Cells(8, 9).value = ""
    Range("B15:I" & Cells(2000, 2).End(xlUp).row + 5).value = Range("B15:I" & Cells(2000, 2).End(xlUp).row + 5).Value2
End If
Application.CutCopyMode = False
Cells(1, 1).Select
Application.Calculation = xlAutomatic
ActiveSheet.EnableSelection = xlUnlockedCells
ActiveSheet.Protect userinterfaceonly:=True
Application.ScreenUpdating = True
Unload Me
Exit Sub
ERR_ROUTIN:

    Dim msg As String
    
    If Err.Number = -2147018887 Then
        msg = "PDFファイルを保存できませんでした。" & vbCrLf & "同じ名前のPDFファイルが開いていないか確認してください。保存し直しますか?"
        
        If MsgBox(msg, vbRetryCancel + vbQuestion, "PDF作成") = vbRetry Then
            Resume
        Else
            Resume Next
        End If
    ElseIf Err.Number = 1004 Then
        msg = Err.Description & vbCrLf & "保存し直しますか?"
        
        If MsgBox(msg, vbRetryCancel + vbQuestion, "PDF作成") = vbRetry Then
            Resume
        Else
            Resume Next
        End If
    Else
        'エラーを再発生させる。
        Err.Raise Err.Number, Err.Source, Err.Description
    End If
End Sub
Private Sub 頁(n)
    Dim vData As Variant
    Dim vData2 As Variant
    Dim jCount As Long
    Dim iCount As Long

    vData = Range(Cells(208 + (n - 1) * p, 2), Cells(207 + n * p, 96)) '20121214　titti 配列にいれ、一部を60進法に変換
    If 給賞 = "給与" Then
        For iCount = 9 To 33
            For jCount = 1 To p
                If Worksheets("給与DATA").Cells(2, iCount + 1).value = True Then
                    If Val(vData(jCount, iCount)) <> 0 Then vData(jCount, iCount) = Zikan(vData(jCount, iCount))
                End If
            Next
        Next
    End If
    vData2 = Application.WorksheetFunction.Transpose(vData)
    Cells(10, 4).Resize(UBound(vData2, 1), UBound(vData2, 2)) = vData2

    If 給賞 = "給与" Then
        Range("CZ" & (208 + (n - 1) * p & ":CZ" & (207 + n * p))).Copy
        Range("D106").PasteSpecial Paste:=xlValues, Transpose:=True
        Range("CW" & (208 + (n - 1) * p & ":CW" & (207 + n * p))).Copy
        Range("D107").PasteSpecial Paste:=xlValues, Transpose:=True
        Range("DG" & (208 + (n - 1) * p & ":DH" & (207 + n * p))).Copy
        Range("D108").PasteSpecial Paste:=xlValues, Transpose:=True
    Else
        Range("CV" & (208 + (n - 1) * p & ":CX" & (207 + n * p))).Copy
        Range("D106").PasteSpecial Paste:=xlValues, Transpose:=True
        Range("DG" & (208 + (n - 1) * p & ":DG" & (207 + n * p))).Copy
        Range("D109").PasteSpecial Paste:=xlValues, Transpose:=True
    End If
    If Val(ListBox1.List(ii, 2)) = n Then '最終頁だったら計を表示
        
        vData = Range(Cells(206, 2), Cells(206, 96)) '20121214　titti 配列にいれ、一部を60進法に変換
        If 給賞 = "給与" Then
            For iCount = 9 To 33
                If Worksheets("給与DATA").Cells(2, iCount + 1).value = True Then
                    If Val(vData(1, iCount)) <> 0 Then vData(1, iCount) = Zikan(vData(1, iCount))
…