Malicious Office (OLE) — malware analysis report

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

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    MsgBox "このファイルは保存できません。", 16, "保存"
    Cancel = True
End Sub

Attribute VB_Name = "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

Private Sub Worksheet_Change(ByVal Target As Range)

    With ThisWorkbook.Worksheets("DATA")
        If Intersect(Target, Range("I8:J8,B10:M10,P10:AD10,B12:M12,P12:AD12,B14:W14,B16,O16:W16,F18:AC18,B20:AD20,F22:AD22,F23:AD23,F24:AD24,F25:AD25")) Is Nothing Then
            Exit Sub
        Else
            Select Case Target.Address
                Case "$I$8", "$I$8:$J$8"
                    .Cells(1, 6).Value = Cells(8, 9).Value
                Case "$B$10", "$B$10:$M$10"
                    .Cells(2, 6).Value = Cells(10, 2).Value
                Case "$P$10", "$P$10:$AD$10"
                    .Cells(3, 6).Value = Cells(10, 16).Value
                Case "$B$12", "$B$12:$M$12"
                    .Cells(4, 6).Value = Cells(12, 2).Value
                Case "$P$12", "$P$12:$AD$12"
                    .Cells(5, 6).Value = Cells(12, 16).Value
                Case "$B$14", "$B$14:$W$14"
                    .Cells(6, 6).Value = Cells(14, 2).Value
                Case "$B$16"
                    .Cells(7, 6).Value = Cells(16, 2).Value
                Case "$O$16", "$O$16:$W$16"
                    .Cells(8, 6).Value = Cells(16, 15).Value
                Case "$F$18", "$F$18:$AC$18"
                    .Cells(9, 6).Value = Cells(18, 6).Value
                Case "$B$20", "$B$20:$AD$20"
                    .Cells(10, 6).Value = Cells(20, 2).Value
                Case "$F$22", "$F$22:$AD$22"
                    .Cells(11, 6).Value = Cells(22, 6).Value
                Case "$F$23", "$F$23:$AD$23"
                    .Cells(12, 6).Value = Cells(23, 6).Value
                Case "$F$24", "$F$24:$AD$24"
                    .Cells(13, 6).Value = Cells(24, 6).Value
                Case "$F$25", "$F$25:$AD$25"
                    .Cells(14, 6).Value = Cells(25, 6).Value
            End Select
        End If
    End With
End Sub


Attribute VB_Name = "Module1"
Option Explicit
Private Const FILENAME_EGOV_TARGET As String = "eGov\番号登録届.xlsm"
Public Const PROC_NAME As String = "個人番号登録変更届出書"
Sub 初期処理()
    Dim i As Integer
    Dim TextFilename As String
    Dim MyData(0) As String
        i = 1
        TextFilename = ThisWorkbook.Path & "\MyTool\ZimukumiaiJoho.dat" '組合
        Open TextFilename For Input As #1
            Do Until EOF(1)
                Input #1, MyData(0)
                Worksheets("DATA").Cells(i, 2).Value = MyData(0)
                i = i + 1
            Loop
        Close #1
End Sub
Sub 個人選択へ()
    kojin.Show
End Sub
Sub 終了()
    ThisWorkbook.Close False
End Sub
Sub 電子()

    Dim wb As Workbook
        
    '既に開いているかどうか調べる
    For Each wb In Workbooks
        If wb.Name = FILENAME_EGOV_TARGET Then
            '開いていたので終わる
            DoEvents
            wb.Activate
            Exit Sub
        End If
    Next wb
        
    Application.Run "DaAddin.xla!OpenWorkbookActive", ThisWorkbook.Path & "\" & FILENAME_EGOV_TARGET
            
    Worksheets("DATA").Cells(1, 1).Value = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Text
    
    Application.Run ActiveWorkbook.Name & "!初期処理"
    
End Sub
Sub 印刷()
    frmPrint.Show 0
End Sub
Sub 保存()
    hozon.Show
End Sub
Sub 読込()
    yomi.Show
