Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'Option Explicit
'
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'ThisWorkbook.Saved = True
'End Sub
'
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'   MsgBox "このファイルは保存できません。", 16, "求人票"
'    Cancel = True
'End Sub
'
'
'

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

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 = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit


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


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


Attribute VB_Name = "Module1"
'マニュアル形式の変更　20111130 kon
Option Explicit
Public da As String
'20111111 余白設定
Public Tmargin As Double
Public Lmargin As Double
Public pFg      As Boolean
Public hName As String
Public cFg       As Boolean
'20111130 kon
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&
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
Sub 初期処理()
da = Worksheets("DATA").Cells(1, 1).Value
Worksheets("高卒求人").Unprotect
Worksheets("大卒求人").Unprotect
On Error Resume Next
Application.ErrorCheckingOptions.BackgroundChecking = False
Sheets("MENU").Select
End Sub
'20110223 kon
Sub 単体初期処理()
Worksheets("DATA").Cells(1, 1).Value = ""
Worksheets("高卒求人").Unprotect
Worksheets("大卒求人").Unprotect
On Error Resume Next
Application.ErrorCheckingOptions.BackgroundChecking = False
Sheets("MENU").Select
End Sub
Sub 高校へ()
Sheets("高卒求人").Select
End Sub
Sub 新高校へ()
Sheets("新高卒求人").Select
End Sub
'taka 20160603
Sub 雇用情報シートへ()

If ActiveSheet.Name = ("新大卒求人") Then '#38256 SHIHO 20170630
    Worksheets("新大卒求人").Cells(1, 1).Value = 1
ElseIf ActiveSheet.Name = ("新高卒求人") Then
    Worksheets("新高卒求人").Cells(1, 1).Value = 1
End If

Sheets("雇用情報シート").Select
Cells(6, 5).Value = Workbooks(da).Worksheets("会社情報").Cells(8, 2).Value
Cells(28, 33).Value = Workbooks(da).Worksheets("会社情報").Cells(36, 2).Value
Cells(6, 34).Value = Now
End Sub

Sub 大学へ()
Sheets("大卒求人").Select
End Sub
Sub 新大学へ()
Sheets("新大卒求人").Select
End Sub
Sub MENUへ()
Sheets("MENU").Select
End Sub
Sub BackSheets() '#38256 SHIHO 20170630

If Worksheets("新大卒求人").Cells(1, 1).Value = 1 Then

    Sheets("新大卒求人").Select
    Cells(1, 1).Clear

ElseIf Worksheets("新高卒求人").Cells(1, 1).Value = 1 Then

    Sheets("新高卒求人").Select
    Cells(1, 1).Clear

End If

End Sub
Sub 欄1へ()
    da = Workbooks("新卒求人票.xls").Worksheets("DATA").Cells(1, 1).Value
    欄1.Show
End Sub
Sub 欄3へ()
    欄3.Show
End Sub
Sub 欄678へ()
    欄678.Show
End Sub
Sub 欄910へ()
    欄910.Show
End Sub
Sub 欄11から16へ()
    欄11から16.Show
End Sub
Sub 欄18へ()
    欄18.Show
End Sub
Sub 青少年雇用情報1へ() '#37684 SHIHO 20170614 高卒大卒共通
    青少年雇用情報1.Show
End Sub
Sub 青少年雇用情報2へ() '#37684 SHIHO 20170614 高卒大卒共通
    青少年雇用情報2.Show
End Sub
Sub 青少年雇用情報3へ() '#37684 SHIHO 20170614 高卒大卒共通
    青少年雇用情報3.Show
End Sub
Sub 欄選考へ()
    欄選考.Show
End Sub
Sub 表面へ()
    ActiveWindow.ScrollRow = 5
End Sub
Sub 次Pへ()
    ActiveWindow.ScrollRow = 71
End Sub
Sub 次次Pへ()
    ActiveWindow.ScrollRow = 156
End Sub

'YBNO 25275  ito 20140520　オンライン同意書追加
Sub 同意書へ()
    DoEvents
    Sheets("同意書").Select
    DoEvents
End Sub
Sub 同意書戻る()
Sheets("新大卒求人").Select
End Sub

'taka 20160606
Sub 所属職種へ()
    所属職種.Show
End Sub

'taka 20160606-------/

