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 Const DEFINE_BASE As Long = 100
Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Set myobj = Nothing

End Sub
Private Sub Workbook_Open()

    If MNMode(True, False) Then Set myobj = New MyNumber

    If NeedDBVersionUp Then DBUP

End Sub
Private Function NeedDBVersionUp() As Boolean

    InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
    
    Dim rec As New ADODB.Recordset
    Dim size As Long
    
    rec.Open "Syslog", dbCon, adOpenStatic, adLockReadOnly
    size = rec.Fields("Summary").DefinedSize
    rec.Close
    dbCon.Close
    
    If size <> DEFINE_BASE Then
        NeedDBVersionUp = True
    Else
        NeedDBVersionUp = False
    End If

End Function
Private Sub DBUP()

    InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
    
    dbCon.Execute "Alter table syslog alter column Summary text(" & DEFINE_BASE & ")"
    dbCon.Execute "Alter table syslog alter column UpdateMachine text(" & DEFINE_BASE & ")"
    
    dbCon.Close

End Sub

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


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


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


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

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

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

Private Sub clsBTN_Click()   'インスタンスのClickイベント
    Dim Temp1 As Integer
    Dim Temp2 As Integer
    Dim j As Integer
    With カレンダー.SpinButton1
        Temp1 = (.Value - 1) \ 12 + 1
        Temp2 = (.Value - 1) Mod 12 + 1
    End With
    If カレンダー.Label9.Caption = "個人情報F" Then
        個人情報F.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
        If カレンダー.Label8.Caption = "Text15" Then
            Dim Myko As Integer
            Dim MyKu As Integer
            Myko = Val(個人情報F.ListBox1.Text) '個人情報の行番号
            MyKu = Val(個人情報F.LaKD.Caption) '給与データの行番号
            If MsgBox("この退社年月日を社保喪失日と雇保離職日にも登録しますか？", 4 + 32, "登録") = 6 Then
                With Worksheets("個人情報")
                        If IsDate(.Cells(Myko, 27).Value) Then
                            .Cells(Myko, 28).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption) + 1
                        End If
                        If IsDate(.Cells(Myko, 29).Value) Then
                            .Cells(Myko, 30).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
                        End If
                End With
                If MyKu > 0 Then
                    With Worksheets("給与データ")
                            If IsDate(.Cells(MyKu, 13).Value) Then
                                .Cells(MyKu, 14).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption) + 1
                            End If
                            
                            If IsDate(.Cells(MyKu, 15).Value) Then
                                .Cells(MyKu, 16).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
                            End If
                    End With
                End If
            End If
        End If
    ElseIf カレンダー.Label9.Caption = "一括有期F" Then
        一括有期F.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
    Else
        新規.Controls(カレンダー.Label8.Caption).Value = DateValue(Temp1 & "/" & Temp2 & "/" + clsBTN.Caption)
    End If
    DoEvents
    Unload カレンダー
End Sub

Attribute VB_Name = "Da保存読込"
Attribute VB_Base = "0{872AE6A3-E99E-4AC7-8158-63A23AB1AAB0}{3097F0D6-13E7-4937-91A6-3B3713669997}"
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 n As Integer
Dim ファイル名 As String
Dim ファイル区分 As String
Dim MyFile As String
Dim MyCheck As Boolean
Dim Kara As String
Private Sub CommandButton1_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, aaa
        Exit Sub
    End If
    
    ''' YBNO22983
    Dim buf As String
    Dim FileName As String
    
    buf = ActiveWorkbook.Name
    FileName = ListBox1.Value & ファイル区分
    ''' END YBNO22983
    
    Application.ScreenUpdating = False
    
    Workbooks.Open ActiveWorkbook.Path & "\Da保存\" & ListBox1.Value & ファイル区分
    On Error Resume Next '20110330　重　保存データをさらに保存する場合、da名が変更されている場合の対応（再度保存用のda名を代入する）
        If Kara = "Zi" Then 'daから読み込まれた処理ファイル
            Worksheets("Info").Cells(1, 1).Value = " " & ファイル区分
        End If
    On Error GoTo 0

    If Workbooks(ListBox1.Value & ファイル区分).BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open ThisWorkbook.Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu").Copy
        Workbooks(ListBox1.Value & ファイル区分).Activate
        Range("A1").Select
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu").Top = 1
        ActiveSheet.Shapes("Zu").Left = 100
        Range("A1").Select
        Workbooks(ListBox1.Value & ファイル区分).BuiltinDocumentProperties("Keywords").Value = 2010
        ActiveWorkbook.Save
        Workbooks("閉じるボタン.xls").Close False
    End If
    Unload Me
    ''' YBNO22983
    DoEvents
    Workbooks(buf).Activate
    DoEvents
    Workbooks(FileName).Activate
    DoEvents
    ''' END YBNO22983
    Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, aaa
        Exit Sub
    End If
    If MsgBox(ListBox1.Value & "を削除してもいいですか？", 1 + 32, "削除") <> 1 Then Exit Sub
    Kill ActiveWorkbook.Path & "\Da保存\" & ListBox1.Value & ファイル区分
    ListBox1.RemoveItem ListBox1.ListIndex
    MsgBox "削除しました", 64, aaa