End Sub
Sub 事業主()
    With Workbooks(Worksheets("DATA").Cells(1, 1).Value).Worksheets("会社情報")
        Cells(22, 6).Value = .Cells(10, 2).Value
        Cells(23, 6).Value = .Cells(8, 2).Value
        Cells(24, 6).Value = .Cells(11, 2).Value & "　" & .Cells(12, 2).Value
        Cells(25, 6).Value = .Cells(13, 2).Value
    End With
End Sub
Sub 事務組合()
    With Worksheets("DATA")
        Cells(22, 6).Value = .Cells(2, 2).Value
        Cells(23, 6).Value = .Cells(3, 2).Value
        Cells(24, 6).Value = .Cells(4, 2).Value & "　" & .Cells(5, 2).Value
        Cells(25, 6).Value = .Cells(6, 2).Value
    End With
End Sub
Sub 非表示()
    Dim i As Integer
    For i = 22 To 25
        Cells(i, 6).Value = ""
    Next
End Sub

'YBNO 29721  ito 20160203　マニュアル追加
Sub OpenManual()
Application.Run "DaAddin.xla!OpenManual"
End Sub

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 = "kojin"
Attribute VB_Base = "0{4DD7E2F0-5C7C-4A3F-9398-86103A9B7EA4}{FE01AAFC-F7AC-4ADA-B07E-DDA9E1A0FE6F}"
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 comFile As String
Dim cnt As Long, n As Long