Sub データ読込()
    Dim i As Long
    Dim n As Long
    Dim MyS As String
    
    '20110223 kon
    If Worksheets("DATA").Cells(1, 1).Value = "" Then
        MsgBox "台帳版での機能です。", vbInformation, "データ読み込み"
        Exit Sub
    End If
    da = Worksheets("DATA").Cells(1, 1).Value
    'taka 20160603
    If ActiveSheet.Name = "雇用情報シート" Then
         Dim m As Long
         Dim l As Long
         With Workbooks(da).Worksheets("個人情報")
            m = .Cells(10000, 13).End(xlUp).Row
            If Cells(31, 38).Value = 1 Then '所属か職種かの判定
                l = 31
            ElseIf Cells(31, 38).Value = 2 Then
                l = 32
            End If
            'クリア
            Range("J13").MergeArea.ClearContents
            Range("J14").MergeArea.ClearContents
            Range("Y13").MergeArea.ClearContents
            Range("Y14").MergeArea.ClearContents
            
'            Dim HeikinDate() As Double '平均継続年数
'            Dim HeikinNenrei() As Double  '平均年齢
            Dim HeikinDate As Double '平均継続年数
            Dim HeikinNenrei As Double  '平均年齢
            Dim HeikinDate2 As Double
            Dim HeikinNenrei2 As Double
            Dim kazu As Long
            Dim kazu2 As Long
'            Dim HeikinDate2() As Double '平均継続年数 所属、職種用
'            Dim HeikinNenrei2() As Double  '平均年齢　所属、職種用
'            ReDim HeikinDate(m)
'            ReDim HeikinNenrei(m)
'            ReDim HeikinDate2(m)
'            ReDim HeikinNenrei2(m)
            For i = 0 To m
                If Cells(3, 15).Value = "〇" Then '正社員
                
                    If .Cells(i + 6, 27).Value <> "" And .Cells(i + 6, 28).Value = "" And .Cells(i + 6, 134).Value < Now Then '社保取得日、喪失日、雇用期間の定めの至で判定
                        If .Cells(i + 6, 15).Value <> "" Or .Cells(i + 6, 14).Value <> "" Then
                                If .Cells(i + 6, 15).Value = "" Then
                                    HeikinDate = HeikinDate + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, Now)) / 365
                                    kazu = kazu + 1
                                    If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                        HeikinDate2 = HeikinDate2 + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, Now)) / 365
                                        kazu2 = kazu2 + 1
                                    End If
                                Else
                                    If .Cells(i + 6, 14).Value <> "" Then
                                        HeikinDate = HeikinDate + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, .Cells(i + 6, 15).Value)) / 365
                                        kazu = kazu + 1
                                        If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                            HeikinDate2 = HeikinDate2 + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, .Cells(i + 6, 15).Value)) / 365
                                            kazu2 = kazu2 + 1
                                        End If
                                    End If
                                End If
                        End If
                    
                        If .Cells(i + 6, 13).Value <> "" Then
                            HeikinNenrei = HeikinNenrei + CDbl(DateDiff("y", .Cells(i + 6, 13).Value, Now)) / 365
                            If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                HeikinNenrei2 = HeikinNenrei2 + CDbl(DateDiff("y", .Cells(i + 6, 13).Value, Now)) / 365
                            End If
                        End If
                    End If
                    
                Else '正社員以外
                
                    If .Cells(i + 6, 27).Value = "" And .Cells(i + 6, 28).Value = "" Or .Cells(i + 6, 28).Value <> "" Or .Cells(i + 6, 132).Value = True And .Cells(i + 6, 134).Value > Now Then
                        If .Cells(i + 6, 15).Value <> "" Or .Cells(i + 6, 14).Value <> "" Then
                                If .Cells(i + 6, 15).Value = "" Then
                                    HeikinDate = HeikinDate + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, Now)) / 365
                                    kazu = kazu + 1
                                    If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                        HeikinDate2 = HeikinDate2 + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, Now)) / 365
                                        kazu2 = kazu2 + 1
                                    End If
                                Else
                                    If .Cells(i + 6, 14).Value <> "" Then
                                        HeikinDate = HeikinDate + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, .Cells(i + 6, 15).Value)) / 365
                                        kazu = kazu + 1
                                        If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                            HeikinDate2 = HeikinDate2 + CDbl(DateDiff("y", .Cells(i + 6, 14).Value, .Cells(i + 6, 15).Value)) / 365
                                            kazu2 = kazu2 + 1
                                        End If
                                    End If
                                End If
                        End If
                    
                        If .Cells(i + 6, 13).Value <> "" Then
                            HeikinNenrei = HeikinNenrei + CDbl(DateDiff("y", .Cells(i + 6, 13).Value, Now)) / 365
                            If Cells(8, 28).Value <> "" And .Cells(i + 6, l).Value = Cells(8, 28).Value Then '所属、職種
                                HeikinNenrei2 = HeikinNenrei2 + CDbl(DateDiff("y", .Cells(i + 6, 13).Value, Now)) / 365
                            End If
                        End If
                    End If
                End If
        
            Next
            
            
           If kazu <> 0 Then