End Sub
Private Sub CommandButton3_Click()
    Dim i As Integer
    If Trim(TextBox1.Value) = "" Then
        MsgBox "検索する文字列を入力して下さい。", 16, aaa
        Exit Sub
    End If
    Dim n As Integer
    If MyCheck = False Then
        n = 0
        Else
        n = ListBox1.ListIndex + 1 '現在選択されている位置の次のところ
    End If
    For i = n To ListBox1.ListCount - 1
        If ListBox1.List(i, 0) Like "*" & TextBox1.Value & "*" Then
            ListBox1.Selected(i) = True
            MyCheck = True
            Exit Sub
        End If
    Next
    MsgBox "見つかりません。", 64, aaa

End Sub
Private Sub TextBox1_Change()
    MyCheck = False
End Sub

Private Sub UserForm_Activate()
    Me.Caption = ActiveSheet.Name & "の保存データ読込"
    If Kara = "Zi" Then
    With Worksheets("DATA")
    ファイル区分 = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & " " & Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 4) & " " & ActiveSheet.Name & ".xls" '会社名＋様式名
    End With
    Else
    ファイル区分 = Left(MyFile, Len(MyFile) - 4) & " " & ActiveSheet.Name & ".xls" 'ブック名＋シート名で保存する
    End If
    ファイル名 = Dir(ActiveWorkbook.Path & "\Da保存\*" & ファイル区分)
    n = Len(ファイル区分) '書類名以外のファイル名の文字数
    Do While ファイル名 <> ""
        With ListBox1
            .AddItem Left(ファイル名, Len(ファイル名) - n)  '
            ファイル名 = Dir()
        End With
    Loop

End Sub

Private Sub UserForm_Initialize()
    On Error GoTo ErrorC
    MyFile = ActiveWorkbook.Name
    Kara = ""
    If Right(Worksheets("DATA").Cells(1, 1).Value, 6) = "da.xls" Then
        Kara = "Zi"
        End If
    Exit Sub
ErrorC:
End Sub


Attribute VB_Name = "KozinJouho"
Option Explicit

'*********20150511 kon マイナンバー
Public myobj As New MyNumber
Public RANGE_ARIA As String
'20151210 kon　扶養追加
'Public strMyNo(7) As String
Public strMyNo(11) As String
Public errorNo() As String
Public dic As Object           '20150515 KON マイナンバー

Public Const LIST_INPUT_FILENAME As String = "一覧入力.xlsm"
Public Const MSG_CELLS_DRIVE_NOT_READY As String = "Cellsドライブの設定がされていません。"
'*********end
Sub 個人情報へ()
    個人情報F.Show 0