Private Sub CommandButton1_Click()
    Dim MyD As Variant
    Dim i As Long, n As Long
    
    With Workbooks(comFile).Worksheets("個人情報")
    
    'YBNO 30033  ito 20160209
    'If ListBox1.ListIndex = -1 then
    If ListBox1.ListIndex = -1 And Worksheets("DATA").Cells(6, 6).Value = "" Then
        MsgBox "対象者を選択して下さい。", vbCritical, "個人選択"
        Exit Sub
    End If
    '#30229
    If TextBox2.Text <> vbNullString And TextBox1.Text = vbNullString Then
        MsgBox "変更前個人番号を入力する際は、個人番号欄も入力してください。", vbInformation + vbOKOnly, "個人選択"
        Exit Sub
    End If
    
    If TextBox1.Text <> vbNullString Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            If Not Application.Run("DaAddin.xla!CallLogin", PROC_NAME, Workbooks(comFile).Worksheets("会社情報")) Then Exit Sub
        End If
    End If
    
    Application.Calculation = xlCalculationManual
    
    MyD = Worksheets("DATA").Range("F1:F17")
    
    If ListBox1.ListIndex <> -1 Then    'YBNO 30033  ito 20160209　追加
    
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then
            
                MyD(1, 1) = ComboBox1.Value
                MyD(2, 1) = TextBox1.Value
                MyD(3, 1) = TextBox2.Value
                MyD(4, 1) = .Cells(ListBox1.List(i, 0), 26).Value
                MyD(5, 1) = TextBox4.Value
                MyD(6, 1) = .Cells(ListBox1.List(i, 0), 7).Value & " " & .Cells(ListBox1.List(i, 0), 8).Value
                MyD(7, 1) = .Cells(ListBox1.List(i, 0), 9).Value
                MyD(8, 1) = .Cells(ListBox1.List(i, 0), 13).Value
                MyD(9, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(8, 2).Value
                MyD(10, 1) = TextBox3.Value
                MyD(11, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(10, 2).Value
                MyD(12, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(8, 2).Value
                'YBNO 30280  ito 20160216
                'MyD(13, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(11, 2).Value & " " & Workbooks(comFile).Worksheets("会社情報").Cells(12, 2).Value
                MyD(13, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(11, 2).Value & "　" & Workbooks(comFile).Worksheets("会社情報").Cells(12, 2).Value
                MyD(14, 1) = Workbooks(comFile).Worksheets("会社情報").Cells(13, 2).Value
                MyD(15, 1) = TextBox5.Value
                MyD(16, 1) = TextBox6.Value
                MyD(17, 1) = TextBox7.Value
                
            End If
        Next
        
    'YBNO 30033  ito 20160209　追加　---------
    Else
        MyD(1, 1) = ComboBox1.Value
        MyD(2, 1) = TextBox1.Value
        MyD(3, 1) = TextBox2.Value
        MyD(5, 1) = TextBox4.Value
        MyD(10, 1) = TextBox3.Value
        MyD(15, 1) = TextBox5.Value
        MyD(16, 1) = TextBox6.Value
        MyD(17, 1) = TextBox7.Value
    End If
    'YBNO 30033  ito 20160209　ここまで　----
    
    Worksheets("DATA").Range("F1:F17") = MyD
    
    '数式を戻す
    Columns("AX:CB").Copy
    Columns("A:AE").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Cells(10, 2).Select
    
    'YBNO 30033  ito 20160209　保存データ用GUID追加　----------------------------------------------------------------------------
    If ListBox1.ListIndex <> -1 Then
        Sheets("DATA").Cells(10, 1).Value = Workbooks(comFile).Worksheets("個人情報").Cells(ListBox1.List(ListBox1.ListIndex, 0), 200).Value
    End If
    'YBNO 30033  ito 20160209　ここまで　----------------------------------------------------------------------------------------
    
    Application.Calculation = xlCalculationAutomatic
    Range(Cells(8, 2), Cells(25, 30)).Value = Range(Cells(8, 2), Cells(25, 30)).Value2
    
    MsgBox "OK", vbInformation, "個人選択"
    
    '個人番号があるときにログを作る
    '---------------------------------------------
    If TextBox1.Text <> vbNullString Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            Dim guid As String
            guid = Worksheets("DATA").Cells(10, 1).Value
        
            Dim ComAccount As String
            ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(comFile))
        
            Application.Run "DaAddin.xla!ProcLogging", ComAccount, PROC_NAME, "データ作成", vbNullString, guid, StrConv(Worksheets("DATA").Cells(6, 6).Value, vbWide), "成功"
        End If
    End If
    '---------------------------------------------
    
    Unload Me
    
    End With
End Sub

'認証・取得ボタン
Private Sub CommandButton2_Click()

    Dim guid As String
    
    If ListBox1.ListIndex <> -1 Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            guid = Workbooks(comFile).Worksheets("個人情報").Cells(ListBox1.List(ListBox1.ListIndex, 0), 200).Value
            TextBox1.Text = Application.Run("DaAddin.xla!GetMyno", guid, Workbooks(comFile).Worksheets("会社情報"), PROC_NAME)
        End If
    'YBNO 30033  ito 20160209　追加　---------------------------------------
    Else  '保存データ読込時
        If Sheets("DATA").Cells(10, 1).Value <> "" Then
            If Application.Run("DaAddin.xla!MNMode", True, False) Then
                guid = Sheets("DATA").Cells(10, 1).Value
                TextBox1.Text = Application.Run("DaAddin.xla!GetMyno", guid, Workbooks(comFile).Worksheets("会社情報"), PROC_NAME)
            End If
        End If
    'YBNO 30033  ito 20160209　ここまで　-----------------------------------
    End If
    
End Sub

Private Sub OptionButton1_Click()

    n = 0
    ListBox1.Clear
    
    '個人情報をセット
    With Workbooks(comFile).Worksheets("個人情報")
        For cnt = 6 To .Cells(Rows.Count, 2).End(xlUp).Row
            ListBox1.AddItem cnt
            ListBox1.List(n, 0) = cnt
            ListBox1.List(n, 1) = .Cells(cnt, 5).Value & "　" & .Cells(cnt, 6).Value
            n = n + 1
        Next cnt
    End With
    
End Sub

Private Sub OptionButton2_Click()

    n = 0
    ListBox1.Clear
    
    '個人情報をセット
    With Workbooks(comFile).Worksheets("個人情報")
        For cnt = 6 To .Cells(Rows.Count, 2).End(xlUp).Row
            If (.Cells(cnt, 14).Value <> "") And (.Cells(cnt, 15) = "") Then
                ListBox1.AddItem cnt
                ListBox1.List(n, 0) = cnt
                ListBox1.List(n, 1) = .Cells(cnt, 5).Value & "　" & .Cells(cnt, 6).Value
                n = n + 1
            End If
        Next cnt
    End With
    
End Sub

Private Sub OptionButton3_Click()

    n = 0
    ListBox1.Clear
    
    '個人情報をセット
    With Workbooks(comFile).Worksheets("個人情報")
        For cnt = 6 To .Cells(Rows.Count, 2).End(xlUp).Row
            If .Cells(cnt, 15) <> "" Then
                ListBox1.AddItem cnt
                ListBox1.List(n, 0) = cnt
                ListBox1.List(n, 1) = .Cells(cnt, 5).Value & "　" & .Cells(cnt, 6).Value
                n = n + 1
            End If
        Next cnt
    End With
    
End Sub

Private Sub UserForm_Initialize()

    comFile = Worksheets("DATA").Cells(1, 1).Value
    OptionButton2.Value = True
    ComboBox1.AddItem 1
    ComboBox1.AddItem 2
    ComboBox1.List(0, 1) = "新規"
    ComboBox1.List(1, 1) = "変更"
    
    Dim NowDate As Date
    NowDate = Now
    TextBox5.Text = Year(NowDate) - 1988
    TextBox6.Text = Month(NowDate)
    TextBox7.Text = Day(NowDate)
    
    'YBNO 30033  ito 20160209　追加　-------------------
    Dim MyD As Variant
    MyD = Worksheets("DATA").Range("F1:F17")
        ComboBox1.Value = MyD(1, 1)
        TextBox4.Value = MyD(5, 1)
        TextBox3.Value = MyD(10, 1)
    Worksheets("DATA").Range("F1:F17") = MyD
    'YBNO 30033  ito 20160209　ここまで　---------------
    
End Sub

Attribute VB_Name = "frmPrint"
Attribute VB_Base = "0{0FCDECC3-A32A-4A85-83EC-FB3B6E23B87E}{1DA5310C-A5A6-4DF0-86B0-200057A3BEF9}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit
Private Sub CommandButton1_Click()

    If CanPrint Then
        If (ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 2).Text <> vbNullString Or ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text <> vbNullString) And Application.Run("DaAddin.xla!MNMode", True, False) Then
            If Not Application.Run("DaAddin.xla!CallLogin", PROC_NAME, Workbooks(Worksheets("DATA").Cells(1, 1).Value).Worksheets("会社情報")) Then Exit Sub
        End If
    Else
        Exit Sub
    End If

'    If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 2).Text <> vbNullString And _
'        ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text <> vbNullString Then
'        If Application.Run("DaAddin.xla!MNMode", True, False) Then
'            If Not Application.Run("DaAddin.xla!CallLogin", PROC_NAME, Workbooks(Worksheets("DATA").Cells(1, 1).Value).Worksheets("会社情報")) Then Exit Sub
'        End If
'    Else
'        Exit Sub
'    End If


'印字設定追加
    Dim FSO As Object
    Dim j As Integer
    Dim intFF As Integer            ' FreeFile値
    Dim setString(2) As Double
    Dim strREC As String            ' 読み込んだレコード内容
    
    If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf")
    End If
    If Dir(ThisWorkbook.Path & "\pdf\個人番号登録変更届出書", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf\個人番号登録変更届出書")
    End If
    
    
    If Dir(hName, vbNormal) = "" Then
        Open hName For Append As #1
            Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
            Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
        Close #1
        
    Else
        Open hName For Output As #1
            Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
            Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
        Close #1
    End If
    
'データのみ印刷の場合はfalse
    If CheckBox1 = True Then
        pFg = False
    Else
        pFg = True
    End If
    
'ハローワーク名を印刷する場合はtrue
    hFg = CheckBox2.Value
'事業所を印刷する場合はtrue
    jFg = CheckBox3.Value
    
    With Workbooks("個人番号登録変更届出書.xls").Worksheets("DATA")
        .Cells(18, 6).Value = Workbooks(ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value).Worksheets("会社情報").Cells(83, 2).Text '職安
        .Cells(19, 6).Value = TextBox7.Value '提出代行
        .Cells(20, 6).Value = TextBox6.Value '作成日
        .Cells(21, 6).Value = ComboBox1.Value '社会保険労務士記入欄
        .Cells(22, 6).Value = TextBox4.Value '氏名
        .Cells(23, 6).Value = TextBox5.Value '電話番号
    End With
    
    '余白設定の読込
    If Dir(hName, vbNormal) <> "" Then
        j = 0
        intFF = FreeFile
        Open hName For Input As intFF
        Do Until EOF(intFF)
            Line Input #intFF, strREC
            setString(j) = IIf(Trim(strREC) = "", 0, strREC)
            j = j + 1
        Loop
        Close #1
    
        Tmargin = setString(0) '上余白
        Lmargin = setString(1) '左余白
    
    End If

    '個人番号があるときにログを作る
    '---------------------------------------------
    If CanPrint Then
        If (ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 2).Text <> vbNullString Or ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text <> vbNullString) And Application.Run("DaAddin.xla!MNMode", True, False) Then
            Dim guid As String
            guid = Worksheets("DATA").Cells(10, 1).Value
        
            Dim ComAccount As String
            ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(ThisWorkbook.Worksheets("data").Cells(1, 1).Value))
        
            Application.Run "DaAddin.xla!ProcLogging", ComAccount, PROC_NAME, "印刷", vbNullString, guid, StrConv(Worksheets("DATA").Cells(6, 6).Value, vbWide), "成功"
        End If
    End If
    '---------------------------------------------

    Unload Me
    CreatePDF
End Sub
Private Function CanPrint() As Boolean

    CanPrint = False

    If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(8, 9).Text = "1" Then
        If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 2).Text <> vbNullString Then
            If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text = vbNullString Then
                CanPrint = True
            Else
                MsgBox "新規の場合は、変更前個人番号欄は、空白にしてください。", vbInformation + vbOKOnly, PROC_NAME
            End If
        Else
            If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text = vbNullString Then
                CanPrint = True
            Else
                MsgBox "新規の場合は、変更前個人番号欄は、空白にしてください。", vbInformation + vbOKOnly, PROC_NAME
            End If
        End If
    End If

    If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(8, 9).Text = "2" Then
        If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 2).Text <> vbNullString Then
            If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text <> vbNullString Then
                CanPrint = True
            Else
                MsgBox "変更の場合は、変更前個人番号欄に、番号を入力してください。", vbInformation + vbOKOnly, PROC_NAME
            End If
        Else
            If ThisWorkbook.Worksheets("個人番号登録・変更届出書").Cells(10, 16).Text = vbNullString Then
                CanPrint = True
            Else
                MsgBox "変更の場合は、個人番号欄に、番号を入力してください。", vbInformation + vbOKOnly, PROC_NAME
            End If
        End If
    End If