'                If Application.Round(WorksheetFunction.Average(HeikinDate), 1) <> 0 Then Cells(13, 10).Value = Application.Round(WorksheetFunction.Average(HeikinDate), 1) & "年"
'                If Application.Round(WorksheetFunction.Average(HeikinNenrei), 1) <> 0 Then Cells(14, 10).Value = Application.Round(WorksheetFunction.Average(HeikinNenrei), 1) & "歳"
                If HeikinDate / kazu <> 0 Then Cells(13, 10).Value = Application.Round(HeikinDate / kazu, 1)
                If HeikinNenrei / kazu <> 0 Then Cells(14, 10).Value = Application.Round(HeikinNenrei / kazu, 1)
            Else
                MsgBox "対象者が見つかりません。", vbCritical, "読込"
                Exit Sub
            End If
    
            If kazu2 <> 0 Then
                If HeikinDate2 / kazu2 <> 0 Then Cells(13, 25).Value = Application.Round(HeikinDate2 / kazu2, 1)
                If HeikinNenrei2 / kazu2 <> 0 Then Cells(14, 25).Value = Application.Round(HeikinNenrei2 / kazu2, 1)
            End If
            
'            Cells(13, 10).Value = Application.Round(WorksheetFunction.Average(HeikinDate), 1) & "年"
'            Cells(14, 10).Value = Application.Round(WorksheetFunction.Average(HeikinNenrei), 1) & "歳"
'            Cells(13, 25).Value = Application.Round(WorksheetFunction.Average(HeikinDate2), 1) & "年"
'            Cells(14, 25).Value = Application.Round(WorksheetFunction.Average(HeikinNenrei2), 1) & "歳"
            
         End With
         MsgBox "読込ました。" & vbCrLf & "(その他のデータは直接シートに入力してください。)", vbExclamation, "読込"

         
    Else

        ''' 20101028 YBNO2365 メッセージの修正
        If MsgBox("台帳から事業所名称等主要データを読み込みますか?" & vbCrLf & "(その他のデータは直接シートに入力してください。)", 4 + 32, "読込") <> 6 Then Exit Sub
        ''' END 20101028 YBNO2365
        With Workbooks(da).Worksheets("会社情報")
            If ActiveSheet.Name = "大卒求人" Then
                For i = 1 To 13 '雇用保険番号
                Cells(8, 8 + i).Value = Mid(.Cells(36, 2).Value, i, 1)
                Next
                Cells(9, 7).Value = .Cells(79, 2).Value 'ﾌﾘｶﾞﾅ
                Cells(10, 7).Value = .Cells(8, 2).Value '会社名
                Cells(12, 7).Value = "（〒 " & .Cells(9, 2).Value & "  )" '所在地
                Cells(13, 7).Value = .Cells(10, 2).Value '所在地
                Cells(15, 7).Value = "  同      上"
                Cells(16, 7).Value = .Cells(11, 2).Value '代表者職
                Cells(17, 7).Value = .Cells(12, 2).Value '代表者
                Cells(19, 7).Value = .Cells(15, 2).Value '業種
                Cells(19, 34).Value = .Cells(13, 2).Value 'TEL
                Cells(20, 34).Value = .Cells(14, 2).Value 'FAX
            Else
                Cells(61, 33).Value = Mid(.Cells(36, 2).Value, 1, 5) '雇用保険番号
                Cells(63, 33).Value = Mid(.Cells(36, 2).Value, 6)
    
                Cells(8, 11).Value = .Cells(79, 2).Value 'ﾌﾘｶﾞﾅ
                Cells(9, 8).Value = .Cells(8, 2).Value '会社名
                Cells(11, 9).Value = .Cells(9, 2).Value '〒
                Cells(12, 8).Value = .Cells(10, 2).Value '所在地
                Cells(15, 7).Value = "  同      上"
                Cells(56, 37).Value = .Cells(8, 2).Value '代表者職
                Cells(58, 37).Value = .Cells(11, 2).Value & "  " & .Cells(12, 2).Value '代表者
                Cells(17, 8).Value = .Cells(15, 2).Value '業種
                On Error Resume Next
                For i = 1 To Len(.Cells(13, 2).Value) 'TEL
                    If Mid(.Cells(13, 2).Value, i, 1) = "-" Then
                        Cells(54, 42).Value = Mid(.Cells(13, 2).Value, 1, i - 1)
                        Exit For
                    End If
                Next
                MyS = Mid(.Cells(13, 2).Value, i + 1)
                For i = 1 To Len(MyS)
                    If Mid(MyS, i, 1) = "-" Then
                        Cells(54, 46).Value = Mid(MyS, 1, i - 1)
                        Cells(54, 50).Value = Mid(MyS, i + 1)
                        Exit For
                    End If
                Next
                For i = 1 To Len(.Cells(14, 2).Value) 'FAX
                    If Mid(.Cells(14, 2).Value, i, 1) = "-" Then
                        Cells(55, 42).Value = Mid(.Cells(14, 2).Value, 1, i - 1)
                        Exit For
                    End If
                Next
                MyS = Mid(.Cells(14, 2).Value, i + 1)
                For i = 1 To Len(MyS)
                    If Mid(MyS, i, 1) = "-" Then
                        Cells(55, 46).Value = Mid(MyS, 1, i - 1)
                        Cells(55, 50).Value = Mid(MyS, i + 1)
                        Exit For
                    End If
                Next
            End If
        End With
    End If
    'taka 20160603-----------------------/
    