End Sub
Sub 一括有期へ()
    Sheets("一括有期データ").Select
    
    'YBNO 28387  ito 20150728　IF文追加
    If Cells(4, 5).Value = "" Then
        'YBNO 28152  ito 20150723　文言表示 -------------------------------------------------------------------
        ActiveSheet.Unprotect
        Cells(4, 5).Select
        Cells(4, 5).Value = "※平成27年3月31日以前の事業は消費税を含めた請負金額、平成27年4月1日以降に開始した事業は消費税額を除く請負金額となっているか確認してください｡ "
        With Selection
            .HorizontalAlignment = xlGeneral
            .ShrinkToFit = False
        End With
        With Selection.Font
            .size = 9
        End With
        With ActiveCell.Characters(Start:=30, length:=19).Font
            .Color = -16776961
        End With
        With ActiveCell.Characters(Start:=49, length:=11).Font
            .Underline = xlUnderlineStyleSingle
        End With
        Cells(2, 3).Select
        ActiveSheet.Unprotect
        'YBNO 28152  ito 20150723　ここまで -------------------------------------------------------------------
    End If
    
    一括有期F.Show
End Sub
Sub 給与データの計()
    Dim i As Integer
    Dim n As Integer
    n = Cells(10000, 7).End(xlUp).Row + 2
    Application.Calculation = xlManual
    For i = 8 To n '横計（個人別）
        Cells(i, 33).Value = WorksheetFunction.Sum(Range(Cells(i, 17), Cells(i, 32)))
    Next
    For i = 17 To 33 '縦計（月別）
        Cells(6, i).Value = WorksheetFunction.Sum(Range(Cells(8, i), Cells(n, i)))
        Cells(5, i).Value = WorksheetFunction.count(Range(Cells(8, i), Cells(n, i)))
    Next
    Cells(5, 33).Value = WorksheetFunction.CountIf(Range(Cells(8, 33), Cells(n, 33)), ">0")
    Application.Calculation = xlAutomatic
End Sub
'20150407 kon マイナンバー
Sub Preview(pPath As String)
    Dim strPath As String
    Dim lngRet As Long
    Dim Manu As String
    
    lngRet = ShellExecute(0, "Open", pPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            MsgBox "ファイルを開くことができません。", 16, aaa
        Case ERROR_FILE_NOT_FOUND
            MsgBox "ファイルが見つかりません。", 16, aaa
    End Select
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報個別編集用)
'
'**********************************************************
Sub SetMyNumberK(ByRef dic As Object, gCnt As Long)
    Dim i As Long
    Dim buf As Variant
    Dim item As Object
    'Dim item As MyNumberItem
   
    With Worksheets("個人情報")
        For Each buf In .Range(RANGE_ARIA)
'20151125 kon 扶養家族
'            For i = 1 To 7
            For i = 1 To 11
                If .Cells(gCnt, 199 + i).Value = buf.Value Then
                    If dic.Exists(LCase(buf.Value)) Then
                        Set item = dic.item(LCase(buf.Value))
                        frmNo.Controls("TextBox" & i).Text = item.myno
                        
                        Exit For
                    End If
                End If
            Next
        Next
    End With
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報一覧編集用)
'
'**********************************************************
Sub SetMyNumberL(ByRef dic As Object, gCnt As Long)
    Dim i As Long
    Dim buf As Variant
    'Dim item As MyNumberItem
    Dim item As Object

    i = 1
    With Workbooks(Workbooks(LIST_INPUT_FILENAME).Worksheets("Data").Cells(1, 1).Value).Worksheets("個人情報")

        For Each buf In .Range(RANGE_ARIA)
'20151210  kon 扶養追加
'            For i = 1 To 7
            For i = 1 To 11
                If .Cells(gCnt, 199 + i).Value = buf.Value Then
                    If dic.Exists(LCase(buf.Value)) Then
                        Set item = dic.item(LCase(buf.Value))
                        strMyNo(i) = item.myno
                        
                    Else
                        strMyNo(i) = ""
                    End If
                    
'                    Exit For
                End If
            Next i
        Next buf
    End With
End Sub
'**********************************************************
'取得したマイナンバーを取り出す(個人情報表記用)
'
'**********************************************************
Sub SetMyNumber(ByRef dic As Object, gCnt As Long)
    Dim i As Long
    Dim buf As Variant

    i = 1
    With Worksheets("個人情報")
        'クリア