End Function
Private Sub CommandButton2_Click()
    cFg = True
    Unload Me
End Sub

Private Sub CommandButton3_Click()
    OpenFile ("個人番号登録変更届裏201601.pdf")
    cFg = True
    Unload Me
End Sub

Private Sub CommandButton4_Click()
    Dim myBookName2 As String
    
    ActiveSheet.Unprotect
    huki = 1
    myBookName2 = ActiveWorkbook.Name
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\第17条付記.xls"
    Workbooks(myBookName2).Activate
    Application.Run "第17条付記.xls!HUKIPDF"

End Sub

Private Sub CommandButton5_Click()
    If MsgBox("このデータをクリアしますか？", 4 + 32, "クリア") <> 6 Then Exit Sub
    TextBox4.Value = ""
    TextBox5.Value = ""
    TextBox6.Value = ""
    TextBox7.Value = ""
    ComboBox1.Value = ""
End Sub

Private Sub UserForm_Initialize()

    cFg = False

    ComboBox1.AddItem ""
    ComboBox1.AddItem Format(Date, "GE.M.D")
    ComboBox1.AddItem "提出代行者"
    ComboBox1.AddItem "事務代理者"
    ComboBox1.Text = "提出代行者"
    TextBox7.Text = Workbooks("DaMenu.xls").Worksheets("標準報酬月額").Cells(162, 12).Value

    With Workbooks("DaMenu.xls").Worksheets("標準報酬月額")
        TextBox4.Value = .Cells(154, 7).Value
        TextBox5.Value = .Cells(155, 7).Value
    End With
    CheckBox2.Value = True
    CheckBox3.Value = True