'    ''' 20101028 YBNO2365 メッセージの修正
'    If MsgBox("台帳から事業所名称等主要データを読み込みますか?" & vbCrLf & "(その他のデータは直接シートに入力してください。)", 4 + 32, "読込") <> 6 Then Exit Sub
'    ''' END 20101028 YBNO2365
'    With Workbooks(da).Worksheets("会社情報")
'        If ActiveSheet.Name = "大卒求人" Then
'            For i = 1 To 13 '雇用保険番号
'            Cells(8, 8 + i).Value = Mid(.Cells(36, 2).Value, i, 1)
'            Next
'            Cells(9, 7).Value = .Cells(79, 2).Value 'ﾌﾘｶﾞﾅ
'            Cells(10, 7).Value = .Cells(8, 2).Value '会社名
'            Cells(12, 7).Value = "（〒 " & .Cells(9, 2).Value & "  )" '所在地
'            Cells(13, 7).Value = .Cells(10, 2).Value '所在地
'            Cells(15, 7).Value = "  同      上"
'            Cells(16, 7).Value = .Cells(11, 2).Value '代表者職
'            Cells(17, 7).Value = .Cells(12, 2).Value '代表者
'            Cells(19, 7).Value = .Cells(15, 2).Value '業種
'            Cells(19, 34).Value = .Cells(13, 2).Value 'TEL
'            Cells(20, 34).Value = .Cells(14, 2).Value 'FAX
'        Else
'            Cells(61, 33).Value = Mid(.Cells(36, 2).Value, 1, 5) '雇用保険番号
'            Cells(63, 33).Value = Mid(.Cells(36, 2).Value, 6)
'
'            Cells(8, 11).Value = .Cells(79, 2).Value 'ﾌﾘｶﾞﾅ
'            Cells(9, 8).Value = .Cells(8, 2).Value '会社名
'            Cells(11, 9).Value = .Cells(9, 2).Value '〒
'            Cells(12, 8).Value = .Cells(10, 2).Value '所在地
'            Cells(15, 7).Value = "  同      上"
'            Cells(56, 37).Value = .Cells(8, 2).Value '代表者職
'            Cells(58, 37).Value = .Cells(11, 2).Value & "  " & .Cells(12, 2).Value '代表者
'            Cells(17, 8).Value = .Cells(15, 2).Value '業種
'            On Error Resume Next
'            For i = 1 To Len(.Cells(13, 2).Value) 'TEL
'                If Mid(.Cells(13, 2).Value, i, 1) = "-" Then
'                    Cells(54, 42).Value = Mid(.Cells(13, 2).Value, 1, i - 1)
'                    Exit For
'                End If
'            Next
'            MyS = Mid(.Cells(13, 2).Value, i + 1)
'            For i = 1 To Len(MyS)
'                If Mid(MyS, i, 1) = "-" Then
'                    Cells(54, 46).Value = Mid(MyS, 1, i - 1)
'                    Cells(54, 50).Value = Mid(MyS, i + 1)
'                    Exit For
'                End If
'            Next
'            For i = 1 To Len(.Cells(14, 2).Value) 'FAX
'                If Mid(.Cells(14, 2).Value, i, 1) = "-" Then
'                    Cells(55, 42).Value = Mid(.Cells(14, 2).Value, 1, i - 1)
'                    Exit For
'                End If
'            Next
'            MyS = Mid(.Cells(14, 2).Value, i + 1)
'            For i = 1 To Len(MyS)
'                If Mid(MyS, i, 1) = "-" Then
'                    Cells(55, 46).Value = Mid(MyS, 1, i - 1)
'                    Cells(55, 50).Value = Mid(MyS, i + 1)
'                    Exit For
'                End If
'            Next
'        End If
'    End With
    
    
    