'20151125　kon 扶養家族
'        For i = 1 To 7
'taka 20151118 huyou
'        For i = 1 To 10
'            個人情報F.Controls("TextBox" & i + 65).Text = ""
'        Next i
    
        
'        For Each buf In .Range(RANGE_ARIA)
''20151125　kon 扶養家族
''            For i = 1 To 7
'            For i = 1 To 10
'                If .Cells(gCnt, 199 + i).Value = UCase(buf.Value) Then
'                    If dic.Exists(LCase(buf.Value)) Then
'                        個人情報F.Controls("TextBox" & i + 65).Text = "************"
'                    Else
'                        個人情報F.Controls("TextBox" & i + 65).Text = vbNullString
'                    End If
'                End If
'            Next i
'       Next
       
        i = 0
        For Each buf In .Range(RANGE_ARIA)
            If .Cells(gCnt, 200 + i).Value = UCase(buf.Value) Then
                If i = 0 Then
                    If dic Is Nothing Then
                        個人情報F.TextBox66.Text = vbNullString
                    Else
                        If dic.Exists(LCase(buf.Value)) Then
                            個人情報F.TextBox66.Text = "************"
                        Else
                            個人情報F.TextBox66.Text = vbNullString
                        End If
                    End If
                Else
                    If 個人情報F.Hlist.Selected(i - 1) = True Then
                        If .Cells(gCnt, 200 + i).Value = UCase(buf.Value) Then
                            If dic Is Nothing Then
                                個人情報F.TextBox67.Text = vbNullString
                            Else
                                If dic.Exists(LCase(buf.Value)) Then
                                    個人情報F.TextBox67.Text = "************"
                                Else
                                    個人情報F.TextBox67.Text = vbNullString
                                End If
                            End If
                            Exit For ' 選択した人が見つかった状態で終わらないと、Textboxの状態が維持されないので、他の人の情報が表示される。
                        End If
                    End If
                End If
            End If
            i = i + 1
       Next

       '-------------------------------------------------------------------------------------/
       
       
    End With
End Sub
'**********************************************************
'マイナンバーを有無
'
'**********************************************************
Function chkSetMyNumber(ByRef dic As Object, gCnt As Long, wb As String, RANGE_ARIA As String) As Boolean
    
    Dim i As Long
    Dim buf As Variant

    i = 1
    With Workbooks(wb).Worksheets("個人情報")
        For Each buf In .Range(RANGE_ARIA)
'20151125　kon 扶養家族
'            For i = 1 To 7
            For i = 1 To 11
                If .Cells(gCnt, 199 + i).Value = buf.Value Then
                    If dic.Exists(LCase(buf)) Then
                        chkSetMyNumber = True
                        Exit Function
                    End If
                End If
            Next i
       Next
    End With
    chkSetMyNumber = False
End Function
'*********20150511 kon マイナンバー
'取り出す
Sub SetDic(ByRef dic As Object, ByRef items() As Object)
'Sub SetDic(ByRef dic As Object, ByRef items() As MyNumberItem)

    Dim i As Long
    Dim buf As Variant
    Dim item As Object
    'Dim item As MyNumberItem
    Set item = CreateObject("Cells.MNApiLib.Data.MyNumberItem")
    
    dic.RemoveAll
    
    If Not Sgn(items) <> 0 Then Exit Sub
    For Each buf In items
        Set item = buf
        If item.Systemkey <> vbNullString Then
            dic.add LCase(item.Systemkey), item
        End If
    Next
End Sub
'20151214 kon 扶養追加
'Sub 個人番号一覧入力抽出(op1 As Boolean, op2 As Boolean, op4 As Boolean, da As String, mon As String, ck As Boolean)
Sub 個人番号一覧入力抽出(op1 As Boolean, op2 As Boolean, op4 As Boolean, op5 As Boolean, da As String, mon As String, ck As Boolean)
    Dim daName As String
    Dim i As Long
    Dim ii As Long
    Dim gNo As Long
    Dim dic As Object
    Dim items()  As Object
    'Dim items()  As MyNumberItem
    Dim ret As Boolean
    Dim hgNo As Range        '20151214 kon 扶養追加
    Dim hNo As Long        '20151214 kon 扶養追加
    Dim icnt As Long
    Dim rcnt As Long