'印字設定追加
    '余白設定のファイル名
    
    TextBox6.Text = Format(Date, "GE.M.D")
    
    hName = ThisWorkbook.Path & "\pdf\個人番号登録変更届出書\myno.txt"
    
    Dim j As Integer
    Dim intFF As Integer            ' FreeFile値
    Dim setString(2) As Double
    Dim strREC As String            ' 読み込んだレコード内容
    
    For j = 0 To 9
        TxtTop.AddItem j
        TxtLeft.AddItem j
    Next j
    
    If Dir(hName, vbNormal) <> "" Then
        j = 0
        intFF = FreeFile
        Open hName For Input As intFF
        Do Until EOF(intFF)
            Line Input #intFF, strREC
            setString(j) = IIf(Trim(strREC) = "", 0, strREC)
            j = j + 1
        Loop
        Close #1
    
        TxtTop.Value = setString(0) * 10 '上余白
        TxtLeft.Value = setString(1) * 10 '左余白
    Else
        TxtTop.Value = 0 '上余白
        TxtLeft.Value = 0 '左余白
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
'        MsgBox "キャンセルボタンでキャンセルしてください。", vbInformation, "雇用保険資格取得"
        Cancel = True
    End If

End Sub

Attribute VB_Name = "hozon"
Attribute VB_Base = "0{52F39B36-E6DE-4199-9530-1394A4C3B384}{BA836FB3-362A-4D33-8D49-D14F680AF54B}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Private Sub UserForm_Initialize()
        TextBox1.Value = Cells(14, 2).Value & " " & Format(Now, "YYYYMMDD作成")