End Sub
Sub 印刷()
If MsgBox("プリンタの準備はいいですか？", 4 + 32, "印刷") <> 6 Then Exit Sub
DoEvents
ActiveSheet.PrintOut
DoEvents
End Sub
Sub Da保存へ()
'20110223 kon
'Open Workbooks("DaMenu.xls").Path & "\HozonName.dat" For Output As #1
    Dim strPath As String
    If Worksheets("DATA").Cells(1, 1).Value = "" Then
        strPath = Workbooks("新求人票.xls").Path & "\HozonName.dat"
    Else
        strPath = Workbooks("DaMenu.xls").Path & "\HozonName.dat"
    End If

Open strPath For Output As #1
        If ActiveSheet.Name = "大卒求人" Then
        Write #1, Cells(24, 4).Value & " " & Year(Date) & "年"
        ElseIf ActiveSheet.Name = "高卒求人" Then
        Write #1, Cells(8, 34).Value & " " & Year(Date) & "年"
        Else
        Write #1, Year(Date) & "年"
        End If
Close #1
'20110223 kon
'Application.Run "DaAddin.xla!Da保存へ"
    If Worksheets("DATA").Cells(1, 1).Value = "" Then
'        Application.Run "新求人票.xls!保存へ"
        Call 単体Da保存へ
    Else
        'YB29734 清水
        'Application.Run "DaAddin.xla!Da保存へ"
        Application.Run "DaAddin.xla!Da保存へ", vbNullString
    End If
End Sub
'20110223 kon
Sub 単体Da保存へ()
    On Error Resume Next
    Dim TextFilename As String
    Dim mystr As String
    Da保存.TextBox1.Value = "作成" & Format(Now, "yyyymmddhmmss")
    TextFilename = Workbooks("新求人票.xls").Path & "\HozonName.dat"
    If "HozonName.dat" = Dir(TextFilename) Then
        Open TextFilename For Input As #1
            Input #1, mystr
            Da保存.TextBox1.Value = mystr
        Close #1
    End If
    Da保存.Show
End Sub
'20110223 kon
Sub 単体Da保存読込へ()
Da保存読込.Show
End Sub

Sub Da保存読込へ()
'20110223 kon
'Application.Run "DaAddin.xla!Da保存読込へ"
    If Worksheets("DATA").Cells(1, 1).Value = "" Then
        'Application.Run "新求人票.xls!保存読込へ"
        Call 単体Da保存読込へ
    Else
        Da保存読込.Show
    End If
End Sub

'#40556  ito 20180403　追加　--------------------
Sub Da保存読込2()
    Application.Run "DaAddin.xla!Da保存読込へ"
End Sub
'#40556  ----------------------------------------

Sub 記載例()
CreateObject("Shell.Application").ShellExecute ThisWorkbook.Path & "\新卒求人記載例.pdf"
End Sub
Sub 終了()
If MsgBox("終了しますか？", 1 + 32, "求人票") <> 1 Then Exit Sub
    On Error Resume Next
    Application.ErrorCheckingOptions.BackgroundChecking = True
'20110223 kon
'Application.Run "DaAddin.xla!閉じる"
    If Worksheets("DATA").Cells(1, 1).Value = "" Then
        Application.Run "新求人票.xls!終了"
    Else
        Application.Run "DaAddin.xla!閉じる"
    End If