'20151002 kon 28970
'    On Error Resume Next
'    InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
'    On Error GoTo 0

    'データをクリアする
    Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A3").Value = 1
    Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A2").Value = ""

    Application.ScreenUpdating = False
    gNo = Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(50000, 3).End(xlUp).Row + 20
'20151214 kon 扶養追加
'    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Range("B4:Y" & IIf(gNo > 4, gNo, 4)).ClearContents
    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Range("B4:AK" & IIf(gNo > 4, gNo, 4)).ClearContents
    
    gNo = Workbooks(LIST_INPUT_FILENAME).Worksheets("不一致").Cells(50000, 1).End(xlUp).Row
    Workbooks(LIST_INPUT_FILENAME).Worksheets("不一致").Range("A4:Y" & IIf(gNo > 3, gNo, 4)).ClearContents
    
    daName = Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Cells(1, 1).Value
    ii = 4
    With Workbooks(daName).Worksheets("個人情報")
        gNo = .Cells(50000, 2).End(xlUp).Row
        '20160125 kon 29973
'20160215 kon
        Workbooks(daName).Worksheets("扶養データ").Unprotect
        Workbooks(daName).Worksheets("扶養データ").Visible = True
        Workbooks(daName).Worksheets("扶養データ").Rows.Columns(1).Hidden = False
        
        For i = 6 To gNo
            DoEvents
            'Application.Run LIST_INPUT_FILENAME & "!pr", gNo, i #28996

            'マイナンバー未入力
            'けんぽＮＯ取得日があって喪失日がない
            If op1 = True Then
                If .Cells(i, 27).Value <> "" Then
                    If .Cells(i, 28).Value <> "" Then
                        Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                    End If
                Else
                   Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                End If
            '雇用保険取得日があって喪失日がない
            End If
            If op2 = True Then
                If .Cells(i, 29).Value <> "" Then
                    If .Cells(i, 30).Value <> "" Then
                        Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                    End If
                Else
                    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                End If
            End If
            '退職日
            If op4 = True Then
                If .Cells(i, 15).Value >= CDate(da) And .Cells(i, 15).Value <= DateAdd("m", Val(mon), da) Then
                    
                Else
                    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                End If
            End If
            '退職者以外 ’20151214 kon　29692
            
            If op5 = True Then
                If .Cells(i, 14).Value <> "" And .Cells(i, 15).Value = "" Then
                Else
                    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 2).Value = 1
                End If
            End If
        
        '********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー end
            '台帳NO　社員NO
            Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 3).Value = .Cells(i, 2)
            Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 4).Value = .Cells(i, 3)
            '本人　5,6
            Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 6).Value = .Cells(i, 5) & " " & .Cells(i, 6)
            Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 5).Value = .Cells(i, 200)
            
            Set hgNo = Workbooks(daName).Worksheets("扶養データ").Columns("A:A").Find(What:=.Cells(i, 200).Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not hgNo Is Nothing Then
                 hNo = hgNo.Row
                 rcnt = 1
                 For icnt = 4 To 202 Step 22
                    '扶養1　(配偶者)
                    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 6 + rcnt * 3).Value = Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt) & " " & Workbooks(daName).Worksheets("扶養データ").Cells(hNo, icnt + 1)
                    Workbooks(LIST_INPUT_FILENAME).Worksheets("一覧入力").Cells(ii, 5 + rcnt * 3).Value = .Cells(i, 200 + rcnt)
    
                    rcnt = rcnt + 1
                Next icnt
                 
            End If
            
            ii = ii + 1
次へ:

        Next i
        
        Erase strMyNo
'20151009 kon
'        RANGE_ARIA = "GR" & 4 & ":GX" & gNo
'taka 20151204 huyou
        RANGE_ARIA = "GR" & 6 & ":HB" & gNo