End Sub
Private Sub CommandButton1_Click()
    Dim da As String, Fda As String, Fdb As String, MyP As String
    Dim 保存ファイル名 As String
    Dim aw As String, fName As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    aw = ActiveWorkbook.Name
    fName = ActiveSheet.Name
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4) 'daをフォルダ名にする
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) '処理ファイルをフォルダ名にする
    
    '\DaProcess\台帳名\処理ファイル名\シート名　フォルダに保存する
    If Dir(ThisWorkbook.Path & "\Da保存", 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存"
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb
    If Dir(ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name, 16) = "" Then MkDir ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name & "\" & TextBox1.Value & ".xls"

    保存ファイル名 = TextBox1.Value & ".xls"
    If 保存ファイル名 = Dir(MyP) Then     'すでにあるかチェック
        If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, "保存") <> 1 Then
            MsgBox "処理を中止します。", 64, "保存"
            Exit Sub
        End If
    End If
    
    Application.Calculation = xlCalculationManual
    ThisWorkbook.Worksheets("DATA").Activate
    ActiveSheet.Copy
    ActiveSheet.Unprotect
    Cells.Copy
    Cells.PasteSpecial Paste:=xlPasteValues
    Range("F2", "F3").ClearContents '保存時マイナンバークリア
    Application.Calculation = xlCalculationAutomatic
    Application.CutCopyMode = False
    Cells(1, 1).Select
    
    If CSng(Application.Version) > 11 = True Then
        ActiveWorkbook.SaveAs MyP, FileFormat:=56 '2007以上
    Else
        ActiveWorkbook.SaveAs MyP '2003
    End If
    ActiveWorkbook.Close False
      
    Workbooks(aw).Worksheets(fName).Activate
    Cells(1, 1).Select
    MsgBox "保存しました。", 64, "保存"
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Unload Me
End Sub