End Sub
'20110223 kon
Function Hani(範囲 As String)
    Dim i As Integer
    For i = 1 To Len(範囲)
        If Mid(範囲, i, 1) = ":" Then
            Hani = Left(範囲, i - 1) & ":"
            Exit For
        End If
    Next
    For i = Len(範囲) To 1 Step -1
        If Mid(範囲, i, 1) = ":" Then
            Hani = Hani & Right(範囲, Len(範囲) - i)
            Exit For
        End If
    Next
End Function
Sub Go_Manual() '#38206 SHIHO 20170704
    
    Dim url As String
    
    url = "https://www.cells.co.jp/daityo-s/wp-content/uploads/manual/sinsotukyujin.pdf"
    Application.Run "DaAddin.xla!WebManual", url
    
End Sub
'20111130 kon
Sub OpenPdf(pdfFile)
    Dim strPath As String
    Dim lngRet As Long
    Dim Manu As String
    
    strPath = ThisWorkbook.Path & "\マニュアル\" & pdfFile
    lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            MsgBox "説明書を開くことができません。", 16, "新卒求人票"
        Case ERROR_FILE_NOT_FOUND
            MsgBox "説明書が見つかりません。", 16, "新卒求人票"
    End Select
End Sub
'Sub macro()
''MsgBox ActiveCell.Column
''Suuti(6, 134, 6, 6)
''MsgBox ActiveCell.Offset(0, 1).Column - ActiveCell.Column
'
'    Dim CB As New DataObject
'    With CB
'        .SetText "Suuti(" & ActiveCell.Row & "," & ActiveCell.Column & "," & (ActiveCell.Offset(0, 1).Column - ActiveCell.Column) & ",3)"
'        .PutInClipboard
'    End With
'MsgBox "Suuti(" & ActiveCell.Row & "," & ActiveCell.Column & "," & (ActiveCell.Offset(0, 1).Column - ActiveCell.Column) & ",3)", 64, "cb"
'
'End Sub
Sub macro()
'MsgBox ActiveCell.Column
'Suuti(6, 134, 6, 6)
'MsgBox ActiveCell.Offset(0, 1).Column - ActiveCell.Column

'    Dim CB As New DataObject
'    With CB
'        .SetText "Suuti(" & ActiveCell.Row & "," & ActiveCell.Column & "," & (ActiveCell.Offset(0, 1).Column - ActiveCell.Column) & ",3)"
'        .PutInClipboard
'    End With
'MsgBox "Suuti(" & ActiveCell.Row & "," & ActiveCell.Column & "," & (ActiveCell.Offset(0, 1).Column - ActiveCell.Column) & ",3)", 64, "cb"
MsgBox "行は " & ActiveCell.Row & Chr(10) & "列は " & ActiveCell.Column & Chr(10) & "結合セルは" & (ActiveCell.Offset(0, 1).Column - ActiveCell.Column), 64, "輝ちゃん、がんばれ！！"
With Worksheets("印刷DATA")
Dim n As Long
n = .Cells(10000, 10).End(xlUp).Row + 1
.Cells(n, 10).Value = ActiveCell.Row
.Cells(n, 11).Value = ActiveCell.Column
.Cells(n, 12).Value = (ActiveCell.Offset(0, 1).Column - ActiveCell.Column)
End With


End Sub


Attribute VB_Name = "Da保存"
Attribute VB_Base = "0{24B01A2E-CC04-4E98-A83F-CE2DBBD1B040}{F1D17934-8140-4139-A84F-C7CEB47F425B}"
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 Kara As String

Private Sub CommandButton1_Click()
    Dim 保存ファイル名 As String
    Dim ファイル区分 As String
    Dim MyFile As String
    Dim 台帳ファイル名 As String
    Dim シート名 As String
    '20080214 kon
