Office (OLE) malware analysis — malicious · a390f0cd4a346f0b

MALICIOUS

Office (OLE)

774.0 KB Created: 2012-02-11 05:45:10 Authoring application: Microsoft Excel First seen: 2018-07-14

MD5: 886bd8fcc595f39eef7380112d1c5fb2 SHA-1: 66bba1e10eb4c53d50c6f1ed1f4793b9098c2ae8 SHA-256: a390f0cd4a346f0b9c3c0fc2b2f2c0492939cbb03f1c0a0f6875b531161c5baf

102 Risk Score

Malware Insights

MITRE ATT&CK

T1059.005 Visual Basic T1204.002 Malicious File

The sample is an Excel file containing a large VBA macro, indicating malicious intent. The macro references CreateProcess and ShellExecute APIs, suggesting it's designed to execute arbitrary code. The document body contains Japanese text related to employment insurance forms, likely a lure to deceive the user. While the embedded URL is benign, the VBA code attempts to navigate to a local file path, which could be part of a larger exploit chain or data exfiltration attempt.

Heuristics 4

Reference to CreateProcess API high SC_STR_CREATEPROCESS

Reference to CreateProcess API
Reference to ShellExecute API high SC_STR_SHELLEXEC

Reference to ShellExecute API
VBA macros detected medium OLE_VBA_MACROS

Document contains VBA macro code
Embedded URL info EMBEDDED_URL

One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.

URL http://get.adobe.com/jp/reader/ In document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

Filename Kind Source Size

macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 528196 bytes