Attribute VB_Name = "yomi"
Attribute VB_Base = "0{F23F4842-B856-4F1F-9041-3F63E5E0A7F8}{93784BF0-22D8-4F04-AA79-B628BD303BDB}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Dim MyP As String
Dim MyCheck As Boolean
    
Private Sub CommandButton1_Click()
    Dim i As Long
    Dim n As Long
    Dim s As String
    Dim fName As String
    Dim Wh As Worksheet
    fName = ActiveSheet.Name
    
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, "読込"
        Exit Sub
    End If
    If MsgBox("保存データをこのファイルに読み込みます。処理中のデータは上書きされます。よろしいですか？", 1 + 32, "読込") <> 1 Then Exit Sub
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Workbooks.Open MyP & "\" & ListBox1.Value & ".xls"
    
    Set Wh = ThisWorkbook.Sheets("DATA")
    Wh.Range(Wh.Cells(1, 1), Wh.Cells(100, 20)).Value = Range(Cells(1, 1), Cells(100, 20)).Value
    Set Wh = Nothing

    Workbooks(ListBox1.Value & ".xls").Close False
    ThisWorkbook.Activate
    Sheets(fName).Select
    
    '数式を戻す
    Columns("AX:CB").Copy
    Columns("A:AE").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Cells(10, 2).Select
    
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    Range(Cells(8, 2), Cells(25, 30)).Value = Range(Cells(8, 2), Cells(25, 30)).Value2
    
    Unload Me
    MsgBox "OK", 64, "読込"
    
End Sub

Private Sub CommandButton2_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "ファイルが選択されていません", 16, "削除"
        Exit Sub
    End If
    If MsgBox(ListBox1.Value & "を削除してもいいですか？", 1 + 32, "削除") <> 1 Then Exit Sub
    Kill MyP & "\" & ListBox1.Value & ".xls"
    ListBox1.RemoveItem ListBox1.ListIndex
    MsgBox "削除しました", 64, "削除"
End Sub

Private Sub CommandButton3_Click()
    Dim i As Integer
    If Trim(TextBox1.Value) = "" Then
        MsgBox "検索する文字列を入力して下さい。", 16, "検索"
        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, "検索"
End Sub
Private Sub TextBox1_Change()
    MyCheck = False
End Sub

Private Sub UserForm_Initialize()
    
    Dim da As String, Fda As String, Fdb As String, Fn As String
    Dim n As Long
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Me.Caption = ActiveSheet.Name & "の保存データ読込"
    n = 0
    da = Worksheets("DATA").Cells(1, 1).Value
    Fda = Left(da, Len(da) - 4)
    Fdb = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    MyP = ThisWorkbook.Path & "\Da保存\" & Fda & "\" & Fdb & "\" & ActiveSheet.Name
    Fn = Dir(MyP & "\*.*")
    Do While Fn <> ""
        With ListBox1
            .AddItem Left(Fn, Len(Fn) - 4)
            .List(n, 1) = FSO.GetFile(MyP & "\" & Fn).DateLastModified '最終更新日時
            n = n + 1
            Fn = Dir()
        End With
    Loop
    Set FSO = Nothing
End Sub

Attribute VB_Name = "Module2"
Option Explicit
Public pFg      As Boolean
Public hFg      As Boolean
Public jFg      As Boolean
Public cFg       As Boolean
Public Tmargin As Double
Public Lmargin As Double
Public hName As String
Public huki As Integer

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 CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long
   
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long
   
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
   hObject As Long) As Long
   
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Public Sub CreatePDF()

    Dim fnam As String
        
    If cFg = True Then
        MsgBox "印刷はキャンセルされました。", vbInformation, "個人番号登録変更届出書"
        Exit Sub
    End If
    
    Dim MSG As Integer

        If Len(Cells(10, 2).Value) > 12 Then
            MSG = MsgBox("個人番号が表示範囲を超えています。12桁まで表示します。よろしいですか？", vbYesNo + vbQuestion, "個人番号登録変更届出書")
            If MSG = vbNo Then
                Exit Sub
            End If
        End If
        If Len(Cells(10, 16).Value) > 12 Then
            MSG = MsgBox("変更前個人番号が表示範囲を超えています。12桁まで表示します。よろしいですか？", vbYesNo + vbQuestion, "個人番号登録変更届出書")
            If MSG = vbNo Then
                Exit Sub
            End If
        End If
        If Len(Cells(12, 2).Value) > 13 Then
            MSG = MsgBox("被保険者番号が表示範囲を超えています。ハイフン込みで13桁まで表示します。よろしいですか？", vbYesNo + vbQuestion, "個人番号登録変更届出書")
            If MSG = vbNo Then
                Exit Sub
            End If
        End If
        If Len(Cells(14, 2).Value) > 20 Then
            MSG = MsgBox("氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）よろしいですか？", vbYesNo + vbQuestion, "個人番号登録変更届出書")
            If MSG = vbNo Then
                Exit Sub
            End If
        End If
               
    fnam = ThisWorkbook.Path & "\pdf\個人番号登録変更届出書\" & Trim(Cells(14, 2).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF"
    If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf")
    End If
    If Dir(ThisWorkbook.Path & "\pdf\個人番号登録変更届出書", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf\個人番号登録変更届出書")
    End If
         
    'pdfファイルを削除する
    On Error Resume Next
        Kill ThisWorkbook.Path & "\pdf\個人番号登録変更届出書\" & "*.pdf"
    On Error GoTo 0
        
    Call pdf作成(fnam, pFg)
    
    Dim ShellString As String
    Dim param As String
    param = 8
            
    ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "個人番号登録変更届出書") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"
    
    ExecCmd ShellString
            
    Application.ScreenUpdating = True