'    Dim 開始範囲    As String
'    Dim 終了範囲    As String

    
    If Trim(TextBox1.Value) = "" Then
        MsgBox "ファイル名を入力してから実行してください。", 16, "保存"
        Exit Sub
    End If
    If TextBox1.Value Like "*[\/:*?""'#<>|]*" Then
        MsgBox TextBox1.Value & " は無効なファイル名です", 16, "保存"
        Exit Sub
    End If
    If Dir(ActiveWorkbook.Path & "\Da保存", 16) = "" Then MkDir ActiveWorkbook.Path & "\Da保存" '保存台帳フォルダがなかったら作成する
        シート名 = ActiveSheet.Name
        MyFile = ActiveWorkbook.Name
    If Kara = "Zi" Then '事業所台帳からの保存とファイル区分が違う
        With Worksheets("DATA")
            台帳ファイル名 = .Cells(1, 1).Value
            ファイル区分 = " " & Left(MyFile, Len(MyFile) - 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
    保存ファイル名 = TextBox1.Value & " " & ファイル区分
    
    Dim フルパス As String
    フルパス = ActiveWorkbook.Path & "\Da保存\" & 保存ファイル名
    If 保存ファイル名 = Dir(フルパス) Then 'すでにあるかチェック
        If MsgBox("この保存ファイルはすでに存在します。上書きしますか？", 1 + 48, "新卒求人票") <> 1 Then
        MsgBox "処理を中止します。", 64, "新卒求人票"
        Exit Sub
        End If
    End If
    
    If MsgBox("ファイル名「" & TextBox1.Value & "」を作成します。よろしいですか？", 1 + 32, "新卒求人票") <> 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim 印刷範囲 As String
    Application.ReferenceStyle = xlA1
    '20080214 kon
    '20080130 kon
'    If ActiveSheet.PageSetup.PrintArea = "" Then
'        ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), Cells(ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row, ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column)).Address
'        印刷範囲 = ActiveSheet.PageSetup.PrintArea
'    Else
'        開始範囲 = Range(ActiveSheet.PageSetup.PrintArea).Row() & ":" & Range(ActiveSheet.PageSetup.PrintArea).Column()
'        終了範囲 = Range(ActiveSheet.PageSetup.PrintArea).Rows.Count & ":" & Range(ActiveSheet.PageSetup.PrintArea).Columns.Count
'        印刷範囲 = Range(開始範囲, 終了範囲).Address
'    End If
    If ActiveSheet.PageSetup.PrintArea = "" Then
        印刷範囲 = "$A$1:" & Cells(1, 1).SpecialCells(xlCellTypeLastCell).Address
    Else
        印刷範囲 = Hani(ActiveSheet.PageSetup.PrintArea)
    End If


'    印刷範囲 = ActiveSheet.PageSetup.PrintArea
'　　印刷範囲を再設定　20080130 kon ４行目から上にタイトルがある場合が多いのであえて４行目から
'    印刷範囲 = Range(Cells(4, 1), Cells(ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row, ActiveSheet.UsedRange.SpecialCells(xlLastCell).Column)).Address
'    印刷範囲 = ActiveSheet.PageSetup.PrintArea

    Label4.Caption = "データをコピーしています・・"
    Me.Repaint
    Workbooks.Open ActiveWorkbook.Path & "\NewKeepFile.xls"
    Workbooks(MyFile).Worksheets(シート名).Copy Before:=ActiveWorkbook.Sheets(1) 'シートをコピーする
    ActiveSheet.Unprotect
    ActiveSheet.Name = "COPY" 'シートを名前をCOPYとする
    Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
    Dim wLeft, wTop, wRight, wBottom
    Dim shapeLeft, shapeTop, shapeRight, shapeBottom
    Dim s As Shape
    With Range(印刷範囲)
        wTop = .Top
        wLeft = .Left
        wBottom = .Top + .Height
        wRight = .Left + .Width
    End With
    
    For Each s In ActiveSheet.Shapes
        shapeTop = s.Top
        shapeLeft = s.Left
        shapeBottom = s.Top + s.Height
        shapeRight = s.Left + s.Width
        If s.Name Like "Drop*" Then
        Else
        If (wTop <= shapeTop And wLeft <= shapeLeft And _
            wBottom >= shapeBottom And wRight >= shapeRight) And s.OnAction = "" Then
            Else
            s.Delete
        End If
        End If
    Next
    Cells.Copy
    Cells.PasteSpecial Paste:=xlValues '数式をすべて値にする
    Range(印刷範囲).Value = Workbooks(MyFile).Worksheets(シート名).Range(印刷範囲).Value2
    Sheets("Info").Select
    ActiveSheet.Shapes("BOTAN").Select
    Selection.Cut
    Sheets("COPY").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False
    With Worksheets("Info")
        .Cells(1, 1).Value = ファイル区分
        .Cells(2, 1).Value = MyFile
        If Kara = "Zi" Then
            .Cells(3, 1).Value = 台帳ファイル名
        End If
        .Cells(4, 1).Value = シート名
        .Cells(5, 1).Value = 保存ファイル名
        .Cells(6, 1).Value = TextBox1.Value
        .Cells(7, 1).Value = Now
    End With
    Label4.Caption = "保存しています・・"
    Me.Repaint
    ActiveWorkbook.SaveAs フルパス '保存する
    ActiveWorkbook.Close False
    Workbooks(MyFile).Activate
    Label4.Caption = ""
    Me.Repaint
     MsgBox "「保存データ」を作成しました。", 64, "新卒求人票"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Range("A1").Select
Unload Me
End Sub

Private Sub UserForm_Activate()
    On Error Resume Next
    Kill Workbooks("DaMenu.xls").Path & "\HozonName.dat"
End Sub

Private Sub UserForm_Initialize()
    Application.ScreenUpdating = True
    Me.Caption = ActiveSheet.Name & "の保存"
    TextBox1.SetFocus
    TextBox1.SelStart = 0
    TextBox1.SelLength = TextBox1.TextLength
    On Error GoTo ErrorC
    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 = "Da保存読込"
Attribute VB_Base = "0{DD11F181-CCC7-4B09-AB90-0F35B8ADCB7D}{837DC6FB-57B8-4AA8-98FC-569A393F2CD9}"
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, "新卒求人票"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim シート As String
    
    シート = ActiveSheet.Name
    
    If Left(シート, 1) = "新" Then '20120607 TITTI
        Workbooks.Open ActiveWorkbook.Path & "\Da保存\" & ListBox1.List(ListBox1.ListIndex, 1)
        
        If シート = "新大卒求人" And Cells(8, 4).Value = 1 Then
            MsgBox "この保存データは旧型式のため現在シートに読み込むことができません。", 48, "保存データ"
            Unload Me
            Exit Sub
        End If
        
        '#40556 SHIHO 20180403
        If Right(ListBox1.List(ListBox1.ListIndex, 1), 4) = ".xls" Then
            ThisWorkbook.Worksheets(シート).Range("B5:FP372").Value = Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).Worksheets("COPY").Range("B5:FP372").Value2
        ElseIf Left(シート, 2) = "新高" Then
            ThisWorkbook.Worksheets(シート).Range("B5:FP372").Value = Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).Worksheets("新高卒求人").Range("B5:FP372").Value2  '#37684 SHIHO 20170619
        ElseIf Left(シート, 2) = "新大" Then
            ThisWorkbook.Worksheets(シート).Range("B5:FP372").Value = Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).Worksheets("新大卒求人").Range("B5:FP372").Value2  '#37684 SHIHO 20170619
        End If
        
        ActiveWorkbook.Close False
        ThisWorkbook.Activate
        MsgBox "保存データを読み込みました。", vbOKOnly, "保存データ読込"
        Unload Me
        Exit Sub
    End If
        
    Workbooks.Open ActiveWorkbook.Path & "\Da保存\" & ListBox1.List(ListBox1.ListIndex, 1)
    If Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open ThisWorkbook.Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu").Copy
        Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).Activate
        Range("A1").Select
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu").Top = 1
        ActiveSheet.Shapes("Zu").Left = 100
        Range("A1").Select
        Workbooks(ListBox1.List(ListBox1.ListIndex, 1)).BuiltinDocumentProperties("Keywords").Value = 2010
        ActiveWorkbook.Save
        Workbooks("閉じるボタン.xls").Close False
    End If
    Unload Me
    Application.ScreenUpdating = True
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 ActiveWorkbook.Path & "\Da保存\" & ListBox1.Value & ファイル区分
    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_Activate()
    Dim i As Long
    
    Me.Caption = ActiveSheet.Name & "の保存データ読込"
    
    i = 0
    
    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)  '
            .List(i, 1) = ファイル名
            ファイル名 = Dir()
            i = i + 1
        End With
    Loop
    
    '#40556 SHIHO 20180403
    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 & ".xlsx" '会社名＋様式名
        End With
    Else
        ファイル区分 = Left(MyFile, Len(MyFile) - 4) & " " & ActiveSheet.Name & ".xlsx" 'ブック名＋シート名で保存する
    End If
    
    ファイル名 = Dir(ActiveWorkbook.Path & "\Da保存\*" & ファイル区分)
    n = Len(ファイル区分) '書類名以外のファイル名の文字数
    
    Do While ファイル名 <> ""
        With ListBox1
            .AddItem Left(ファイル名, Len(ファイル名) - n)
            .List(i, 1) = ファイル名
            ファイル名 = Dir()
            i = i + 1
        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 = "高欄1"
Attribute VB_Base = "0{110D659B-4A24-41D5-9612-947BBB6B2ED3}{78C99013-5074-42C1-B8BB-496D8096A431}"
…