Filename	Kind	Source	Size
`macros.bas`	vba-macro	oletools.olevba.extract_macros (decoded VBA source)	528196 bytes
SHA-256: `38b88b3e3f45ec06aa8e3a165e0c447d5ef67a7e43795b757bcdb437b63d2c03`
Preview script First 1,000 lines of the extracted script 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 = "Sheet8" 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 Dim CBox As Object Dim objITEM As Object 'Private Sub WebBrowser1_StatusTextChange(ByVal Text As String) ' 'End Sub ' 'Private Sub Worksheet_Activate() ' WebBrowser1.Navigate "J:\eGov\ツール\ＸＳＬ\離職票aaa\495000020289029832_01.xml" ' WebBrowser1.Document.parentWindow.scrollTo 400, 0 ' ' ActiveSheet.WebBrowser1.Document.parentWindow.scrollTo 400, 0 ' WebScrolRight 'End Sub '''' 20100407 笹原縦バー内のサイトを表示したときに最初から右にスクロールする 'Private Sub WebWindow_DocumentComplete(ByVal pDisp As Object, URL As Variant) ' WebScrolRight 'End Sub 'Private Sub WebScrolRight() ' ' Dim objDoc As Object ' 'Set objDoc = WebBrowser1.Document.parentWindow ' ' objDoc.scrollTo 400, 0 ' ' Set objDoc = Nothing ' 'End Sub ''' 20100407 笹原 End Sub 適用() ThisWorkbook.Activate Application.Calculation = xlCalculationManual With WebBrowser1.Document.Forms(0) Set CBox = .item("J80_選択1_1") チェックボックス CBox, 438 Set CBox = .item("J82_選択2_1") チェックボックス CBox, 440 Set CBox = .item("J83_選択2_2") チェックボックス CBox, 441 Set CBox = .item("J85_選択2_4") チェックボックス CBox, 442 Set CBox = .item("J86_選択2_5") チェックボックス CBox, 443 Set CBox = .item("J87_選択3_1") チェックボックス CBox, 444 Set CBox = .item("J88_選択3_2") チェックボックス CBox, 445 Set CBox = .item("J89_選択3_3_1") チェックボックス CBox, 446 Set CBox = .item("J90_選択3_3_2") チェックボックス CBox, 447 Set CBox = .item("J91_選択4_1_1") チェックボックス CBox, 448 Set CBox = .item("J98_選択5") チェックボックス CBox, 449 Set CBox = .item("J97_選択4_2") チェックボックス CBox, 450 Set CBox = .item("J92_選択4_1_2") チェックボックス CBox, 451 Set CBox = .item("J93_選択4_1_3") チェックボックス CBox, 452 Set CBox = .item("J94_選択4_1_4") チェックボックス CBox, 453 Set CBox = .item("J95_選択4_1_5") チェックボックス CBox, 454 Set CBox = .item("J96_選択4_1_6") チェックボックス CBox, 455 Set CBox = .item("J84_選択2_3") チェックボックス CBox, 456 Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(458, 2).Value = .item("J_定年").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(461, 2).Value = .item("J_箇月1").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(462, 2).Value = .item("J_箇月2").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(468, 2).Value = .item("J_箇月3").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(469, 2).Value = .item("J_箇月4").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(463, 2).Value = .item("J_回数1").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(470, 2).Value = .item("J_回数2").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(476, 2).Value = .item("J_理由1").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(480, 2).Value = .item("J_理由2").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(482, 2).Value = .item("J_理由3").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(479, 2).Value = .item("J_所在地").Value Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(487, 2).Value = .item("J_署名").Value For Each objITEM In ActiveSheet.WebBrowser1.Document.all If objITEM.tagName = "INPUT" Then ラジオボタン "J100_派遣労働者の選択", 460 ラジオボタン "J104_常用労働者以外_契約更新する_確約合意の有無", 464 ラジオボタン "J105_常用労働者以外_契約更新しない_明示の有無", 465 ラジオボタン "J106_常用労働者以外_労働者_契約更新希望申出の有無", 466 ラジオボタン "J107_常用労働者以外_適用基準に該当する派遣就業指示の選択", 467 ラジオボタン "J111_常用労働者_契約更新する_確約合意の有無", 471 ラジオボタン "J112_常用労働者_契約更新しない_明示の有無", 472 ラジオボタン "J113_常用労働者_契約更新時に雇止め通知の有無", 473 ラジオボタン "J114_常用労働者_労働者_契約更新希望申出の有無", 474 ラジオボタン "J116_職種転換等に適応困難_教育訓練の有無", 478 ラジオボタン "J121_離職理由に異議の有無", 486 End If Next End With Application.Calculation = xlCalculationAutomatic End Sub Function チェックボックス(CBox As Object, R As Long) With Workbooks("雇用喪失離職票.xls").Worksheets("離職") If CBox.Checked = True Then .Cells(R, 2).Value = 1 Else .Cells(R, 2).ClearContents End If End With Set CBox = Nothing End Function Function ラジオボタン(Rajio As String, R As Long) If objITEM.Name = Rajio And objITEM.Checked = True Then Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(R, 2).Value = objITEM.Value End If End Function Function テキスト(ttt As String, R As Long) With Workbooks("雇用喪失離職票.xls").Worksheets("離職") .Cells(R, 2).Value = WebBrowser1.Document.Forms(0).item(ttt).Value End With End Function Attribute VB_Name = "Sheet1" Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Attribute VB_TemplateDerived = False Attribute VB_Customizable = True Option Explicit Attribute VB_Name = "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 = "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) Application.Calculation = xlAutomatic ThisWorkbook.Saved = True End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) MsgBox "このファイルは保存できません。", 16, AAA Cancel = True End Sub Attribute VB_Name = "Module11" '修正履歴 '離職票印刷で事業所番号の下1ケタが被保険者番号の下1ケタを持ってきていた　20090619 kon '201101用紙追加　20110506 kon '事務組合の場合の事業所名称の修正　20110725 kon '事務所情報の表示非表示がおかしい　20110823 kon '以降用紙の印刷がおかしい。　Eno 11988 20111209 kon Option Explicit Public Const PROC_NAME As String = "雇用保険資格喪失届" Public Const AAA As String = "雇用保険資格喪失届" '20110506 kon Public pFg As Boolean Public cFg As Boolean Public cDat(3) As String Public hFg As Boolean Public jfg As Boolean '20110506 kon Private Type PROCESS_INFORMATION hProcess As Long hThread As Long dwProcessID As Long dwThreadID As Long End Type '20110506 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 '20110506 kon Private Const NORMAL_PRIORITY_CLASS = &H20& '20110506 kon 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 '20110506 kon 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 '20110927 余白設定 Public Tmargin As Double Public Lmargin As Double Public hName As String Public huki As Integer '関数 Sub OpenFile(fName As String) '関連付いたアプリケーションで立ち上げる Call ShellExecute(0, "open", ThisWorkbook.Path & "\" & fName, vbNullString, vbNullString, 1) End Sub Sub A保存() ActiveWindow.DisplayWorkbookTabs = False Application.EnableEvents = False ThisWorkbook.Save Application.EnableEvents = True End Sub Sub 日数と賃金へ() Dim da As String da = Worksheets("DATA").Cells(1, 1).Value '読み込まれた台帳ファイル名 If Cells(1, 1).Value = 0 Then MsgBox "資格喪失届を作成してから実行してください。", 16, AAA Exit Sub End If If Cells(6, 23).Value <> "" And Cells(6, 23).Value <> Worksheets("雇保喪失届").Cells(10, 4).Value Then MsgBox "保存データから読込まれたデータのためこの操作を実行できません。" & Chr(10) & " 編集は直接シート上でおこなって下さい。", 16, AAA Exit Sub End If With Workbooks(da).Worksheets("個人情報") If IsDate(.Cells(Cells(1, 1), 30).Value) = False Then MsgBox "資格喪失届で選択されている被保険者の離職年月日が不正又は登録されていないため実行できません。", 16, AAA Exit Sub End If If IsDate(.Cells(Cells(1, 1), 29).Value) = False Then MsgBox "資格喪失届で選択されている被保険者の取得年月日が不正又は登録されていないため実行できません。（賃金対象期間の算出に必要です。）", 16, AAA Exit Sub End If '電子申請の場合、退職されるかたの電話番号が必須なので、メッセージを出す。 '20140714 kon 25688 ' If IsEmpty(.Cells(Cells(1, 1), 33).Value) Then If .Cells(Cells(1, 1), 33).Value = "" Then If MsgBox("被保険者の電話番号が登録されていません。電子申請する場合、被保険者の電話番号は必須です。" & vbCrLf & "続けますか。", vbQuestion + vbYesNo, AAA) = vbNo Then Exit Sub End If End With 日数と賃金.Show End Sub Sub 印刷() If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub ActiveSheet.PrintOut End Sub Sub 戻る() '20100906 kon ThisWorkbook.Activate Application.Run "DaAddin.xla!閉じる" 'ThisWorkbook.Close False End Sub Sub 喪失届() Sheets("雇保喪失届").Select Cells(5, 1).Select End Sub Sub 会社Fへ() Application.Run "DaAddin.xla!会社Fへ" End Sub Sub 給与Fへ() Application.Run "DaAddin.xla!給与Fへ" End Sub Sub 個人Fへ() Application.Run "DaAddin.xla!個人Fへ" End Sub Sub Da保存へ() Open Workbooks("DaMenu.xls").Path & "\HozonName.dat" For Output As #1 If ActiveSheet.Name = "離職票" Then Write #1, Cells(6, 23).Value & " " & Cells(5, 30).Value & "年" & Cells(5, 32).Value & "月" & Cells(5, 33).Value & "日" & "離職" Else Write #1, Cells(10, 4).Value & " " & Cells(16, 30).Value End If Close #1 'YBNO 29734 ito 20151216　保存時マイナンバークリア 'Application.Run "DaAddin.xla!Da保存へ" If ActiveSheet.Name = "雇保喪失届" Then Application.Run "DaAddin.xla!Da保存へ", "C20:N20,AD9" Else Application.Run "DaAddin.xla!Da保存へ", vbNullString End If End Sub Sub Da保存読込へ() Da保存読込.Show End Sub Sub Da保存読込喪失へ() Application.Run "DaAddin.xla!Da保存読込へ" End Sub Sub OpenManual() 'YBNO 29726 ito 201602 'Worksheets("HELP").Cells(1, 30).Value = ActiveSheet.Name 'Sheets("HELP").Select Application.Run "DaAddin.xla!OpenManual" End Sub Sub マニュアル戻る() Sheets(Cells(1, 30).Value).Select End Sub Sub 選択へ() 選択.Show End Sub Sub 初期処理() 選択へ End Sub Sub 保存へ() Application.Run "DaAddin.xla!Da保存へ" End Sub Sub 保存読込へ() Application.Run "DaAddin.xla!Da保存読込へ" End Sub Sub 離職票へ() If Cells(3, 11) <> "資格喪失届" Then MsgBox "資格喪失届を選択してください。", vbInformation + vbOKOnly, AAA Exit Sub Else Sheets("離職票").Select End If End Sub Sub 保護の解除() ActiveSheet.Unprotect MsgBox "保護を解除しました", 64, AAA End Sub '20110506 kon Public Function PathCombine(ByVal path1 As String, ByVal path2 As String) As String If Right(path1, 1) = "\" Then PathCombine = path1 & path2 Else PathCombine = path1 & "\" & path2 End If End Function Sub 印刷シートへ() Dim Yousi As String Dim Button As String Dim wb As Object ' Dim fnam As String 'YBNO 29508 ito 20151210　旧様式廃止 ' If Cells(1, 12).Value = 1 Then ' Yousi = "雇用保険資格喪失届印刷シートH2202.xls" ' Button = "Zu5" ' End If ' If Cells(1, 12).Value = 2 Then ' Yousi = "雇用保険資格喪失届印刷シート.xls" ' Button = "Zu4" ' End If ' ' If Cells(1, 12).Value = 3 Then ' ''' YBNO 22048 20130515 ' frmPrint喪失.Show vbModeless '' frmPrint喪失.Show '' If cFg = True Then '' Exit Sub '' End If '' '' If Len(Cells(11, 30).Value) > 20 Then '' MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格取得届印刷" '' End If '' '' fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失\" & Trim(Cells(10, 4).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 = 3 '' '' ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """" '' '' ExecCmd ShellString '' '' '' Application.ScreenUpdating = True ' Exit Sub ' End If frmPrint喪失.Show vbModeless Exit Sub For Each wb In Workbooks If wb.Name = Yousi Then wb.Activate Exit Sub End If Next Application.ScreenUpdating = False Workbooks.Open ThisWorkbook.Path & "\" & Yousi '20101028masa 2010問題　閉じるボタンを張り付ける Application.ScreenUpdating = False If Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value <> 2010 Then Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls" Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes(Button).Copy Workbooks(Yousi).Activate Range("A1").Select ActiveSheet.Paste ActiveSheet.Shapes(Button).Top = 7 ActiveSheet.Shapes(Button).Left = 256 Range("A1").Select Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value = 2010 Application.EnableEvents = False ActiveWorkbook.Save Application.EnableEvents = True Workbooks("閉じるボタン.xls").Close False End If '''20101108 印刷シートの初期処理が呼ばれない Application.Run Yousi & "!初期処理" ''' END 20101108 印刷シートの初期処理が呼ばれない Application.ScreenUpdating = True End Sub ''' #24664 'Sub CreatePDF() ' ' Dim fnam As String ' ' If cFg = True Then ' Exit Sub ' End If ' '''' #24675 '' If Len(Cells(11, 30).Value) > 20 Then '' MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格喪失届印刷" '' End If ' ' fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失\" & Trim(Cells(10, 4).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 = 3 ' ' ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """" ' ' ExecCmd ShellString ' 'End Sub Public Sub CreatePDF(ByVal param As String) Dim fnam As String Dim ProcName As String Dim ShellString As String If cFg = True Then Exit Sub 'YBNO 29508 ito 20151225 'If param = 2 Then If param = 2 Or param = 9 Then ProcName = "雇用資格喪失移行" 'YBNO 29508 ito 20151210 'ElseIf param = 3 Then ElseIf param = 3 Or param = 6 Then ProcName = "雇用資格喪失" Else Exit Sub End If fnam = ThisWorkbook.Path & "\pdf\" & ProcName & "\" & Trim(Cells(10, 4).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF" If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then MkDir (ThisWorkbook.Path & "\pdf") End If If Dir(ThisWorkbook.Path & "\pdf\" & ProcName, vbDirectory) = "" Then MkDir (ThisWorkbook.Path & "\pdf\" & ProcName) End If 'YBNO 29508 ito 20151225 'If param = 2 Then If param = 2 Or param = 9 Then pdf作成移行処理 fnam, pFg 'YBNO 29508 ito 20151210 'ElseIf param = 3 Then ElseIf param = 3 Or param = 6 Then pdf作成 fnam, pFg End If ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, ProcName) & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """" ExecCmd ShellString End Sub ''' END 24664 Sub 新様式4号へ() Dim wb As Workbook Dim Yousi As String Dim fnam As String 'YBNO 29508 ito 20151214 'If Cells(1, 1).Value = "" Then ' MsgBox "被保険者を選択してから実行してください。", 16, AAA ' Exit Sub 'End If 'If Cells(1, 12).Value = 1 Then Yousi = "雇用保険資格喪失届4号H2202.xls" 'If Cells(1, 12).Value = 2 Then Yousi = "雇用保険資格喪失届4号.xls" ''20110502 kon ' 'If Cells(1, 12).Value = 3 Then frmPrint.Show vbModeless ''' #24664 ' frmPrint.Show ' If cFg = True Then ' Exit Sub ' End If ' ' If Len(Cells(11, 30).Value) > 20 Then ' MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格取得届印刷" ' End If ' ' fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失移行\" & Trim(Cells(10, 4).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 = 2 ' ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失移行") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """" ' ' ExecCmd ShellString ' ' ' Application.ScreenUpdating = True ''' END #24664 Exit Sub 'End If 'YBNO 29508 ito 20151214　コメントに For Each wb In Workbooks If wb.Name = Yousi Then wb.Activate Exit Sub End If Next Application.ScreenUpdating = False Workbooks.Open ThisWorkbook.Path & "\" & Yousi If Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value <> 2010 Then Application.Run "DaAddin.xla!モジュール入替2010", Yousi End If ActiveWindow.DisplayWorkbookTabs = False Sheets("雇保喪失届").Select With ThisWorkbook.Worksheets("雇保喪失届") Range("B2:AD31").Value = .Range("B2:AD31").Value2 Cells(6, 7).Value = IIf(.Cells(6, 7).Value = 2, 0, 1) Range("H25").Value = .Range("H25").Text Range("I25").Value = .Range("I25").Text End With Application.ScreenUpdating = True End Sub Sub 離職票印刷シートへ() Dim wb As Workbook Dim i As Integer Dim n As Integer For Each wb In Workbooks If wb.Name = "離職票印刷シート.xls" Then wb.Activate Exit Sub End If Next Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Workbooks.Open ThisWorkbook.Path & "\離職票印刷シート.xls" '20101028masa 2010問題　閉じるボタンを張り付ける Application.ScreenUpdating = False If Workbooks("離職票印刷シート.xls").BuiltinDocumentProperties("Keywords").Value <> 2010 Then Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls" Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu13").Copy Workbooks("離職票印刷シート.xls").Activate ActiveSheet.Unprotect Range("A1").Select DoEvents ActiveSheet.Paste ActiveSheet.Shapes("Zu13").Top = 10 ActiveSheet.Shapes("Zu13").Left = 306 Range("A1").Select Workbooks("離職票印刷シート.xls").BuiltinDocumentProperties("Keywords").Value = 2010 Application.EnableEvents = False ActiveWorkbook.Save Application.EnableEvents = True Workbooks("閉じるボタン.xls").Close False End If Application.ScreenUpdating = True ActiveWindow.DisplayWorkbookTabs = False Sheets("離職票").Select With ThisWorkbook.Worksheets("離職票") n = 1 For i = 20 To 32 Step 4 Cells(3, i).Value = Mid(Format(.Cells(5, 6).Value, "0000"), n, 1) n = n + 1 Next n = 1 For i = 41 To 61 Step 4 Cells(3, i).Value = Mid(Format(.Cells(5, 11).Value, "000000"), n, 1) n = n + 1 Next Cells(3, 69).Value = .Cells(5, 18).Value n = 1 For i = 20 To 32 Step 4 Cells(5, i).Value = Mid(Format(.Cells(6, 6).Value, "0000"), n, 1) n = n + 1 Next n = 1 For i = 41 To 61 Step 4 Cells(5, i).Value = Mid(Format(.Cells(6, 11).Value, "000000"), n, 1) n = n + 1 Next '20090619 kon ' Cells(5, 69).Value = .Cells(5, 18).Value Cells(5, 69).Value = .Cells(6, 18).Value Cells(3, 90).Value = .Cells(5, 23).Value Cells(5, 90).Value = .Cells(6, 23).Value Cells(4, 106).Value = .Cells(5, 30).Value Cells(4, 109).Value = .Cells(5, 32).Value Cells(4, 110).Value = .Cells(5, 33).Value Cells(7, 101).Value = .Cells(7, 26).Value Cells(8, 101).Value = .Cells(8, 26).Value Cells(10, 104).Value = .Cells(9, 28).Value Cells(7, 22).Value = .Cells(7, 6).Value Cells(9, 22).Value = .Cells(8, 6).Value Cells(10, 22).Value = .Cells(9, 6).Value For i = 12 To 14 Cells(i, 22).Value = .Cells(i - 2, 6).Value Next Cells(16, 24).Value = .Cells(16, 6).Value Cells(16, 29).Value = .Cells(16, 8).Value For i = 17 To 29 Cells(i, 1).Value = .Cells(i, 2).Value Cells(i, 11).Value = .Cells(i, 4).Value If i > 17 Then Cells(i, 21).Value = .Cells(i, 6).Value If i > 17 Then Cells(i, 29).Value = .Cells(i, 8).Value If i > 17 Then Cells(i, 37).Value = .Cells(i, 11).Value Cells(i, 46).Value = .Cells(i, 13).Value Cells(i, 54).Value = .Cells(i, 15).Value Cells(i, 62).Value = .Cells(i, 17).Value If i > 17 Then Cells(i, 72).Value = .Cells(i, 19).Value If i > 17 Then Cells(i, 80).Value = .Cells(i, 21).Value Cells(i, 88).Value = .Cells(i, 23).Value Cells(i, 97).Value = .Cells(i, 25).Value Cells(i, 100).Value = .Cells(i, 26).Value Cells(i, 104).Value = .Cells(i, 28).Value Cells(i, 108).Value = .Cells(i, 31).Value Next Cells(31, 19).Value = .Cells(30, 5).Value Cells(33, 113).Value = .Cells(35, 2).Value Application.Calculation = xlCalculationAutomatic End With Application.ScreenUpdating = True End Sub Sub サンプルデータ() Dim i As Integer If MsgBox("印字設定用のサンプルデータを表示しますか？", 4 + 32, "サンプル") <> 6 Then Exit Sub Application.Calculation = xlCalculationManual For i = 20 To 32 Step 4 Cells(3, i).Value = 9 Next For i = 41 To 61 Step 4 Cells(3, i).Value = 9 Next Cells(3, 69).Value = 9 For i = 20 To 32 Step 4 Cells(5, i).Value = 9 Next For i = 41 To 61 Step 4 Cells(5, i).Value = 9 Next Cells(5, 69).Value = 9 Cells(3, 90).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(5, 90).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(4, 106).Value = 99 Cells(4, 109).Value = 99 Cells(4, 110).Value = 99 Cells(7, 101).Value = "999-9999" Cells(8, 101).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(10, 104).Value = "0999-99-9999" Cells(7, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(9, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(10, 22).Value = "0999-99-9999" For i = 12 To 14 Cells(i, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Next Cells(16, 24).Value = 99 Cells(16, 29).Value = 99 For i = 17 To 29 Cells(i, 1).Value = 99 Cells(i, 11).Value = 99 If i > 17 Then Cells(i, 21).Value = 99 If i > 17 Then Cells(i, 29).Value = 99 If i > 17 Then Cells(i, 37).Value = 99 Cells(i, 46).Value = 99 Cells(i, 54).Value = 99 Cells(i, 62).Value = 99 If i > 17 Then Cells(i, 72).Value = 99 If i > 17 Then Cells(i, 80).Value = 99 Cells(i, 88).Value = 99 Cells(i, 97).Value = 9999999 Cells(i, 100).Value = 9999999 Cells(i, 104).Value = 9999999 Cells(i, 108).Value = "ＸＸＸＸＸ" Next Cells(31, 19).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Cells(33, 113).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ" Application.Calculation = xlCalculationAutomatic MsgBox "OK", 64, "離職票" End Sub Public Sub eGovへ() '''23913 If ThisWorkbook.Worksheets("雇保喪失届").Cells(8, 4).Value = vbNullString Then MsgBox "雇用保険番号が入力されていません。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If If ActiveSheet.Name = "離職票" Then '#25345 'YBNO 29508 ito 20151225　201601新様式対応 'If Worksheets("雇保喪失届").Cells(25, 8).Value = vbNullString Or Worksheets("雇保喪失届").Cells(25, 9).Value = vbNullString Then If Worksheets("雇保喪失届").Cells(12, 32).Value = vbNullString Or Worksheets("雇保喪失届").Cells(12, 33).Value = vbNullString Then MsgBox "週所定労働時間を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If 'YBNO 29508 ito 20151225　201601新様式対応 'If Worksheets("雇保喪失届").Cells(25, 8).Value < 20 Then If Worksheets("雇保喪失届").Cells(12, 32).Value < 20 Then MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If 'YBNO 29508 ito 20151225　201601新様式対応 'If Worksheets("雇保喪失届").Cells(25, 9).Value > 59 And Worksheets("雇保喪失届").Cells(25, 9).Value < 0 Then If Worksheets("雇保喪失届").Cells(12, 33).Value > 59 And Worksheets("雇保喪失届").Cells(12, 33).Value < 0 Then MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If eGov離.Show vbModeless Else 'eGov.Show If Cells(3, 11).Value = "氏名変更届" Then Dim wb As Workbook For Each wb In Workbooks If wb.Name = "雇用氏名変更.xls" Then wb.Activate Exit Sub End If Next Workbooks.Open ThisWorkbook.Path & "\eGov\雇用氏名変更.xls" Workbooks("雇用氏名変更.xls").Activate Worksheets("DATA").Cells(1, 1).Value = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value Application.Run ActiveWorkbook.Name & "!初期処理" Else '#25345 'YBNO 29508 ito 20151225　201601新様式対応 'If Cells(25, 8).Value = vbNullString Or Cells(25, 9).Value = vbNullString Then If Cells(12, 32).Value = vbNullString Or Cells(12, 33).Value = vbNullString Then MsgBox "週所定労働時間を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If 'YBNO 29508 ito 20151225　201601新様式対応 'If Cells(25, 8).Value < 20 Then If Cells(12, 32).Value < 20 Then MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If 'YBNO 29508 ito 20151225　201601新様式対応 'If Cells(25, 9).Value > 59 And Cells(25, 9).Value < 0 Then If Cells(12, 33).Value > 59 And Cells(12, 33).Value < 0 Then MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請" Exit Sub End If '#25345 Application.Run "EAppCom.xla!eGovFormShow", 2, "雇用喪失.xls", "雇喪失XMLデータ作成.xls", ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value End If End If End Sub '20110502 kon Private Sub pdf作成移行処理(ByVal fn As String, PrintMode As Boolean) '必要データ作成 Dim TextFilename As String TextFilename = fn Dim SheetName As String SheetName = "雇保喪失届" With Worksheets(SheetName) Open TextFilename For Output As #1 Dim strData As String Dim iCounter As Integer Dim jCounter As Integer 'パスワードは利用しないので空欄 Print #1, "" '帳票種別 Print #1, IIf(.Cells(6, 7).Text = 2, "0", "1") '被保険者番号 4 For jCounter = 1 To 4 If jCounter = 1 Then strData = Mid(.Cells(8, 4).Text, jCounter, 1) Else strData = strData & vbTab & Mid(.Cells(8, 4).Text, jCounter, 1) End If Next jCounter Print #1, strData '被保険者番号 6 For jCounter = 6 To 11 If jCounter = 6 Then strData = Mid(.Cells(8, 4).Text, jCounter, 1) Else strData = strData & vbTab & Mid(.Cells(8, 4).Text, jCounter, 1) End If Next jCounter Print #1, strData '被保険者番号 1 Print #1, Right(.Cells(8, 4).Text, 1) '事業所番号 4 For jCounter = 1 To 4 If jCounter = 1 Then strData = Mid(.Cells(8, 12).Text, jCounter, 1) Else strData = strData & vbTab & Mid(.Cells(8, 12).Text, jCounter, 1) End If Next jCounter Print #1, strData '事業所番号 6 For jCounter = 6 To 11 If jCounter = 6 Then strData = Mid(.Cells(8, 12).Text, jCounter, 1) Else strData = strData & vbTab & Mid(.Cells(8, 12).Text, jCounter, 1) End If Next jCounter Print #1, strData '事業所番号 1 Print #1, Right(.Cells(8, 12).Text, 1) '取得年月日 Print #1, .Cells(8, 21).Text '離職年月日 For jCounter = 3 To 8 If jCounter = 3 Then strData = .Cells(16, jCounter).Text Else strData = strData & vbTab & .Cells(16, jCounter).Text End If Next jCounter Print #1, strData Print #1, .Cells(16, 10).Text '喪失原因 Print #1, .Cells(16, 19).Text '離職票交付希望 Print #1, .Cells(18, 3).Text '新氏名 'フリガナ For jCounter = 10 To 30 If jCounter = 10 Then strData = .Cells(18, jCounter).Text ElseIf jCounter >= 26 Then strData = strData & vbTab & .Cells(19, jCounter - 4).Text Else strData = strData & vbTab & .Cells(18, jCounter).Text End If Next jCounter Print #1, strData Print #1, .Cells(16, 24).Text '補充採用予定の有無 '変更前の氏名 If .Cells(6, 7).Text = 2 Then Print #1, .Cells(3, 30).Text '被保険者氏名フリガナ …

