Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "Module3"
Option Explicit

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 Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long

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 CloseHandle Lib "kernel32" (ByVal _
   hObject As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
'---

'メールオプション実行ファイル名
Public Const PDF_EXE As String = "CreatePDF.exe"
Public Const SEND_EXE As String = "KyuyoSmtp.exe"
Public Const SUBJECT_DATA As String = "メールの件名と本文.dat"
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
Public Function IsExist(ByVal path1 As String, Optional ByVal attr As VbFileAttribute = vbNormal) As Boolean

    Dim str As String
    
    str = Dir(path1, attr)

    If str = vbNullString Then
        IsExist = False
    Else
        IsExist = True
    End If

End Function
Public Function GetTextData(ByVal i As Integer, ByVal FileName As String) As String
  
    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName

    GetTextData = buffer(i - 1)

End Function
Public Sub GetStringArray(ByRef str() As String, ByVal FileName As String)

    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open FileName For Input As #FileNumber

        Do While Not EOF(FileNumber)
            'ファイルの長さで配列をデータを保持しながら初期化
            ReDim Preserve str(LineCount)
    
            'ファイルをバイナリで読み込んで配列に格納
            Line Input #FileNumber, str(LineCount)
            LineCount = LineCount + 1
        Loop
           
    Close #FileNumber

End Sub
'''
'''設定ファイルをMyToolの事業所フォルダ内に配置するので、そのファイル名を返す
'''
Public Function GetFolderName() As String

    Dim Folder As String
    Folder = Workbooks(Cells(1, 1).Value).Worksheets("基本項目").Cells(12, 3).Value 'Left(Cells(1, 1).value, Len(Cells(1, 1).value) - 6)
    
    'MyTool内にフォルダがない場合に作る
    If Dir(ThisWorkbook.Path & "\MyTool\" & Folder, vbDirectory) = vbNullString Then
        MkDir (ThisWorkbook.Path & "\MyTool\" & Folder)
    End If
       
    GetFolderName = Folder
    
End Function
'''
'''リストボックスが1つでも選択されていたらTrue
'''
Public Function IsSelectedListBox(ByRef lb As MSForms.ListBox) As Boolean
    
    Dim ret As Boolean
    Dim cnt As Integer
    ret = False
   
    For cnt = 0 To lb.ListCount - 1
        If lb.Selected(cnt) = True Then
            ret = True
            Exit For
        End If
    Next

    IsSelectedListBox = ret
End Function
'''
'''リストボックスの全てのアイテムの選択状態を設定する
'''
Public Sub SelectedAllListBox(ByRef lb As MSForms.ListBox, ByVal flg As Boolean)
    
    Dim cnt As Integer
   
    For cnt = 0 To lb.ListCount - 1
        lb.Selected(cnt) = flg
    Next

End Sub
'''
''' 文字列挿入
'''
Public Function InsertString(ByVal stTarget As String, ByVal iStart As Integer, ByVal stValue As String) As String
    
    InsertString = Left(stTarget, iStart) & stValue & Mid(stTarget, iStart + 1)
    
End Function
Public Function GetProgramFolder() As String
    Dim str As String
    
    str = PathCombine(Environ("ProgramFiles"), "cells\明細おとどけ君 for Cells給与")
    GetProgramFolder = str
    
'    str = "C:\Program Files\cells\明細おとどけ君 for Cells給与"
'    GetProgramFolder = str
End Function

'#35156 hara 20170317
Public Sub ShowWebMeisai()
    Dim wsh As Object, fso As Object, luText As Object
    Dim TextFilename As String
    Dim userNo As String
    Dim f As Long
    
    '--初期化処理---
    Set wsh = CreateObject("Wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    TextFilename = PathCombine(ThisWorkbook.Path, "lu.dat") 'LiveUpdateのファイル
    userNo = ""
    
    On Error GoTo Error 'エラーが起きた場合も管理画面に遷移する
    
    '--ユーザーNoを取得する処理--
    If fso.FileExists(TextFilename) Then
        f = FreeFile()
        Open TextFilename For Input As #f
        Do Until EOF(1)
            Input #f, userNo    '最終行のデータが末尾なので、最終的にユーザーNoが変数に入る
        Loop
        Close #f
    Else
        userNo = ""     'ユーザーNoが分からないので空欄
    End If
    
    '--管理画面に遷移する処理--
    If userNo = "" Then
        wsh.Run "https://meisai-sr.cells.jp/Login", 3
    Else
        wsh.Run "https://meisai-sr.cells.jp/Login?userno=" & userNo, 3
    End If
    
    '--メモリ開放処理--
    Set wsh = Nothing
    Set fso = Nothing
    Exit Sub
    
Error:
    wsh.Run "https://meisai-sr.cells.jp/Login", 3
    '--メモリ開放処理--
    Set wsh = Nothing
    Set fso = Nothing
End Sub
'#35156 end

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 = "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 = "Module1"
'************************
'修正履歴：
'************************
Option Explicit
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 Const AAA As String = "Web明細"
Public Const BBB As String = "送信設定"
Public Const OTODO As String = "この機能はオプション「Web明細機能」が必要です。"
Sub 初期処理()
    Dim kk As String
    Dim n As Integer
    Application.Calculation = xlCalculationManual
    kk = Cells(1, 1).Value
    If Dir(ThisWorkbook.Path & "\pdf", 16) = "" Then MkDir ThisWorkbook.Path & "\pdf" '初めての作成はフォルダを作る
    If Dir(ThisWorkbook.Path & "\pdf\" & Workbooks(kk).Worksheets("基本項目").Cells(12, 3).Value, 16) = "" Then MkDir ThisWorkbook.Path & "\pdf\" & Workbooks(kk).Worksheets("基本項目").Cells(12, 3).Value

    Cells(23, 1).Value = Workbooks(kk).Worksheets("基本項目").Cells(4, 3).Value '会社名
'    With Workbooks(kk).Worksheets("個人情報") 'アドレス情報をセット
'        n = .Cells(10000, 2).End(xlUp).Row
'        Worksheets("MailData").Range("A6:B" & n).Value = .Range("B6:C" & n).Value
'        Worksheets("MailData").Range("C6:E" & n).Value = .Range("CV6:CX" & n).Value
'    End With
End Sub
Sub 給与賞与データの読込()
    Dim kk As String
    Dim ks As String
    Dim i As Long
    kk = Cells(1, 1).Value
    ks = Cells(1, 2).Value

    Dim TextFilename As String
    Dim MyStr As String
    TextFilename = ThisWorkbook.Path & "\MyTool\PDFメール送信.dat" '明細設定をセット
    With Worksheets("明細")
        If Dir(TextFilename) <> "" Then
            Open TextFilename For Input As #1
                Input #1, MyStr
                    .Cells(2, 14).Value = CBool(MyStr)
                    
                Input #1, MyStr
                    .Cells(2, 15).Value = CBool(MyStr)
                Input #1, MyStr
                    .Cells(2, 16).Value = CBool(MyStr)
            Close #1
        Else
            .Cells(2, 14).Value = False '初期値
            .Cells(2, 15).Value = False
            .Cells(2, 16).Value = False
        End If
    End With
    Sheets("明細").Select
   
    With Workbooks(kk).Worksheets("基本項目")
        Cells(8, 9).Value = IIf(ks = "賞与", .Cells(11, 25).Value, .Cells(8, 25).Value) 'おしらせ
        Cells(30, 2).Value = .Cells(4, 3).Value '会社名
        Cells(69, 3).Value = .Cells(5, 26).Value    '課税累計の表示(1はしない）
        Cells(69, 5).Value = .Cells(55, 3).Value   '日給時間給の単価表示（するはTRUE)
        Cells(65, 11).Value = .Cells(56, 3).Value   '有給残の表示(するはFALSE)
    End With
    If ks = "給与" Then
        With Workbooks(kk).Worksheets("給与入力")
            Cells(87, 7).Value = .Cells(1, 11).Value '勤怠の60進法表示
            Range("C89:K89").Value = .Range("L1:T1").Value
            Cells(87, 9).Value = .Cells(1, 21).Value
            Cells(87, 8).Value = .Cells(1, 47).Value
            Cells(87, 10).Value = .Cells(1, 48).Value
            Cells(91, 6).Value = .Cells(1, 49).Value
            Cells(91, 7).Value = .Cells(1, 50).Value
        End With
    End If
    With Workbooks(kk) '給与DATAをセット
        .Worksheets(ks & "DATA").Cells.Copy
        Worksheets("DATA").Cells.PasteSpecial Paste:=xlPasteValues
        .Worksheets(ks & "支給控除").Range("B14:B104").Copy
        Worksheets("DATA").Range("F1").PasteSpecial Paste:=xlPasteValues, Transpose:=True '項目表示をセット
    End With
    With Worksheets("DATA")
        '手当控除項目をセット
        Range(Cells(50, 3), Cells(50, 11)).Value = .Range(.Cells(7, 41), .Cells(7, 49)).Value
        Range(Cells(52, 3), Cells(52, 11)).Value = .Range(.Cells(7, 50), .Cells(7, 58)).Value
        Range(Cells(54, 3), Cells(54, 7)).Value = .Range(.Cells(7, 59), .Cells(7, 63)).Value
        Range(Cells(54, 9), Cells(54, 11)).Value = .Range(.Cells(7, 64), .Cells(7, 66)).Value
        Range(Cells(57, 3), Cells(57, 11)).Value = .Range(.Cells(7, 67), .Cells(7, 75)).Value
        Range(Cells(59, 3), Cells(59, 11)).Value = .Range(.Cells(7, 76), .Cells(7, 84)).Value
        Range(Cells(61, 3), Cells(61, 7)).Value = .Range(.Cells(7, 85), .Cells(7, 89)).Value
        Range(Cells(61, 9), Cells(61, 11)).Value = .Range(.Cells(7, 90), .Cells(7, 92)).Value
        Range(Cells(64, 3), Cells(64, 7)).Value = .Range(.Cells(7, 6), .Cells(7, 10)).Value
        Cells(64, 9).Value = .Cells(7, 20).Value
        Cells(64, 8).Value = .Cells(7, 31).Value
        Cells(64, 10).Value = .Cells(7, 32).Value
        Cells(68, 6).Value = .Cells(7, 33).Value
        Cells(68, 7).Value = .Cells(7, 34).Value
        
        Range(Cells(66, 3), Cells(66, 11)).Value = .Range(.Cells(7, 11), .Cells(7, 19)).Value
        Range(Cells(68, 8), Cells(68, 10)).Value = .Range(.Cells(7, 94), .Cells(7, 96)).Value
        Cells(68, 11).Value = .Cells(7, 93).Value
        '値がゼロの場合の項目表示をセット
        Range(Cells(51, 3), Cells(51, 11)).Value = .Range(.Cells(1, 41), .Cells(1, 49)).Value
        Range(Cells(53, 3), Cells(53, 11)).Value = .Range(.Cells(1, 50), .Cells(1, 58)).Value
        Range(Cells(55, 3), Cells(55, 7)).Value = .Range(.Cells(1, 59), .Cells(1, 63)).Value
        Range(Cells(55, 9), Cells(55, 11)).Value = .Range(.Cells(1, 64), .Cells(1, 66)).Value
        Range(Cells(58, 3), Cells(58, 11)).Value = .Range(.Cells(1, 67), .Cells(1, 75)).Value
        Range(Cells(60, 3), Cells(60, 11)).Value = .Range(.Cells(1, 76), .Cells(1, 84)).Value
        Range(Cells(62, 3), Cells(62, 7)).Value = .Range(.Cells(1, 85), .Cells(1, 89)).Value
        Range(Cells(62, 9), Cells(62, 11)).Value = .Range(.Cells(1, 90), .Cells(1, 92)).Value
        Range(Cells(65, 3), Cells(65, 7)).Value = .Range(.Cells(1, 6), .Cells(1, 10)).Value
        Cells(65, 9).Value = .Cells(1, 20).Value
        Cells(65, 8).Value = .Cells(1, 31).Value
        Cells(65, 10).Value = .Cells(1, 32).Value
        Cells(69, 6).Value = .Cells(1, 33).Value
        Cells(69, 7).Value = .Cells(1, 34).Value
        
        
        Range(Cells(67, 3), Cells(67, 11)).Value = .Range(.Cells(1, 11), .Cells(1, 19)).Value
        Range(Cells(69, 8), Cells(69, 10)).Value = .Range(.Cells(1, 94), .Cells(1, 96)).Value
        Cells(69, 11).Value = .Cells(1, 93).Value
    
    End With
    Sheets("DATA").Select
    
    Cells(7, 101).Value = "税扶養人数" 'テキストファイルの項目名に使用
    Cells(7, 111).Value = "課税累計額"
    Cells(7, 104).Value = "日時給単価"
    Cells(1, 1).Select
    Sheets("Text").Select
    
    Range("A9:F100").ClearContents '前のデータをクリア
    Dim n As Integer
    n = 9
    'テキストファイルの項目
    '勤怠
    With Worksheets("DATA")
        If ks = "給与" Then '賞与は勤怠はないのでやらない
            For i = 6 To 20 '20130513
                If .Cells(6, i).Value <> 0 Then
                    Cells(n, 1).Value = i '合計がある項目の列番号を置く
                    n = n + 1
                End If
            Next
            For i = 31 To 34 '20130513 新項目
                If .Cells(6, i).Value <> 0 Then
                    Cells(n, 1).Value = i '合計がある項目の列番号を置く
                    n = n + 1
                End If
            Next
            Cells(n, 1).Value = 0 '境界線を引く
            n = n + 1
        End If
        
        
        
        '支給項目
        For i = 41 To 96
            If i = 67 Then '手当と控除の境界線
                Cells(n, 1).Value = 0 '境界線を引く
                n = n + 1
            End If
            If ks = "給与" Then
                If i <> 91 Then '控除計は置かない
                    If (i >= 67 And i <= 69) Or (i >= 71 And i <= 74) Or i = 64 Or i = 65 Or .Cells(6, i).Value <> 0 Then '課税計と非課税計、合計があればセット
                        Cells(n, 1).Value = i '合計がある項目の列番号を置く
                        n = n + 1
                    End If
                End If
             Else
                If i <> 91 Or i <> 64 Or i <> 65 Then '課税計と非課税計,控除計は置かない
                    If (i >= 67 And i <= 69) Or (i >= 71 And i <= 74) Or i = 61 Or i = 62 Or i = 87 Or i = 88 Or .Cells(6, i).Value <> 0 Then '61,62,87,88は適当、空欄を設定（賞与はバランスが悪いので）
                        Cells(n, 1).Value = i '合計がある項目の列番号を置く
                        n = n + 1
                    End If
                End If
            End If
        Next

    Cells(n, 1).Value = 0 '境界線を引く
    n = n + 1
    End With
    With Worksheets("明細")
        If .Cells(69, 3).Value <> 1 Then '課税累計額
            Cells(n, 1).Value = 111
            n = n + 1
        End If
        If ks = "給与" Then
            If .Cells(65, 11).Value <> True Then '有給残日数
                Cells(n, 1).Value = 112
                n = n + 1
            End If
        End If
        If .Cells(2, 15).Value <> True Then    '税扶養人数
            Cells(n, 1).Value = 101
            n = n + 1
        End If
        If ks = "給与" Then
            If Worksheets("明細").Cells(69, 5).Value <> False Then   '基本給単価
                Cells(n, 1).Value = 104
                n = n + 1
            End If
        End If
    End With
    n = Cells(10000, 1).End(xlUp).Row
    Range("B9:B" & n).FormulaR1C1 = _
        "=IF(RC1>0,""|""&LEFTB(INDIRECT(""DATA!R7C""&RC1,0),10)&REPT("" "",10-LENB(LEFTB(INDIRECT(""DATA!R7C""&RC1,0),10))),""|----------"")"
    Range("C9:C" & Cells(10000, 1).End(xlUp).Row).FormulaR1C1 = _
        "=REPT("" "",8-LENB(TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),IF(RC[-2]<41,""0.00#"",""0""))))&TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),IF(RC[-2]<41,""0.00#"",""0""))&""|"""
    For i = 9 To n
        If Cells(i, 1).Value = 0 Then Cells(i, 3).Value = "--------|"
        If Cells(i, 1).Value = 104 Then '基本給単価
            Cells(i, 3).FormulaR1C1 = "=IF(INDIRECT(""DATA!R""&R1C1&""C99"",0)>1,REPT("" "",8-LENB(INDIRECT(""DATA!R""&R1C1&""C104"",0)))&INDIRECT(""DATA!R""&R1C1&""C104"",0),""        "")&""|"""
        End If
        If Cells(i, 1).Value = 112 And Worksheets("明細").Cells(65, 11).Value = "TRUE" Then '有給残日数(マイナスは非表示）
            Cells(i, 3).FormulaR1C1 = _
            "=REPT("" "",8-LENB(TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),""0.00#"")))&TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),""0.00#"")&""|"""
        End If
        If Cells(i, 1).Value = 101 Then  '税扶養人数（99は乙欄）
            Cells(i, 3).FormulaR1C1 = _
            "=IF(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0)=99,""    乙欄|"",REPT("" "",8-LENB(TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),""0;;"")))&TEXT(INDIRECT(""DATA!R""&R1C1&""C""&RC1,0),""0;;"")&""|"")"
        End If
    Next
    n = n + 1
    Cells(n, 2).Value = "+----------" '最後の境界線
    Cells(n, 3).Value = "--------+"

    Cells(n + 2, 2).FormulaR1C1 = "=IF(LEN(R[1]C)>1,""おしらせ"","""")"
    Cells(n + 3, 2).FormulaR1C1 = "=TEXT(INDIRECT(""DATA!R""&R1C1&""C109"",0),""#"")" '20121217　titti
    Cells(n + 4, 2).Value = "END"
    Range("D3:D" & n + 4).FormulaR1C1 = "=RC[-2]&RC[-1]"
    
    Sheets("MENU").Select
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Worksheets("Text").Range("B9:B" & n).Value = Worksheets("Text").Range("B9:B" & n).Value
End Sub
Sub 給与作成()
    If Cells(1, 2).Value = "源泉" Then
        MsgBox "源泉徴収票はすでに作成されています。次の作成ファイルで確認してください。", 64, AAA
        Exit Sub
    End If
    If Cells(1, 2).Value = "賞与" Then
        With 給与
            .cb3.Visible = False
            .cb5.Visible = False
 
        End With
    End If
    給与.Show
End Sub

Sub MEMUへ()
Sheets("MENU").Select
End Sub
Sub 明細へ()
Sheets("明細").Select
End Sub
Sub HELPへ()
Sheets("HELP").Select
End Sub
Sub マニュアルへ()
Dim URL As String, rc
    URL = "https://www.cells.co.jp/webmeisai/manual"
    rc = ShellExecute(0, "Open", URL, "", "", 1)
End Sub
'
'Sub 作成()
'    Dim kk As String
'    If Cells(9, 5).value = "" Then
'    ElseIf Cells(9, 5).value = Cells(9, 2).value Then
'        If MsgBox("当月分はすでに作成されています。追加して作成または変更しますか？", 4 + 48, "追加処理") <> 6 Then Exit Sub
'    Else
'        If MsgBox("「" & Cells(9, 5).value & "」データを削除してから実行します。よろしいですか？", 4 + 48, "新規作成") <> 6 Then Exit Sub
'        kk = Worksheets("明細").Cells(1, 12).value
'        kk = Workbooks(kk).Worksheets("基本項目").Cells(12, 3).Value
'        Kill ThisWorkbook.path & "\pdf\" & kk & "\*.*" 'すべて削除
'        Cells(9, 5).value = "" '○月分を削除
'    End If
'    '選択.Show
'End Sub
Sub リンク()
    ThisWorkbook.FollowHyperlink Address:="http://get.adobe.com/jp/reader/"
End Sub
Sub 印刷へ()
If MsgBox("プリンタの準備はいいですか？", 4 + 32, "印刷") <> 6 Then Exit Sub
'20090908 kon
DoEvents
ActiveSheet.PrintOut
'20090908 kon
DoEvents

End Sub

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit


Attribute VB_Name = "給与"
Attribute VB_Base = "0{27AC6F82-7180-4484-8CD2-B8C78F556E8D}{9635B14A-0F8D-435E-BCD7-EA344FFEE332}"
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 kk As String
Dim ks As String
Dim flg As Boolean
Private Sub CheckBox1_Click()
    Dim i As Integer
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = CheckBox1.Value
    Next
End Sub
'Private Sub CheckBox2_Click()
'    Dim i As Integer
'    For i = 0 To ListBox1.ListCount - 1
'        If Trim(ListBox1.List(i, 2)) <> "" Then
'            ListBox1.Selected(i) = CheckBox2.Value
'        Else
'            ListBox1.Selected(i) = IIf(CheckBox2.Value = True, False, True)
'        End If
'    Next
'End Sub




Private Sub CommandButton4_Click()
    Dim iCnt As Long
    
    Application.Calculation = xlCalculationManual


'    With Worksheets("明細")
'        .Cells(2, 14).Value = CheckBox3.Value
'        .Cells(2, 15).Value = CheckBox4.Value
'        .Cells(2, 16).Value = CheckBox5.Value
'    End With
    Dim TextFilename As String
    
    If Dir(ThisWorkbook.Path & "\Web明細", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\Web明細")
    End If
    
    If Dir(ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value, vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value)
    End If
    
    TextFilename = ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value & "\作成設定.dat"
    
    Open TextFilename For Output As #1
'20160413 kon
'    For iCnt = 1 To 9
    For iCnt = 1 To 10
        Write #1, IIf(Controls("cb" & iCnt).Value = True, 1, 0)
    Next iCnt
    
    Close #1
    
    Dim buf  As String
        
    Open TextFilename For Input As #1
    iCnt = 1
    Do Until EOF(1)
        Line Input #1, buf
        
        If buf = 1 Then
            Controls("cb" & iCnt).Value = True
        Else
            Controls("cb" & iCnt).Value = False
        End If
        
        Worksheets("DATA").Cells(1, iCnt).Value = buf
        iCnt = iCnt + 1
    Loop
    Close #1
            
    
    MsgBox "登録しました。", 64, AAA
    Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub CommandButton5_Click()
    Dim i As Integer
    Dim n As Integer
    Dim フォルダ As String
    Dim Nengetu As String
    Dim TextFilename As String
    
       
    If IsSelectedListBox(Me.ListBox1) = False Then
        MsgBox "作成する社員が選択されていません。", 16, AAA
        Exit Sub
    End If
    
'    If Left(ks, 1) = "源" Then
'        Nengetu = Format(Date, "yyyymm") '作成年月
'    ElseIf Left(ks, 1) = "賞" Then
'        Nengetu = Format(Worksheets("DATA").Cells(5, 2).value, "yyyymm") '支払い年月日
'    Else
'        Nengetu = Format(Worksheets("DATA").Cells(5, 2).value, "yyyymm") '支払い年月日
'    End If
'    フォルダ = Workbooks(kk).Worksheets("基本項目").Cells(12, 3).value
'    With Workbooks(kk).Worksheets(ks & "DATA")
'        For i = 0 To ListBox1.ListCount - 1
'            If ListBox1.Selected(i) = True Then
'                If .Cells(i + 8, 110).value = vbNullString Then
'                    MsgBox "No." & ListBox1.List(i, 0) & ListBox1.List(i, 1) & "のアドレスが登録されていません。", 16, AAA
'                    Exit Sub
'                End If
'                If Trim(Workbooks(kk).Worksheets("個人情報").Cells(.Cells(i + 8, 110), 100).value) = "" Then
'                    MsgBox "No." & ListBox1.List(i, 0) & ListBox1.List(i, 1) & "のアドレスが登録されていません。", 16, AAA
'                    Exit Sub
'                End If
'            End If
'        Next
'    End With
    
    If MsgBox("作成しますか？", 4 + 32, AAA) <> 6 Then Exit Sub
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationAutomatic
    Label2.Caption = "作成中・・・"
    DoEvents
    
    
    Dim Path As String
    
    If Dir(ThisWorkbook.Path & "\Web明細", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\Web明細")
    End If

    If Dir(ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value, vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value)
    End If
'20150525 kon YB27800
'    Path = ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value & "\" & Format(Now, "YYYYMMDD") & "MEISAIDATA.CSV"
    Path = ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value & "\" & Cells(1, 2).Value & Format(Now, "YYYYMMDDhhmmss") & "MEISAIDATA.CSV"
   
    
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            flg = True
            Exit For
        End If
    Next i
    
    
    If flg = True Then
        Open Path For Output As #1
        'ヘッダ設定
        
        Dim linData As String
        Dim SheetName As String
        SheetName = "DATA"
        With Worksheets(SheetName)
            'ヘッダー
            '1項目目は固定
            '2項目目は出力したソフト名
            '3項目目はバージョン値
            '4項目目はWeb明細データ作成
            '5項目目は帳票種類、給与の場合は1、賞与の場合は2
            '6項目目はYYYY
            '7項目目はMM
            '8項目名はYYYYMMDD（支払日）
            '9項目名は作成日時YYYYMMDDHHSS
            
            linData = "CellsSoftWaerOutPutCsv" & ","  '1 刻印
            linData = linData & "Cells給与,"   '2 ソフト名
            
            Application.EnableEvents = False
            Workbooks.Open FileName:=ActiveWorkbook.Path & "\バージョン情報.xls"
            linData = linData & IIf(.Cells(1, 2).Value = 0, Cells(1, 2).Text, "") & ","     '3 バージョン値
            Workbooks("バージョン情報.xls").Close
            Application.EnableEvents = True
            
            linData = linData & ThisWorkbook.Name & ","     '4 作成ファイル
            
            If Worksheets("MENU").Cells(19, 2).Value Like "給与*" Then
                linData = linData & 1 & ","   '5帳票種類
                linData = linData & Format(Left(.Cells(5, 4).Text, Len(.Cells(5, 4).Text) - 1), "YYYY") & "," '6支給年
                linData = linData & Format(Left(.Cells(5, 4).Text, Len(.Cells(5, 4).Text) - 1), "MM") & "," '7支給月
            Else
                linData = linData & 2 & ","
                linData = linData & Format(.Cells(5, 2).Value, "YYYY") & ","  '6支給年
                linData = linData & Format(.Cells(5, 2).Value, "MM") & ","  '7支給月
            End If
            
            linData = linData & Format(.Cells(5, 2).Value, "YYYYMMDD") & ","          '8支払日
            linData = linData & Format(Now(), "YYYY/MM/DD hh:nn:ss")         '9作成日時
        End With
        
        Print #1, linData

        
        
    End If
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Label2.Caption = ListBox1.List(i, 1) & " の作成中"
            DoEvents
''''''''作成
            Worksheets("明細").Cells(5, 1).Value = i + 7
            Call 作成(i)
        End If
    Next
    
   If flg = True Then
        Close #1
        Path = ThisWorkbook.Path & "\Web明細\" & Worksheets("MENU").Cells(23, 1).Value & "\Member.dat"
        Open Path For Output As #1
        For i = 0 To ListBox1.ListCount - 1
            
            If ListBox1.Selected(i) = True Then
                Print #1, ListBox1.List(i, 0)
            End If
            
        Next i
        Close #1
    End If
    
    
    Label2.Caption = "変換中・・・"
    Me.Repaint

    Application.ScreenUpdating = True
    Dim hProcess As Long
    Dim lret As Long
    Dim param As Integer
    
    If Left(ks, 1) = "賞" Then
        param = 2 '給与は1、賞与は2
    Else
        param = 1 '給与は1、賞与は2
    End If
    
    '-------------------------------------
    MsgBox "給与データを作成しました。", 64, AAA
    Unload Me
    Application.ScreenUpdating = True
End Sub
Private Sub 作成(iRcnt)

    '明細からPDFに必要なデータをテキストにする
    
    Dim linData As String
    
    Dim SheetName As String
    SheetName = "DATA"
    
    With Worksheets(SheetName)
        Dim iCounter As Integer '列
        Dim jCounter As Integer '行
        Dim hCounter As Integer 'ヘッダー行
        Dim Bcd     As String '部門部課CD
        Dim Bnm     As String '部門部課名
        
        '内容欄
        
        hCounter = 7
        iCounter = iRcnt + 8
        
        linData = ""
        For jCounter = 2 To 112
            Select Case jCounter
            Case 2
                linData = linData & IIf(.Cells(iCounter, jCounter).Value = "", ",", .Cells(hCounter, jCounter).Value & "," & """" & Format(.Cells(iCounter, jCounter).Value, "000000") & """")
            Case 39
                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Text = "", "" & "," & "", .Cells(hCounter, jCounter).Text & "" & "," & "" & Format(.Cells(iCounter, jCounter).Text, "000000"))
            
            '部門コード
            Case 3
                
                If .Cells(hCounter, jCounter).Value > 0 Then
                    Bcd = IIf(.Cells(1, 6).Value = 0, .Cells(iCounter, jCounter).Value, "")
                    Bnm = IIf(.Cells(1, 7).Value = 0, Workbooks(kk).Worksheets("基本項目").Cells(.Cells(iCounter, jCounter).Value + 4, 20).Value, "")
                Else
                    Bcd = ""
                    Bnm = ""
                End If
'20180817 kon YB33319
'                If Bcd = "" Then
'                    If Bnm = "" Then

                If Bcd = "" Or Bcd = "0" Then
                    If Bnm = "" Or Bnm = "部門" Then
                        linData = linData & "," & ","
                    Else
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & Bnm
                    End If
                Else
                    If Bnm = "" Then
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & " " & Bcd
                    Else
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & " " & Bcd & " " & Bnm
                    End If
                End If
 
            '部課コード
            Case 4
                If .Cells(hCounter, jCounter).Value > 0 Then
                    Bcd = IIf(.Cells(1, 8).Value = 0, .Cells(iCounter, jCounter).Value, "")
                    Bnm = IIf(.Cells(1, 9).Value = 0, Workbooks(kk).Worksheets("基本項目").Cells(.Cells(iCounter, jCounter).Value + 4, 23).Value, "")
                Else
                    Bcd = ""
                    Bnm = ""
                End If
'20180817 kon YB33319
'                If Bcd = "" Then
'                    If Bnm = "" Then
                If Bcd = "" Or Bcd = "0" Then
                    If Bnm = "" Or Bnm = "部課" Then

                        linData = linData & "," & ","
                    Else
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & Bnm
                    End If
                Else
                    If Bnm = "" Then
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & " " & Bcd
                    Else
                        linData = linData & "," & .Cells(hCounter, jCounter).Value & ", " & " " & Bcd & " " & Bnm
                    End If
                End If
            
            
            '扶養人数
            Case 101
'                linData = linData & "," & IIf(.Cells(hCounter, jCounter).Value = 0, ",", IIf(.Cells(1, jCounter).Value = 1 And .Cells(iCounter, jCounter).Value = 0, ",", .Cells(hCounter, jCounter).Value & "," & """" & IIf(.Cells(iCounter, jCounter).Value = 99, "乙欄", .Cells(iCounter, jCounter).Value) & """"))
                linData = linData & "," & IIf(.Cells(1, 10).Value = 0, IIf(.Cells(hCounter, jCounter).Value = 0, ",", IIf(.Cells(1, jCounter).Value = 1 And .Cells(iCounter, jCounter).Value = 0, ",", .Cells(hCounter, jCounter).Value & "," & """" & IIf(.Cells(iCounter, jCounter).Value = 99, "乙欄", .Cells(iCounter, jCounter).Value) & """")), ",")
            '基本給単価
            Case 104
                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Value = 0, ",", IIf(.Cells(1, 5).Value = 1, ",", IIf(.Cells(iCounter, 99).Value = 1, ",", .Cells(hCounter, jCounter).Value & "," & """" & Format(.Cells(iCounter, jCounter).Value, "#,###") & """")))
            '課税累計額
            Case 111
                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Value = 0, ",", IIf(.Cells(1, 4).Value = 1, ",", .Cells(hCounter, jCounter).Value & "," & """" & Format(.Cells(iCounter, jCounter).Value, "#,###") & """"))
            '有給残日数
            Case 112
'20150415 kon #27564
'                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Value = 0, ",", IIf(.Cells(1, 3).Value = 1, ",", .Cells(hCounter, jCounter).Value & "," & """" & Format(.Cells(iCounter, jCounter).Value, "#,###") & """"))
                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Value = 0, ",", IIf(.Cells(1, 3).Value = 1, ",", .Cells(hCounter, jCounter).Value & "," & """" & .Cells(iCounter, jCounter).Value & """"))
            Case Is >= 41
                linData = linData & "," & IIf(.Cells(hCounter, jCounter).Value = 0, ",", IIf(.Cells(1, jCounter).Value = 1 And .Cells(iCounter, jCounter).Value = 0, ",", .Cells(hCounter, jCounter).Value & "," & """" & Format(.Cells(iCounter, jCounter).Value, "###,###") & """"))
            Case Else
                linData = linData & "," & IIf(.Cells(iCounter, jCounter).Text = "", "" & "," & "", .Cells(hCounter, jCounter).Text & "" & "," & "" & .Cells(iCounter, jCounter).Text)
            End Select

        Next jCounter
        
        linData = linData & "," & .Cells(5, 4).Text    '支給年月分
        linData = linData & "," & IIf(.Cells(1, 2).Value = 0, .Cells(5, 6).Text, "")     '支給期間
        linData = linData & "," & Cells(23, 1).Text     '会社名

        If Worksheets("MENU").Cells(19, 2).Value Like "給与*" Then
            linData = linData & "," & Workbooks(kk).Worksheets("基本項目").Cells(8, 25).Value & ""  '文言
        Else
            linData = linData & "," & Workbooks(kk).Worksheets("基本項目").Cells(11, 25).Value & ""   '文言
        End If

        linData = linData & "," & IIf(.Cells(1, 1).Value = 0, Format(.Cells(5, 2).Value, "gggee年mm月dd日"), "") & "" '支給年月日
        linData = linData & "," & IIf(Worksheets("MENU").Cells(19, 2).Value Like "給与*", 1, 2)      '給与区分
        
        Print #1, linData
        
    End With
End Sub
Private Sub SetData(ByVal hCounter As Integer, ByVal jCounter As Integer, ByVal fn As Integer, ByVal SheetName As String)
    
    Dim iCounter As Integer
    
    With Worksheets(SheetName)
    
        For iCounter = 3 To 11
            '金額が発生しない場合は項目名も表示しない
            Print #fn, IIf(.Cells(jCounter, iCounter).Text = "", "" & vbTab & "", .Cells(hCounter, iCounter).Text & vbTab & .Cells(jCounter, iCounter).Text)
        Next iCounter
    
    End With
    
End Sub
Private Sub CommandButton5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    If Shift = 3 Then
        flg = Not flg
    End If

End Sub

Private Sub CommandButton6_Click()
    Dim iCnt As Long
    Dim i As Long
    
    iCnt = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
           iCnt = iCnt + 1
        End If
    Next
    
    If iCnt = 0 Then
        MsgBox "リストを選択してください。", vbInformation, "同意書印刷"
        Exit Sub
    End If
    
    Workbooks.Open FileName:=ActiveWorkbook.Path & "\書式集\Web同意書.xls"
    
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Label2.Caption = ListBox1.List(i, 1) & " の作成中"
            DoEvents
            '社名
            Cells(38, 2).Value = ThisWorkbook.Sheets("MENU").Cells(23, 1).Value
            '氏名
            Cells(43, 7).Value = ThisWorkbook.Sheets("DATA").Cells(i + 8, 5).Value
            ActiveWorkbook.PrintOut
                    
        End If
    Next
    
    Application.DisplayAlerts = False
    Workbooks("Web同意書.xls").Close
    Application.DisplayAlerts = True
End Sub

Private Sub CommandButton7_Click()
    Workbooks.Open FileName:=ActiveWorkbook.Path & "\書式集\Web同意書.xls"
…