'20151214 kon 扶養追加
'        Dim hNo As Long
        
        ret = myobj.Reference(RangeToCollection(.Range(RANGE_ARIA)), items)
        
        If myobj.Authenticated Then
            '認証したので、ログを書く
            If ret Then
                '成功ログ
                Application.Run "cellsdrive.xlam!LogWrite", myobj, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(4, 2).Value, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(8, 2).Value, "一覧入力", "ログイン認証", "成功"
            Else
                '失敗ログ
                Application.Run "cellsdrive.xlam!LogWrite", myobj, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(4, 2).Value, Workbooks(Workbooks("一覧入力.xlsm").Worksheets("Data").Cells(1, 1).Value).Worksheets("会社情報").Cells(8, 2).Value, "一覧入力", "ログイン認証", "認証エラー"
                Application.Run "業務日誌.xlam!MessageBox", myobj.LastError
            End If
        End If
        
        If myobj.AccessRight = 0 Then
            MsgBox "機密取扱権限がありません。", vbInformation, "アクセス権限"
            Exit Sub
        End If
        
        If Not ret Then Exit Sub
        
        Set dic = CreateObject("Scripting.Dictionary")
        SetDic dic, items
        '#28996
        Dim frm As New ProgressBar
        Load frm
        frm.MaxValue = gNo - 5
        frm.Show vbModeless
        '#28966 END
        For i = 6 To gNo + 1 '#29173 20151021 ishikawa
             'DoEvents
            frm.Value = i - 5  '#28966
        '********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー
'20151009 kon
            If ck = True Then
            '20160210 kon 30248
                If Cells(ii, 7).Value <> "" Then
                    Cells(ii, 2).Value = 1
                Else
                    Cells(ii, 2).Value = ""
                End If
            Else
                If HshChk(daName, i, 2) = False Then
                    Exit Sub
                End If
            End If
        '20151211 kon 扶養追加
        
        Workbooks("一覧入力.xlsm").Activate
        '********************起動時取得した一覧からマイナンバーの存在確認 20150515 kon マイナンバー end
            '一致したGUIDのマイナンバーを表示
            SetMyNumberL dic, i
            '本人
            Cells(i - 2, 7).Value = strMyNo(1)
            '扶養1
            Cells(i - 2, 10).Value = strMyNo(2)
            '扶養2
            Cells(i - 2, 13).Value = strMyNo(3)
            '扶養3
            Cells(i - 2, 16).Value = strMyNo(4)
            '扶養4
            Cells(i - 2, 19).Value = strMyNo(5)
            '扶養5
            Cells(i - 2, 22).Value = strMyNo(6)
            '扶養6
            Cells(i - 2, 25).Value = strMyNo(7)
'20151214 kon 扶養追加
            '扶養7
            Cells(i - 2, 28).Value = strMyNo(8)
            '扶養8
            Cells(i - 2, 31).Value = strMyNo(9)
            '扶養9
            Cells(i - 2, 34).Value = strMyNo(10)
            '扶養10
            Cells(i - 2, 37).Value = strMyNo(11)
        
        
        ii = i - 2
        Next i
         '#28966
        Unload frm
        Set frm = Nothing
        'End #28966
        '条件外データ削除
'20160215 kon 30273
        For i = Cells(50000, 6).End(xlUp).Row To 4 Step -1

            DoEvents
            If Cells(i, 2).Value = 1 Then
                Rows(i & ":" & i).Select
                Selection.Delete Shift:=xlUp
            End If
        Next i

        
           'ログ