SHA-256: 38b88b3e3f45ec06aa8e3a165e0c447d5ef67a7e43795b757bcdb437b63d2c03

Preview script

First 1,000 lines of the extracted script

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 = "Sheet8"
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






Dim CBox As Object
Dim objITEM As Object

'Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)
'
'End Sub
'
'Private Sub Worksheet_Activate()
'    WebBrowser1.Navigate "J:\eGov\ツール\ＸＳＬ\離職票aaa\495000020289029832_01.xml"
'    WebBrowser1.Document.parentWindow.scrollTo 400, 0
'
'    ActiveSheet.WebBrowser1.Document.parentWindow.scrollTo 400, 0
'    WebScrolRight
'End Sub
'''' 20100407 笹原 縦バー内のサイトを表示したときに最初から右にスクロールする
'Private Sub WebWindow_DocumentComplete(ByVal pDisp As Object, URL As Variant)
'    WebScrolRight
'End Sub
'Private Sub WebScrolRight()
'
'    Dim objDoc As Object
'
'Set objDoc = WebBrowser1.Document.parentWindow
'
'    objDoc.scrollTo 400, 0
'
'    Set objDoc = Nothing
'
'End Sub
''' 20100407 笹原 End
Sub 適用()
    ThisWorkbook.Activate
    
    Application.Calculation = xlCalculationManual
    
    With WebBrowser1.Document.Forms(0)
        
        Set CBox = .item("J80_選択1_1")
        チェックボックス CBox, 438
        Set CBox = .item("J82_選択2_1")
        チェックボックス CBox, 440
        Set CBox = .item("J83_選択2_2")
        チェックボックス CBox, 441
        Set CBox = .item("J85_選択2_4")
        チェックボックス CBox, 442
        Set CBox = .item("J86_選択2_5")
        チェックボックス CBox, 443
        Set CBox = .item("J87_選択3_1")
        チェックボックス CBox, 444
        Set CBox = .item("J88_選択3_2")
        チェックボックス CBox, 445
        Set CBox = .item("J89_選択3_3_1")
        チェックボックス CBox, 446
        Set CBox = .item("J90_選択3_3_2")
        チェックボックス CBox, 447
        Set CBox = .item("J91_選択4_1_1")
        チェックボックス CBox, 448
        Set CBox = .item("J98_選択5")
        チェックボックス CBox, 449
        Set CBox = .item("J97_選択4_2")
        チェックボックス CBox, 450
        Set CBox = .item("J92_選択4_1_2")
        チェックボックス CBox, 451
        Set CBox = .item("J93_選択4_1_3")
        チェックボックス CBox, 452
        Set CBox = .item("J94_選択4_1_4")
        チェックボックス CBox, 453
        Set CBox = .item("J95_選択4_1_5")
        チェックボックス CBox, 454
        Set CBox = .item("J96_選択4_1_6")
        チェックボックス CBox, 455
        Set CBox = .item("J84_選択2_3")
        チェックボックス CBox, 456
        

        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(458, 2).Value = .item("J_定年").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(461, 2).Value = .item("J_箇月1").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(462, 2).Value = .item("J_箇月2").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(468, 2).Value = .item("J_箇月3").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(469, 2).Value = .item("J_箇月4").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(463, 2).Value = .item("J_回数1").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(470, 2).Value = .item("J_回数2").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(476, 2).Value = .item("J_理由1").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(480, 2).Value = .item("J_理由2").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(482, 2).Value = .item("J_理由3").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(479, 2).Value = .item("J_所在地").Value
        Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(487, 2).Value = .item("J_署名").Value
        
        For Each objITEM In ActiveSheet.WebBrowser1.Document.all
            If objITEM.tagName = "INPUT" Then
                ラジオボタン "J100_派遣労働者の選択", 460
                ラジオボタン "J104_常用労働者以外_契約更新する_確約合意の有無", 464
                ラジオボタン "J105_常用労働者以外_契約更新しない_明示の有無", 465
                ラジオボタン "J106_常用労働者以外_労働者_契約更新希望申出の有無", 466
                ラジオボタン "J107_常用労働者以外_適用基準に該当する派遣就業指示の選択", 467
                ラジオボタン "J111_常用労働者_契約更新する_確約合意の有無", 471
                ラジオボタン "J112_常用労働者_契約更新しない_明示の有無", 472
                ラジオボタン "J113_常用労働者_契約更新時に雇止め通知の有無", 473
                ラジオボタン "J114_常用労働者_労働者_契約更新希望申出の有無", 474
                ラジオボタン "J116_職種転換等に適応困難_教育訓練の有無", 478
                ラジオボタン "J121_離職理由に異議の有無", 486
                
             End If
        Next
    
    End With
    
    Application.Calculation = xlCalculationAutomatic