End Sub
Private Sub pdf作成(ByVal Fn As String, PrintMode As Boolean)
    Dim i As Integer, n As Integer
    Dim d As String, strData As String
    
    '必要データ作成
    Dim TextFilename As String
    TextFilename = Fn
    
    Open TextFilename For Output As #1
    
    'パスワードは利用しないので空欄
    Print #1, ""
    
    With Workbooks("個人番号登録変更届出書.xls").Worksheets("DATA")
        For i = 1 To 23
            Select Case i
                Case 2 'マイナンバー
                    For n = 1 To 12
                        If n = 1 Then
                            strData = Mid(.Cells(i, 6).Value, n, 1)
                        Else
                            strData = strData & vbTab & Mid(.Cells(i, 6).Value, n, 1)
                        End If
                    Next
                Case 3 '変更前マイナンバー
                    For n = 1 To 12
                        If n = 1 Then
                            strData = Mid(.Cells(i, 6).Value, n, 1)
                        Else
                            strData = strData & vbTab & Mid(.Cells(i, 6).Value, n, 1)
                        End If
                    Next
                Case 4 '被保険者番号
                    For n = 1 To 4
                        If n = 1 Then
                            strData = Mid(.Cells(i, 6).Value, n, 1)
                        Else
                            strData = strData & vbTab & Mid(.Cells(i, 6).Value, n, 1)
                        End If
                    Next
                    Print #1, strData
                    For n = 6 To 11
                        If n = 6 Then
                            strData = Mid(.Cells(i, 6).Value, n, 1)
                        Else
                            strData = strData & vbTab & Mid(.Cells(i, 6).Value, n, 1)
                        End If
                    Next
                    Print #1, strData
                    strData = Mid(.Cells(i, 6).Value, 13, 1)
                Case 6 '氏名
                    For n = 1 To 20
                        If n = 1 Then
                            strData = Mid(.Cells(i, 6).Value, n, 1)
                        Else
                            strData = strData & vbTab & Mid(.Cells(i, 6).Value, n, 1)
                        End If
                    Next
                Case 8 '生年月日
                    d = Format(.Cells(i, 6).Value, "ggeemmdd")
                    strData = IIf(Mid(d, 1, 1) = "昭", 3, IIf(Mid(d, 1, 1) = "平", 4, ""))
                    Print #1, strData
                    For n = 2 To 7
                        If n = 2 Then
                            strData = Mid(d, n, 1)
                        Else
…