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

Sub 大学へ()
Sheets("大卒求人").Select
End Sub
Sub 新大学へ()
Sheets("新大卒求人").Select
End Sub
Sub MENUへ()
Sheets("MENU").Select
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 欄選考へ()
    欄選考.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

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

    ''' 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
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 HELPへ()
'20111130 kon
'Sheets("HELP").Select
    OpenPdf ("新卒求人票.pdf")
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{742196D4-BF31-4ADB-B2C5-C096AB568E29}{B53D5E83-4ECB-40B5-B231-218181784D0B}"
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{3C53F115-0441-4E66-9045-5684D43D11EF}{E73F54C2-223B-402B-B2D5-143E2FE37414}"
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.Value & ファイル区分
        If シート = "新大卒求人" And Cells(8, 4).Value = 1 Then
            MsgBox "この保存データは旧型式のため現在シートに読み込むことができません。", 48, "保存データ"
            Unload Me
            Exit Sub
        End If
        ThisWorkbook.Worksheets(シート).Range("B5:FP251").Value = Workbooks(ListBox1.Value & ファイル区分).Worksheets("COPY").Range("B5:FP251").Value2
        ActiveWorkbook.Close False
        ThisWorkbook.Activate
        Unload Me
        Exit Sub
    End If
        
    Workbooks.Open ActiveWorkbook.Path & "\Da保存\" & ListBox1.Value & ファイル区分
    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
    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()
    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 = "高欄1"
Attribute VB_Base = "0{3AE20954-AA8D-4634-BEFF-5371C2AF6E60}{DE7E10AD-5079-4C5A-96F8-DA489FA12A05}"
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 CommandButton2_Click()
    If MsgBox("「台帳」の会社情報から「事業所番号」と「事業所名」を読み込みます。", 4 + 32, "読込") <> 6 Then Exit Sub
    With Workbooks(da).Worksheets("会社情報")
        TextBox3.Value = .Cells(36, 2).Value
        TextBox5.Value = .Cells(8, 2).Value
        TextBox4.Value = StrConv(Application.GetPhonetic(TextBox5.Value), vbKatakana)
    End With
End Sub

Private Sub CommandButton3_Click()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim k As Long
Application.Calculation = xlCalculationManual
    Range("E11:CD12,CS10:FN13,ED6:FM6,E15:FC19").ClearContents
    
    
    '年月日
    Call SuutiBB(Trim(TextBox1.Value), 6, 134, 6, 6)

    '事業所番号
        Call SuutiBB(Trim(TextBox3.Value), 11, 5, 6, 13)
        Call SuutiBB(Trim(TextBox3.Value), 77, 5, 6, 13)
        Call SuutiBB(Trim(TextBox3.Value), 169, 5, 6, 13)
        Cells(10, 97).Value = TextBox4.Value
        Cells(12, 97).Value = TextBox5.Value
        Cells(76, 97).Value = TextBox5.Value
        Cells(168, 97).Value = TextBox5.Value

    '職種
    Call SuutiBB(Trim(TextBox7.Value), 15, 5, 11, 14)
    Call SuutiBB(Trim(TextBox8.Value), 19, 5, 11, 14)
    Application.Calculation = xlCalculationAutomatic
    Unload Me
    
End Sub
Private Sub CommandButton4_Click()
    ActiveSheet.Unprotect
    MsgBox "シートの保護を解除しました。", 64, "保護解除"
    Unload Me
End Sub
Private Sub UserForm_Activate()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    If da = "" Then CommandButton2.Visible = False
    TextBox1.Value = Suuti(6, 134, 6, 6)
    TextBox3.Value = Suuti(11, 5, 6, 13)
    TextBox4.Value = Cells(10, 97).Value
    TextBox5.Value = Cells(12, 97).Value
    '漢字
    TextBox7.Value = Suuti(15, 5, 11, 14)
    TextBox8.Value = Suuti(19, 5, 11, 14)

End Sub


Attribute VB_Name = "Module2"
Option Explicit
'20111111 kon
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type
'20111111 kon
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 Const NORMAL_PRIORITY_CLASS = &H20&
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
'20111111 kon end


Function Suuti(行 As Long, 列 As Long, 間 As Long, 数 As Long) As String
    Dim ii As Long
    Suuti = ""
    For ii = 1 To 数
        Suuti = Suuti & IIf(Cells(行, 列 + 間 * (ii - 1)).Value = "", " ", Cells(行, 列 + 間 * (ii - 1)).Value)
    Next
    Suuti = Trim(Suuti)
End Function
Sub SuutiB(s As String, 行 As Long, 列 As Long, 間 As Long, 数 As Long)
    Dim ii As Long
    Dim nn As Long
    nn = 0
    For ii = 数 - 1 To 0 Step -1
        If Len(s) > ii Then Cells(行, 列 + nn * 間).Value = Mid(s, -(ii - Len(s)), 1)
        nn = nn + 1
    Next
End Sub
Sub SuutiBB(s As String, 行 As Long, 列 As Long, 間 As Long, 数 As Long)
    Dim ii As Long '先頭から
    For ii = 1 To 数
        Cells(行, 列 + (ii - 1) * 間).Value = Mid(s, ii, 1)
    Next

End Sub
Function Check(Mr As Long, Mc As Long)
    Check = IIf(Trim(Cells(Mr, Mc).Value) <> "", True, False)
End Function
Sub CheckB(s As Boolean, 行 As Long, 列 As Long)
    If s Then Cells(行, 列).Value = "|"
End Sub
Public Function GetTextData(ByVal i As Integer, ByVal FileName As String) As String
  
    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName

    GetTextData = buffer(i - 1)

End Function
Public Sub SetTextData(ByVal i As Integer, ByVal str As String, ByVal FileName As String)

    '先に全部読み込む

    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName
    
    '書き換えたい文字列
    buffer(i - 1) = str
    
    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

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

    For LineCount = 0 To UBound(buffer)
            'ファイルをバイナリで読み込んで配列に格納
            Print #FileNumber, buffer(LineCount)
    Next
           
    Close #FileNumber
    
End Sub
Public Sub GetStringArray(ByRef str() As String, ByVal FileName As String)

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

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

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

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

End Sub
Public Function PathCombine(ByVal str1 As String, ByVal str2 As String) As String

    If Right(str1, 1) = "\" Then
        PathCombine = str1 & str2
    Else
        PathCombine = str1 & "\" & str2
    End If

End Function
'20100330 笹原 NO318 会社情報->電子申請->画像ファイルのパスが保存されない
'空ファイルを作る
Public Sub CreateEmptyTextFile(ByVal FileName As String, ByVal MaxLine As Long)

    Dim FileNumber As Long 'ファイル番号
    Dim LineCount As Long

    FileNumber = FreeFile

    Open FileName For Output As #FileNumber
    For LineCount = 0 To MaxLine - 1
            'ファイルをバイナリで読み込んで配列に格納
            Print #FileNumber, vbNullString
    Next
    Close #FileNumber
    
End Sub
'END 20100330 笹原 NO318 会社情報->電子申請->画像ファイルのパスが保存されない
Public Sub CheckTextFile(ByVal FileName As String, ByVal MaxLine As Long)

    Dim buffer() As String '文字列受け取り用
    Dim i As Long

    '読込
    GetStringArray buffer, FileName

    '最大値に足りない場合は、後ろに空データを増やす
    If UBound(buffer) <> MaxLine - 1 Then
        ReDim Preserve buffer(MaxLine - 1)
    Else
        '同じなら何もしない
        Exit Sub
    End If
      
    Dim FileNumber As Long 'ファイル番号
    Dim LineCount As Long '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

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

    For LineCount = 0 To UBound(buffer)
            'ファイルをバイナリで読み込んで配列に格納
            Print #FileNumber, buffer(LineCount)
    Next
           
    Close #FileNumber

End Sub
Sub 印刷データ作成()
    Dim i, n, r, c, nn  As Long
    Dim FileName As String
    Dim 区分 As String
    Dim 列 As Long
    Dim ShellString As String
    Dim param As String
    Dim pFg As String
    
    区分 = Mid(ActiveSheet.Name, 2, 2) '大卒または高卒
    If 区分 = "高卒" Then
        列 = 8
        param = 2
    Else
        列 = 1
        param = 1
    End If
    
    frmPrint.Show
    If cFg = True Then Exit Sub

'20111111 kon add
…