End Sub
Function チェックボックス(CBox As Object, R As Long)

    With Workbooks("雇用喪失離職票.xls").Worksheets("離職")
        If CBox.Checked = True Then
           .Cells(R, 2).Value = 1
           Else
            .Cells(R, 2).ClearContents
        End If
    End With
    
    Set CBox = Nothing
    
End Function
Function ラジオボタン(Rajio As String, R As Long)

    If objITEM.Name = Rajio And objITEM.Checked = True Then
       Workbooks("雇用喪失離職票.xls").Worksheets("離職").Cells(R, 2).Value = objITEM.Value
   End If
       
End Function
Function テキスト(ttt As String, R As Long)

        With Workbooks("雇用喪失離職票.xls").Worksheets("離職")
            .Cells(R, 2).Value = WebBrowser1.Document.Forms(0).item(ttt).Value
        End With
       
End Function


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


Attribute VB_Name = "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 = "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)
    Application.Calculation = xlAutomatic
    ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    MsgBox "このファイルは保存できません。", 16, AAA
    Cancel = True
End Sub



Attribute VB_Name = "Module11"
'修正履歴
'離職票印刷で事業所番号の下1ケタが被保険者番号の下1ケタを持ってきていた　20090619 kon
'201101用紙追加　20110506 kon
'事務組合の場合の事業所名称の修正　20110725  kon
'事務所情報の表示非表示がおかしい　20110823 kon
'以降用紙の印刷がおかしい。　Eno 11988 20111209 kon