'20151021 kon
        On Error Resume Next
        InitDBObjectmy Replace(PathCombine(ThisWorkbook.Path & "\MNRelevance", "Syslog.accdb"), Workbooks("DaMenu.xls").Path & "\", ""), dbCon, DB_PROVIDER_ACE
        On Error GoTo 0
        For i = 4 To Range("C50000").End(xlUp).Row
            DoEvents
            
            Call Log_writeAll("マイナンバー閲覧", items, i)
        Next i
'20151021 kon
        dbCon.Close
        Set dbCon = Nothing

        '20160125 kon 29973
       Workbooks(daName).Activate
       Worksheets("MENU").Select
       Workbooks("一覧入力.xlsm").Activate
        
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    '#29193 ここで処理すると2016だとうまくうごかない
    If ii >= 4 Then
        MsgBox "抽出しました。", vbInformation, "個人番号一覧登録"
    Else
        MsgBox "抽出しましたが、該当者はありませんでした。", vbInformation, "個人番号一覧登録"
    End If
    Set dic = Nothing
    Application.Run LIST_INPUT_FILENAME & "!終了"

    
End Sub
'#29193
Public Sub MisMatch()

    frmMismatch.Show vbModal

End Sub
Function cName(Namae As String, Honnin As String)
    Dim Fname As Integer, Fno As Integer
    
    Fno = 0
    
    For Fname = 1 To Len(Honnin)
        If Mid(Honnin, Fname, 1) = "/" Then
            Fno = Fname
            Exit For
        End If
    Next
    If Fno = 0 Then
        If Honnin <> "" Then
            cName = Namae & " " & Honnin
        End If
    Else
        cName = Left(Honnin, Fno - 1) & " " & Mid(Honnin, Fno + 1, Len(Honnin))
    End If
End Function
Public Function 一覧更新() As Boolean
    
    Dim items()  As Object
    Dim ret As Boolean
    Dim icnt As Integer
    Dim rcnt As Long
    Dim gNo As Long
    Dim dic As Object
    Dim daName As String
    Dim rng As Range
    Dim str As String
   
    一覧更新 = False
   '20160207
    Dim ws As Worksheet, flag As Boolean
    For Each ws In Worksheets
        If ws.Name = "一覧入力" Then
            flag = True
            Exit For
        End If
    Next ws
    If flag <> True Then
       MsgBox "このブックからは個人番号を取り込むことができません。", vbInformation, "個人情報更新"
         Exit Function
    End If
   '20151004 kon
    If ActiveWorkbook.Worksheets("一覧入力").Range("A1").Value <> "cellsnyuryoku" Then
         MsgBox "このブックからは個人番号を取り込むことができません。", "個人情報更新", vbInformation
         Exit Function
    End If
    ' 20160125 kon YB30002
    daName = Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Cells(1, 1).Value '20151004 kon
    With ActiveWorkbook.Worksheets("一覧入力")
        gNo = .Cells(50000, 3).End(xlUp).Row
        Sheets("一覧入力").Unprotect
    
        For rcnt = 4 To gNo
            For icnt = 5 To 35 Step 3
    '20160216 kon
                If Workbooks("一覧入力.xlsm").Sheets("Data").Cells(1, 2).Value = "一覧入力.xlsm" Then
                    'もし、GUIDが未入力でマイナンバーが入力されていたら消す 20151004 kon
                    If .Cells(rcnt, icnt).Value = "" And .Cells(rcnt, icnt + 2) <> "" Then
                        .Cells(rcnt, icnt + 2).Value = ""
                    End If
                Else
                    '外部から取り込んだ入力表のマイナンバーが入力されていたらいなかったら何もしない20160216 kon
                    If .Cells(rcnt, icnt + 2) = "" Then
                        .Cells(rcnt, icnt).Value = ""
                    End If
                End If
                '入力済だったらＧＵＩＤ消す　20151020 kon
                If .Cells(rcnt, icnt + 2) = "************" Then
                    .Cells(rcnt, icnt).Value = ""
                End If
                If NoChk(.Cells(rcnt, icnt + 2).Value, 1) = False Then
                    .Cells(rcnt, icnt + 2).Select
                    MsgBox "該当者　" & .Cells(rcnt, icnt + 1) & "さん", vbInformation, "個人番号チェック"
                    Exit Function
                End If
            Next
        Next
    'データをクリアする
    Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A3").Value = 1
    Workbooks(LIST_INPUT_FILENAME).Sheets("Data").Range("A2").Value = ""
    Set dic = CreateObject("Scripting.Dictionary")
'チケットの有効確認は、登録したときのエラーの帰り値で確認
'有効切れだったら再度ログイン画面からやり直す
' 20160125 kon YB30002 移動
        gNo = .Cells(50000, 3).End(xlUp).Row
        If gNo < 4 Then
            MsgBox "登録データーが存在しません。", vbInformation, "一覧入力"
            Exit Function
        End If
        If MsgBox("更新には時間がかかります。よろしいですか？" & vbCr & "更新すると個人情報も保存されます。", vbOKCancel, "個人番号") = vbCancel Then
            Exit Function
        End If
        Application.Run LIST_INPUT_FILENAME & "!chlbl"
        Workbooks(daName).Sheets("個人情報").Visible = True
        Workbooks(daName).Sheets("個人情報").Columns("GR:HS").EntireColumn.Hidden = False
        Workbooks("一覧入力.xlsm").Sheets("一覧入力").Unprotect
        For icnt = 5 To 35 Step 3
            Workbooks("一覧入力.xlsm").Sheets("一覧入力").Columns(icnt).Hidden = True
        Next icnt
        Dim frm As New ProgressBar
        Load frm
        frm.MaxValue = gNo - 3
        frm.Show vbModeless
        For rcnt = 4 To gNo
            frm.Value = rcnt - 3
            For icnt = 5 To 35 Step 3
                If .Cells(rcnt, icnt).Value <> "" Then
                    dic.add .Cells(rcnt, icnt).Value, .Cells(rcnt, icnt + 2).Value
                   'マイナンバー空じゃなかったら
                    Set rng = Find(Workbooks(daName).Sheets("個人情報").Range("GR:HB"), .Cells(rcnt, icnt).Value)
                    If Not rng Is Nothing Then
        'みつかったら
                        Call CaluculateHash(rng.Row, rng.Column + 17, daName)
                        Workbooks(daName).Sheets("個人情報").Cells(rng.Row, rng.Column + 17).Value = CaluculateHash(rng.Row, rng.Column + 17, daName)
                        If .Cells(rcnt, icnt + 2).Value = "" Then
                            Workbooks(daName).Sheets("個人情報").Cells(rng.Row, rng.Column + 17).Value = ""
                        End If
                    End If
                End If
            Next
        Next
        '20160217　kon
        If dic.count = 0 Then
            MsgBox "取込みデータがありません。", vbInformation, "個人番号登録"
            Unload frm
            Set frm = Nothing
            Workbooks(daName).Sheets("個人情報").Columns("GR:HS").EntireColumn.Hidden = True
            Workbooks(daName).Sheets("個人情報").Visible = False
            Workbooks(daName).Sheets("扶養データ").Visible = False
            Workbooks(daName).Sheets("MENU").Activate
            Exit Function
        End If
        
        ret = myobj.Edit(dic, items)
        If ret = False Then
            Unload frm
            MsgBox myobj.LastError
            Exit Function
        End If
        Call Log_writeUp("マイナンバー更新", items, rcnt)
        dic.RemoveAll
        Unload frm
        Set frm = Nothing
    End With
    Set dic = Nothing
    Workbooks(daName).Sheets("個人情報").Columns("GR:HS").EntireColumn.Hidden = True
    Workbooks(daName).Sheets("個人情報").Visible = False
    Workbooks(daName).Sheets("扶養データ").Visible = False
    Workbooks(daName).Sheets("MENU").Activate
    Application.DisplayAlerts = False
    Workbooks(daName).Save
    Application.DisplayAlerts = True
'20160222 kon   30363
'    MsgBox "更新しました。" & vbCr & "個人番号を別ファイルから取り込んだ場合は再抽出をおこなってください。", vbInformation, "個人番号更新"
    MsgBox "更新しました。", vbInformation, "個人番号更新"

    一覧更新 = True

End Function
Private Function Find(ByRef rng As Range, ByVal SearchString As String) As Range

    Dim item As Variant
    
    For Each item In rng
        If item.Value = SearchString Then
            Set Find = item
            Exit Function
        End If
    Next

    Set Find = Nothing

End Function
'個人番号一覧入力
'Sub Log_write(gaiyo, ByRef items() As MyNumberItem, rcnt As Long)
Sub Log_write(gaiyo, ByRef items() As Object, rcnt As Long)
    
    Dim sql As String
    Dim rec As Object
    Dim MaxIdNo As Long
    Dim icnt As Long
    Dim cnt As Long
    Dim buf
    'Dim iitem As MyNumberItem
    Dim iitem As Object
    Dim str(7) As String
    Dim str_Time(7) As String
    
    For Each buf In items
    
       Set iitem = buf
       If iitem.Process <> vbNullString Then
           str(cnt) = iitem.Process
           str_Time(cnt) = iitem.ProcessDate
           cnt = cnt + 1
       Else
           str(cnt) = 0
           cnt = cnt + 1
       End If
       
    Next
    
    With Workbooks(LIST_INPUT_FILENAME)
…