Option Explicit
Public Const PROC_NAME As String = "雇用保険資格喪失届"
Public Const AAA As String = "雇用保険資格喪失届"
'20110506 kon
Public pFg      As Boolean
Public cFg       As Boolean
Public cDat(3)         As String
Public hFg As Boolean
Public jfg As Boolean
    

'20110506 kon
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type
'20110506 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
'20110506 kon
Private Const NORMAL_PRIORITY_CLASS = &H20&
'20110506 kon
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
'20110506 kon
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
'20110927 余白設定
Public Tmargin As Double
Public Lmargin As Double
Public hName As String
Public huki As Integer
'関数
Sub OpenFile(fName As String)
    '関連付いたアプリケーションで立ち上げる
    Call ShellExecute(0, "open", ThisWorkbook.Path & "\" & fName, vbNullString, vbNullString, 1)
End Sub
Sub A保存()
    ActiveWindow.DisplayWorkbookTabs = False
    Application.EnableEvents = False
    ThisWorkbook.Save
    Application.EnableEvents = True
End Sub
Sub 日数と賃金へ()
    Dim da As String
    da = Worksheets("DATA").Cells(1, 1).Value '読み込まれた台帳ファイル名
    If Cells(1, 1).Value = 0 Then
        MsgBox "資格喪失届を作成してから実行してください。", 16, AAA
        Exit Sub
    End If
    If Cells(6, 23).Value <> "" And Cells(6, 23).Value <> Worksheets("雇保喪失届").Cells(10, 4).Value Then
        MsgBox "保存データから読込まれたデータのためこの操作を実行できません。" & Chr(10) & " 編集は直接シート上でおこなって下さい。", 16, AAA
        Exit Sub
    End If
    With Workbooks(da).Worksheets("個人情報")
        If IsDate(.Cells(Cells(1, 1), 30).Value) = False Then
            MsgBox "資格喪失届で選択されている被保険者の離職年月日が不正又は登録されていないため実行できません。", 16, AAA
            Exit Sub
        End If
        If IsDate(.Cells(Cells(1, 1), 29).Value) = False Then
            MsgBox "資格喪失届で選択されている被保険者の取得年月日が不正又は登録されていないため実行できません。（賃金対象期間の算出に必要です。）", 16, AAA
            Exit Sub
        End If
        '電子申請の場合、退職されるかたの電話番号が必須なので、メッセージを出す。
'20140714 kon 25688
'        If IsEmpty(.Cells(Cells(1, 1), 33).Value) Then
        
        If .Cells(Cells(1, 1), 33).Value = "" Then
            If MsgBox("被保険者の電話番号が登録されていません。電子申請する場合、被保険者の電話番号は必須です。" & vbCrLf & "続けますか。", vbQuestion + vbYesNo, AAA) = vbNo Then Exit Sub
        End If
    End With
    
    日数と賃金.Show
End Sub
Sub 印刷()
    If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
    ActiveSheet.PrintOut
End Sub
Sub 戻る()
    '20100906 kon
    ThisWorkbook.Activate
    Application.Run "DaAddin.xla!閉じる"
'ThisWorkbook.Close False
End Sub
Sub 喪失届()
    Sheets("雇保喪失届").Select
    Cells(5, 1).Select
End Sub
Sub 会社Fへ()
    Application.Run "DaAddin.xla!会社Fへ"
End Sub
Sub 給与Fへ()
    Application.Run "DaAddin.xla!給与Fへ"
End Sub
Sub 個人Fへ()
    Application.Run "DaAddin.xla!個人Fへ"
End Sub
Sub Da保存へ()
    Open Workbooks("DaMenu.xls").Path & "\HozonName.dat" For Output As #1
        If ActiveSheet.Name = "離職票" Then
            Write #1, Cells(6, 23).Value & " " & Cells(5, 30).Value & "年" & Cells(5, 32).Value & "月" & Cells(5, 33).Value & "日" & "離職"
        Else
            Write #1, Cells(10, 4).Value & " " & Cells(16, 30).Value
        End If
    Close #1
    
    'YBNO 29734  ito 20151216　保存時マイナンバークリア
    'Application.Run "DaAddin.xla!Da保存へ"
    If ActiveSheet.Name = "雇保喪失届" Then
        Application.Run "DaAddin.xla!Da保存へ", "C20:N20,AD9"
    Else
        Application.Run "DaAddin.xla!Da保存へ", vbNullString
    End If
End Sub
Sub Da保存読込へ()
    Da保存読込.Show
End Sub
Sub Da保存読込喪失へ()
    Application.Run "DaAddin.xla!Da保存読込へ"
End Sub
Sub OpenManual()
    'YBNO 29726  ito 201602
    'Worksheets("HELP").Cells(1, 30).Value = ActiveSheet.Name
    'Sheets("HELP").Select
    Application.Run "DaAddin.xla!OpenManual"
End Sub
Sub マニュアル戻る()
    Sheets(Cells(1, 30).Value).Select
End Sub
Sub 選択へ()
    選択.Show
End Sub
Sub 初期処理()
    選択へ
End Sub
Sub 保存へ()
    Application.Run "DaAddin.xla!Da保存へ"
End Sub
Sub 保存読込へ()
    Application.Run "DaAddin.xla!Da保存読込へ"
End Sub
Sub 離職票へ()
    If Cells(3, 11) <> "資格喪失届" Then
        MsgBox "資格喪失届を選択してください。", vbInformation + vbOKOnly, AAA
        Exit Sub
    Else
        Sheets("離職票").Select
    End If
End Sub
Sub 保護の解除()
    ActiveSheet.Unprotect
    MsgBox "保護を解除しました", 64, AAA
End Sub
'20110506 kon
Public Function PathCombine(ByVal path1 As String, ByVal path2 As String) As String

    If Right(path1, 1) = "\" Then
        PathCombine = path1 & path2
    Else
        PathCombine = path1 & "\" & path2
    End If
End Function

Sub 印刷シートへ()
    Dim Yousi As String
    Dim Button As String
    Dim wb As Object
'    Dim fnam As String
    
'YBNO 29508  ito 20151210　旧様式廃止
'    If Cells(1, 12).Value = 1 Then
'        Yousi = "雇用保険資格喪失届印刷シートH2202.xls"
'        Button = "Zu5"
'    End If
'    If Cells(1, 12).Value = 2 Then
'        Yousi = "雇用保険資格喪失届印刷シート.xls"
'        Button = "Zu4"
'    End If
'
'    If Cells(1, 12).Value = 3 Then
'        ''' YBNO 22048 20130515
'        frmPrint喪失.Show vbModeless
''        frmPrint喪失.Show
''        If cFg = True Then
''            Exit Sub
''        End If
''
''        If Len(Cells(11, 30).Value) > 20 Then
''            MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格取得届印刷"
''        End If
''
''        fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失\" & Trim(Cells(10, 4).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 = 3
''
''        ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"
''
''        ExecCmd ShellString
''
''
''        Application.ScreenUpdating = True
'        Exit Sub
'    End If
    frmPrint喪失.Show vbModeless
    Exit Sub
    
    For Each wb In Workbooks
        If wb.Name = Yousi Then
            wb.Activate
            Exit Sub
        End If
    Next
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & Yousi
    
    '20101028masa 2010問題　閉じるボタンを張り付ける
    Application.ScreenUpdating = False
    If Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes(Button).Copy
        Workbooks(Yousi).Activate
        Range("A1").Select
        ActiveSheet.Paste
        ActiveSheet.Shapes(Button).Top = 7
        ActiveSheet.Shapes(Button).Left = 256
        Range("A1").Select
        Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value = 2010
        Application.EnableEvents = False
        ActiveWorkbook.Save
        Application.EnableEvents = True
        Workbooks("閉じるボタン.xls").Close False
    End If
    
    '''20101108 印刷シートの初期処理が呼ばれない
    Application.Run Yousi & "!初期処理"
    ''' END 20101108 印刷シートの初期処理が呼ばれない
    
    Application.ScreenUpdating = True
End Sub
''' #24664
'Sub CreatePDF()
'
'    Dim fnam As String
'
'    If cFg = True Then
'        Exit Sub
'    End If
'
'''' #24675
''    If Len(Cells(11, 30).Value) > 20 Then
''        MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格喪失届印刷"
''    End If
'
'    fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失\" & Trim(Cells(10, 4).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 = 3
'
'    ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"
'
'    ExecCmd ShellString
'
'End Sub
Public Sub CreatePDF(ByVal param As String)

    Dim fnam As String
    Dim ProcName As String
    Dim ShellString As String

    If cFg = True Then Exit Sub
    
    'YBNO 29508  ito 20151225
    'If param = 2 Then
    If param = 2 Or param = 9 Then
        ProcName = "雇用資格喪失移行"
    'YBNO 29508  ito 20151210
    'ElseIf param = 3 Then
    ElseIf param = 3 Or param = 6 Then
        ProcName = "雇用資格喪失"
    Else
        Exit Sub
    End If

    fnam = ThisWorkbook.Path & "\pdf\" & ProcName & "\" & Trim(Cells(10, 4).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF"
    
    If Dir(ThisWorkbook.Path & "\pdf", vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf")
    End If
    If Dir(ThisWorkbook.Path & "\pdf\" & ProcName, vbDirectory) = "" Then
        MkDir (ThisWorkbook.Path & "\pdf\" & ProcName)
    End If
    
    'YBNO 29508  ito 20151225
    'If param = 2 Then
    If param = 2 Or param = 9 Then
        pdf作成移行処理 fnam, pFg
    'YBNO 29508  ito 20151210
    'ElseIf param = 3 Then
    ElseIf param = 3 Or param = 6 Then
        pdf作成 fnam, pFg
    End If
    
    ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, ProcName) & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"

    ExecCmd ShellString

End Sub
''' END 24664
Sub 新様式4号へ()
    Dim wb As Workbook
    Dim Yousi As String
    Dim fnam As String
    
    'YBNO 29508  ito 20151214
    'If Cells(1, 1).Value = "" Then
    '    MsgBox "被保険者を選択してから実行してください。", 16, AAA
    '    Exit Sub
    'End If
    'If Cells(1, 12).Value = 1 Then Yousi = "雇用保険資格喪失届4号H2202.xls"
    'If Cells(1, 12).Value = 2 Then Yousi = "雇用保険資格喪失届4号.xls"
    ''20110502 kon
    '
    'If Cells(1, 12).Value = 3 Then
        frmPrint.Show vbModeless
        
''' #24664
'        frmPrint.Show
'        If cFg = True Then
'            Exit Sub
'        End If
'
'        If Len(Cells(11, 30).Value) > 20 Then
'            MsgBox "被保険者氏名カナが表示範囲を超えています。20文字まで表示します。（半角ｶﾅ20文字まで）", vbInformation, "資格取得届印刷"
'        End If
'
'        fnam = ThisWorkbook.Path & "\pdf\雇用資格喪失移行\" & Trim(Cells(10, 4).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 = 2
'        ShellString = """" & PathCombine(ThisWorkbook.Path, "雇用保険役所用紙.exe") & """ """ & PathCombine(GetProgramFolder, "雇用資格喪失移行") & """ """ & fnam & """ """ & param & """ """ & pFg & """ """ & Tmargin & """ """ & Lmargin & """"
'
'        ExecCmd ShellString
'
'
'        Application.ScreenUpdating = True
''' END #24664
        Exit Sub
    'End If 'YBNO 29508  ito 20151214　 コメントに
    
    For Each wb In Workbooks
        If wb.Name = Yousi Then
            wb.Activate
            Exit Sub
        End If
    Next
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\" & Yousi
    If Workbooks(Yousi).BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Application.Run "DaAddin.xla!モジュール入替2010", Yousi
    End If
    
    ActiveWindow.DisplayWorkbookTabs = False
    Sheets("雇保喪失届").Select
    With ThisWorkbook.Worksheets("雇保喪失届")
        Range("B2:AD31").Value = .Range("B2:AD31").Value2
        Cells(6, 7).Value = IIf(.Cells(6, 7).Value = 2, 0, 1)
        Range("H25").Value = .Range("H25").Text
        Range("I25").Value = .Range("I25").Text
    End With
    Application.ScreenUpdating = True
End Sub


Sub 離職票印刷シートへ()
    Dim wb As Workbook
    Dim i As Integer
    Dim n As Integer
    For Each wb In Workbooks
        If wb.Name = "離職票印刷シート.xls" Then
            wb.Activate
            Exit Sub
        End If
    Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Workbooks.Open ThisWorkbook.Path & "\離職票印刷シート.xls"
    '20101028masa 2010問題　閉じるボタンを張り付ける
        Application.ScreenUpdating = False
        If Workbooks("離職票印刷シート.xls").BuiltinDocumentProperties("Keywords").Value <> 2010 Then
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\閉じるボタン.xls"
        Workbooks("閉じるボタン.xls").Worksheets("Button").Shapes("Zu13").Copy
        Workbooks("離職票印刷シート.xls").Activate
        ActiveSheet.Unprotect
        Range("A1").Select
        DoEvents
        ActiveSheet.Paste
        ActiveSheet.Shapes("Zu13").Top = 10
        ActiveSheet.Shapes("Zu13").Left = 306
        Range("A1").Select
        Workbooks("離職票印刷シート.xls").BuiltinDocumentProperties("Keywords").Value = 2010
        Application.EnableEvents = False
        ActiveWorkbook.Save
        Application.EnableEvents = True
        Workbooks("閉じるボタン.xls").Close False
    End If
    Application.ScreenUpdating = True
    ActiveWindow.DisplayWorkbookTabs = False
    Sheets("離職票").Select
    With ThisWorkbook.Worksheets("離職票")
        n = 1
        For i = 20 To 32 Step 4
            Cells(3, i).Value = Mid(Format(.Cells(5, 6).Value, "0000"), n, 1)
            n = n + 1
        Next
        n = 1
        For i = 41 To 61 Step 4
            Cells(3, i).Value = Mid(Format(.Cells(5, 11).Value, "000000"), n, 1)
            n = n + 1
        Next
        Cells(3, 69).Value = .Cells(5, 18).Value
        n = 1
        For i = 20 To 32 Step 4
            Cells(5, i).Value = Mid(Format(.Cells(6, 6).Value, "0000"), n, 1)
            n = n + 1
        Next
        n = 1
        For i = 41 To 61 Step 4
            Cells(5, i).Value = Mid(Format(.Cells(6, 11).Value, "000000"), n, 1)
            n = n + 1
        Next
'20090619 kon
'        Cells(5, 69).Value = .Cells(5, 18).Value
        Cells(5, 69).Value = .Cells(6, 18).Value
        
        Cells(3, 90).Value = .Cells(5, 23).Value
        Cells(5, 90).Value = .Cells(6, 23).Value
        Cells(4, 106).Value = .Cells(5, 30).Value
        Cells(4, 109).Value = .Cells(5, 32).Value
        Cells(4, 110).Value = .Cells(5, 33).Value
        Cells(7, 101).Value = .Cells(7, 26).Value
        Cells(8, 101).Value = .Cells(8, 26).Value
        Cells(10, 104).Value = .Cells(9, 28).Value
        Cells(7, 22).Value = .Cells(7, 6).Value
        Cells(9, 22).Value = .Cells(8, 6).Value
        Cells(10, 22).Value = .Cells(9, 6).Value
        For i = 12 To 14
            Cells(i, 22).Value = .Cells(i - 2, 6).Value
        Next
        Cells(16, 24).Value = .Cells(16, 6).Value
        Cells(16, 29).Value = .Cells(16, 8).Value
        For i = 17 To 29
            Cells(i, 1).Value = .Cells(i, 2).Value
            Cells(i, 11).Value = .Cells(i, 4).Value
            If i > 17 Then Cells(i, 21).Value = .Cells(i, 6).Value
            If i > 17 Then Cells(i, 29).Value = .Cells(i, 8).Value
            If i > 17 Then Cells(i, 37).Value = .Cells(i, 11).Value
            Cells(i, 46).Value = .Cells(i, 13).Value
            Cells(i, 54).Value = .Cells(i, 15).Value
            Cells(i, 62).Value = .Cells(i, 17).Value
            If i > 17 Then Cells(i, 72).Value = .Cells(i, 19).Value
            If i > 17 Then Cells(i, 80).Value = .Cells(i, 21).Value
            Cells(i, 88).Value = .Cells(i, 23).Value
            Cells(i, 97).Value = .Cells(i, 25).Value
            Cells(i, 100).Value = .Cells(i, 26).Value
            Cells(i, 104).Value = .Cells(i, 28).Value
            Cells(i, 108).Value = .Cells(i, 31).Value
        Next
        Cells(31, 19).Value = .Cells(30, 5).Value
        Cells(33, 113).Value = .Cells(35, 2).Value
        Application.Calculation = xlCalculationAutomatic
    End With
    Application.ScreenUpdating = True
End Sub

Sub サンプルデータ()
    Dim i As Integer
    If MsgBox("印字設定用のサンプルデータを表示しますか？", 4 + 32, "サンプル") <> 6 Then Exit Sub
    Application.Calculation = xlCalculationManual
    For i = 20 To 32 Step 4
        Cells(3, i).Value = 9
    Next
    For i = 41 To 61 Step 4
        Cells(3, i).Value = 9
    Next
    Cells(3, 69).Value = 9
    For i = 20 To 32 Step 4
        Cells(5, i).Value = 9
    Next
    For i = 41 To 61 Step 4
        Cells(5, i).Value = 9
    Next
    Cells(5, 69).Value = 9
    Cells(3, 90).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(5, 90).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(4, 106).Value = 99
    Cells(4, 109).Value = 99
    Cells(4, 110).Value = 99
    Cells(7, 101).Value = "999-9999"
    Cells(8, 101).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(10, 104).Value = "0999-99-9999"
    Cells(7, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(9, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(10, 22).Value = "0999-99-9999"
    For i = 12 To 14
        Cells(i, 22).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Next
    Cells(16, 24).Value = 99
    Cells(16, 29).Value = 99
    For i = 17 To 29
        Cells(i, 1).Value = 99
        Cells(i, 11).Value = 99
        If i > 17 Then Cells(i, 21).Value = 99
        If i > 17 Then Cells(i, 29).Value = 99
        If i > 17 Then Cells(i, 37).Value = 99
        Cells(i, 46).Value = 99
        Cells(i, 54).Value = 99
        Cells(i, 62).Value = 99
        If i > 17 Then Cells(i, 72).Value = 99
        If i > 17 Then Cells(i, 80).Value = 99
        Cells(i, 88).Value = 99
        Cells(i, 97).Value = 9999999
        Cells(i, 100).Value = 9999999
        Cells(i, 104).Value = 9999999
        Cells(i, 108).Value = "ＸＸＸＸＸ"
    Next
    Cells(31, 19).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Cells(33, 113).Value = "ＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸＸ"
    Application.Calculation = xlCalculationAutomatic
    MsgBox "OK", 64, "離職票"
End Sub

Public Sub eGovへ()
     
    '''23913
    If ThisWorkbook.Worksheets("雇保喪失届").Cells(8, 4).Value = vbNullString Then
        MsgBox "雇用保険番号が入力されていません。", vbInformation + vbOKOnly, "電子申請"
        Exit Sub
    End If
    
    If ActiveSheet.Name = "離職票" Then
        '#25345
        'YBNO 29508  ito 20151225　201601新様式対応
        'If Worksheets("雇保喪失届").Cells(25, 8).Value = vbNullString Or Worksheets("雇保喪失届").Cells(25, 9).Value = vbNullString Then
        If Worksheets("雇保喪失届").Cells(12, 32).Value = vbNullString Or Worksheets("雇保喪失届").Cells(12, 33).Value = vbNullString Then
            MsgBox "週所定労働時間を入力してください。", vbInformation + vbOKOnly, "電子申請"
            Exit Sub
        End If
        'YBNO 29508  ito 20151225　201601新様式対応
        'If Worksheets("雇保喪失届").Cells(25, 8).Value < 20 Then
        If Worksheets("雇保喪失届").Cells(12, 32).Value < 20 Then
            MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請"
            Exit Sub
        End If
        'YBNO 29508  ito 20151225　201601新様式対応
        'If Worksheets("雇保喪失届").Cells(25, 9).Value > 59 And Worksheets("雇保喪失届").Cells(25, 9).Value < 0 Then
        If Worksheets("雇保喪失届").Cells(12, 33).Value > 59 And Worksheets("雇保喪失届").Cells(12, 33).Value < 0 Then
            MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請"
            Exit Sub
        End If
        eGov離.Show vbModeless
    Else
        'eGov.Show
        If Cells(3, 11).Value = "氏名変更届" Then
            Dim wb As Workbook
            For Each wb In Workbooks
                If wb.Name = "雇用氏名変更.xls" Then
                    wb.Activate
                    Exit Sub
                End If
            Next
            Workbooks.Open ThisWorkbook.Path & "\eGov\雇用氏名変更.xls"
            Workbooks("雇用氏名変更.xls").Activate
            Worksheets("DATA").Cells(1, 1).Value = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value
            Application.Run ActiveWorkbook.Name & "!初期処理"
        Else
            '#25345
            'YBNO 29508  ito 20151225　201601新様式対応
            'If Cells(25, 8).Value = vbNullString Or Cells(25, 9).Value = vbNullString Then
            If Cells(12, 32).Value = vbNullString Or Cells(12, 33).Value = vbNullString Then
                MsgBox "週所定労働時間を入力してください。", vbInformation + vbOKOnly, "電子申請"
                Exit Sub
            End If
            'YBNO 29508  ito 20151225　201601新様式対応
            'If Cells(25, 8).Value < 20 Then
            If Cells(12, 32).Value < 20 Then
                MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請"
                Exit Sub
            End If
            'YBNO 29508  ito 20151225　201601新様式対応
            'If Cells(25, 9).Value > 59 And Cells(25, 9).Value < 0 Then
            If Cells(12, 33).Value > 59 And Cells(12, 33).Value < 0 Then
                MsgBox "週所定労働時間は20以上を入力してください。", vbInformation + vbOKOnly, "電子申請"
                Exit Sub
            End If
            '#25345
            Application.Run "EAppCom.xla!eGovFormShow", 2, "雇用喪失.xls", "雇喪失XMLデータ作成.xls", ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value
        End If
    End If
    
End Sub
'20110502 kon
Private Sub pdf作成移行処理(ByVal fn As String, PrintMode As Boolean)
    
    '必要データ作成
    Dim TextFilename As String
    TextFilename = fn
    
    Dim SheetName As String
    
    SheetName = "雇保喪失届"
    
    With Worksheets(SheetName)
        Open TextFilename For Output As #1

        Dim strData As String
        Dim iCounter As Integer
        Dim jCounter As Integer
        
        'パスワードは利用しないので空欄
        Print #1, ""
        '帳票種別
        Print #1, IIf(.Cells(6, 7).Text = 2, "0", "1")
        
        '被保険者番号 4
        For jCounter = 1 To 4
            If jCounter = 1 Then
                strData = Mid(.Cells(8, 4).Text, jCounter, 1)
            Else
                strData = strData & vbTab & Mid(.Cells(8, 4).Text, jCounter, 1)
            End If
        Next jCounter
        Print #1, strData
        '被保険者番号 6
        For jCounter = 6 To 11
            If jCounter = 6 Then
                strData = Mid(.Cells(8, 4).Text, jCounter, 1)
            Else
                strData = strData & vbTab & Mid(.Cells(8, 4).Text, jCounter, 1)
            End If
        Next jCounter
        Print #1, strData
        '被保険者番号 1
        Print #1, Right(.Cells(8, 4).Text, 1)
        '事業所番号 4
        For jCounter = 1 To 4
            If jCounter = 1 Then
                strData = Mid(.Cells(8, 12).Text, jCounter, 1)
            Else
                strData = strData & vbTab & Mid(.Cells(8, 12).Text, jCounter, 1)
            End If
        Next jCounter
        Print #1, strData
        '事業所番号 6
        For jCounter = 6 To 11
            If jCounter = 6 Then
                strData = Mid(.Cells(8, 12).Text, jCounter, 1)
            Else
                strData = strData & vbTab & Mid(.Cells(8, 12).Text, jCounter, 1)
            End If
        Next jCounter
        Print #1, strData
        '事業所番号 1
        Print #1, Right(.Cells(8, 12).Text, 1)
        
        '取得年月日
        Print #1, .Cells(8, 21).Text
        
        '離職年月日
        For jCounter = 3 To 8
            If jCounter = 3 Then
                strData = .Cells(16, jCounter).Text
            Else
                strData = strData & vbTab & .Cells(16, jCounter).Text
            End If
        Next jCounter
        Print #1, strData
        
        Print #1, .Cells(16, 10).Text '喪失原因
        Print #1, .Cells(16, 19).Text '離職票交付希望
        
        Print #1, .Cells(18, 3).Text '新氏名

        'フリガナ
        For jCounter = 10 To 30
            If jCounter = 10 Then
                strData = .Cells(18, jCounter).Text
            ElseIf jCounter >= 26 Then
                strData = strData & vbTab & .Cells(19, jCounter - 4).Text
            Else
                strData = strData & vbTab & .Cells(18, jCounter).Text
            End If
        Next jCounter
        
        Print #1, strData
        Print #1, .Cells(16, 24).Text '補充採用予定の有無
        '変更前の氏名
        If .Cells(6, 7).Text = 2 Then
            Print #1, .Cells(3, 30).Text '被保険者氏名フリガナ
…

Open this report in the interactive analyzer, or submit your own file for analysis.