MALICIOUS
142
Risk Score
Malware Insights
MITRE ATT&CK
T1059.005 Visual Basic
T1566.001 Spearphishing Attachment
T1071.001 Web Protocols
The sample is an Excel file containing VBA macros that reference CreateProcess and ShellExecute APIs, indicating potential execution of external processes. The document body presents a form for social insurance benefits, suggesting a phishing or social engineering lure to collect sensitive personal data. The embedded URL, while marked as unknown, is likely part of the malicious infrastructure.
Heuristics 5
-
Reference to CreateProcess API high SC_STR_CREATEPROCESSReference to CreateProcess API
-
Reference to ShellExecute API high SC_STR_SHELLEXECReference to ShellExecute API
-
VBA macros detected medium 1 related finding OLE_VBA_MACROSDocument contains VBA macro code
-
CreateObject call high OLE_VBA_CREATEOBJCreateObject callMatched line in script
Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") Dim n As Long -
Embedded URL info EMBEDDED_URLOne 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 https://www.cells.co.jp/daityo-s/wp-content/uploads/manual/sinkenkouhoken.pdf In document text (OLE body)
- 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) | 790690 bytes |
SHA-256: 88c4a9941c1b983db232e8651aeb98e09e2de8ba6cd7bd4166d2f65b4e5efd54 |
|||
Preview scriptFirst 1,000 lines of the extracted script
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 = "Sheet19"
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 = "印刷F"
Attribute VB_Base = "0{ED3F167F-A9A2-4573-A148-EEC3CFC0A6B9}{02342802-22A2-490C-9702-A92419527FA0}"
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 f As Integer '#28140 20150716 ishikawa
Private Sub UserForm_Initialize()
da = ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value '#36146 ito 20170130 追加
'余白設定のファイル名
hName = ThisWorkbook.Path & "\pdf\健康保険\" & ActiveSheet.Name & "\print.txt"
Dim j As Integer
Dim intFF As Integer ' FreeFile値
Dim setString(2) As Double
Dim strREC As String ' 読み込んだレコード内容
For j = 0 To 9
TxtTop.AddItem j
TxtLeft.AddItem j
Next j
If Dir(hName, vbNormal) <> "" Then
j = 0
intFF = FreeFile
Open hName For Input As intFF
Do Until EOF(intFF)
Line Input #intFF, strREC
setString(j) = IIf(Trim(strREC) = "", 0, strREC)
j = j + 1
Loop
Close #1
TxtTop.Value = setString(0) * 10 '上余白
TxtLeft.Value = setString(1) * 10 '左余白
Else
TxtTop.Value = 0 '上余白
TxtLeft.Value = 0 '左余白
End If
End Sub
Private Sub CommandButton1_Click()
'YB30405 清水
' If TxtTop.Text < 0 Then
' MsgBox "上余白は0から9までの数字で設定してください。"
' Exit Sub
' End If
' If TxtLeft.Text < 0 Then
' MsgBox "左余白は0から9までの数字で設定してください。"
' Exit Sub
' End If
'#36146 ito 20170202 追加 --------------------------------------------------------------------------------------------------------------------------------------------------------------
'●ログイン認証は印刷前に
If Cells(300, 19).Value <> vbNullString Then
If Application.Run("DaAddin.xla!MNMode", True, False) Then
If Not Application.Run("DaAddin.xla!CallLogin", Cells(1, 50).Value, Workbooks(da).Worksheets("会社情報")) Then Exit Sub
End If
ElseIf ActiveSheet.Name = "任意継続" Then
If Cells(73, 20).Value <> vbNullString Or Cells(78, 20).Value <> vbNullString Or Cells(83, 20).Value <> vbNullString Or Cells(88, 20).Value <> vbNullString Then
If Application.Run("DaAddin.xla!MNMode", True, False) Then
If Not Application.Run("DaAddin.xla!CallLogin", Cells(1, 50).Value, Workbooks(da).Worksheets("会社情報")) Then Exit Sub
End If
End If
End If
'#36146 ここまで -------------------------------------------------------------------------------------------------------------------------------------------------------------------------
If OptionButton1.Value = True Then
Call 現シート印刷
ElseIf OptionButton2.Value = True Then
Call 印刷へ(ActiveSheet.Name, False)
ElseIf OptionButton3.Value = True Then
Call 印刷へ(ActiveSheet.Name, True)
End If
'#36146 ito 20170130 追加 --------------------------------------------------------------------------------------------------------------------------------------------------------------
Dim i As Long
Dim guid As String
Dim ComAccount As String
'●被保険者
'個人番号があるときにログを作る ---------------------------------------------------------------------------------------------------------------
If Cells(300, 19).Value <> vbNullString Then
If Application.Run("DaAddin.xla!MNMode", True, False) Then
If Not Application.Run("DaAddin.xla!CallLogin", Cells(1, 50).Value, Workbooks(da).Worksheets("会社情報")) Then Exit Sub
guid = Cells(20, 50).Value
ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(da))
Application.Run "DaAddin.xla!ProcLogging", ComAccount, Cells(1, 50).Value, "印刷", vbNullString, guid, Cells(21, 50).Value, "成功"
End If
End If
'-----------------------------------------------------------------------------------------------------------------------------------------------
'●被扶養者
If ActiveSheet.Name = "任意継続" Then
'個人番号があるときにログを作る -----------------------------------------------------------------------------------------------------------------------------------
If Cells(73, 20).Value <> vbNullString Or Cells(78, 20).Value <> vbNullString Or Cells(83, 20).Value <> vbNullString Or Cells(88, 20).Value <> vbNullString Then
If Application.Run("DaAddin.xla!MNMode", True, False) Then
If Not Application.Run("DaAddin.xla!CallLogin", Cells(1, 50).Value, Workbooks(da).Worksheets("会社情報")) Then Exit Sub
For i = 1 To 4
guid = Cells(20 + i * 2, 50).Value
If Cells(68 + i * 5, 20).Value <> "" Then
ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(da))
Application.Run "DaAddin.xla!ProcLogging", ComAccount, Cells(1, 50).Value, "印刷", vbNullString, guid, Cells(21 + i * 2, 50).Value, "成功"
End If
Next
End If
End If
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------
End If
'#36146 ここまで -------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Unload Me
End Sub
Private Sub 現シート印刷()
DoEvents
ActiveSheet.PrintOut
DoEvents
End Sub
Sub 印刷へ(kenko, PMode)
Dim Yousi As String
Dim Button As String
Dim wb As Object
Dim fnam As String
fnam = ThisWorkbook.Path & "\pdf\健康保険\" & kenko & "\" & 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
If Dir(ThisWorkbook.Path & "\pdf\健康保険\" & kenko & "\", vbDirectory) = "" Then
MkDir (ThisWorkbook.Path & "\pdf\健康保険\" & kenko & "\")
End If
Call 様式印刷(fnam, kenko)
Dim ShellString As String
Dim param As String
Select Case kenko
Case "出産手当金"
param = 1
Case "療養費装具"
param = 2
Case "療養費立替払"
param = 3
Case "再交付申請書"
param = 4
Case "高額療養費"
param = 5
Case "傷病手当金"
param = 6
Case "限度額適用認定"
param = 7
Case "標準負担額"
param = 8
Case "任意継続"
param = 9
Case "高齢受給者証"
param = 10
Case "負傷原因"
param = 11
'-------------------------------------20141106 様式追加 ishikawa
Case "出産育児一時金"
param = 12
Case "内払差額"
param = 13
Case "埋葬料"
param = 14
Case "特定疾病"
param = 15
'-------------------------------------ここまで
End Select
Tmargin = IIf(Trim(TxtTop.Value) = "", 0, TxtTop.Value / 10) '上余白
Lmargin = IIf(Trim(TxtLeft.Value) = "", 0, TxtLeft.Value / 10) '左余白
ShellString = """" & PathCombine(ThisWorkbook.Path, "健康保険.exe") & """ """ & PathCombine(GetProgramFolder, "健康保険") & "\" & kenko & """ """ & fnam & """ """ & param & """ """ & PMode & """ """ & Tmargin & """ """ & Lmargin & """"
ExecCmd ShellString
Application.ScreenUpdating = True
Exit Sub
End Sub
Private Sub 様式印刷(TextFilename, yousiki)
Dim i As Long
Dim jCounter As Long
Dim MyStr As String
Dim MyTab As String
Dim TxtYohaku As String
'If MsgBox("印刷を開始します。", 4 + 32, "印刷") <> 6 Then Exit Sub '#36146 ito 20170201 必要ないのでコメントに
If ActiveSheet.Name = "出産手当金" Then
Call 出産手当金印刷(TextFilename)
End If
If ActiveSheet.Name = "療養費装具" Then
Call 療養費装具印刷(TextFilename)
End If
If ActiveSheet.Name = "療養費立替払" Then
Call 療養費立替払印刷(TextFilename)
End If
If ActiveSheet.Name = "再交付申請書" Then
Call 再交付申請書印刷(TextFilename)
End If
If ActiveSheet.Name = "高額療養費" Then
Call 高額療養費印刷(TextFilename)
End If
If ActiveSheet.Name = "傷病手当金" Then
Call 傷病手当金印刷(TextFilename)
End If
If ActiveSheet.Name = "限度額適用認定" Then
Call 限度額適用認定印刷(TextFilename)
End If
If ActiveSheet.Name = "標準負担額" Then
Call 標準負担額印刷(TextFilename)
End If
If ActiveSheet.Name = "任意継続" Then
Call 任意継続印刷(TextFilename)
End If
If ActiveSheet.Name = "高齢受給者証" Then
Call 高齢受給者証印刷(TextFilename)
End If
If ActiveSheet.Name = "負傷原因" Then
Call 負傷原因印刷(TextFilename)
End If
'-------------------------------------20141106 様式追加 ishikawa
If ActiveSheet.Name = "出産育児一時金" Then
Call 出産育児一時金印刷(TextFilename)
End If
If ActiveSheet.Name = "内払差額" Then
Call 内払差額印刷(TextFilename)
End If
If ActiveSheet.Name = "埋葬料" Then
Call 埋葬料印刷(TextFilename)
End If
If ActiveSheet.Name = "特定疾病" Then
Call 特定疾病印刷(TextFilename)
End If
'-------------------------------------ここまで
'YB30405 清水 2016/3/7
If TxtTop.Value < 0 Then
MsgBox "余白にマイナス値は設定できません。0で設定します。", vbInformation, "上余白値"
TxtTop.Value = 0
End If
If TxtLeft.Value < 0 Then
MsgBox "余白にマイナス値は設定できません。0で設定します。", vbInformation, "左余白値"
TxtLeft.Value = 0
End If
TxtYohaku = ThisWorkbook.Path & "\pdf\健康保険\" & yousiki
If Dir(TxtYohaku & "\print.txt") = "" Then
Open TxtYohaku & "\print.txt" For Append As #1
Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
Close #1
Else
Open hName For Output As #1
Print #1, IIf(TxtTop.Value = 0, 0, TxtTop.Value / 10) '上余白
Print #1, IIf(TxtLeft.Value = 0, 0, TxtLeft.Value / 10) '左余白
Close #1
End If
End Sub
Function Tab区切(zi As String, su As Long, b As Boolean)
Dim jCounter As Long
Dim a As String
zi = Left(zi, su) '指定の数より多い文字数が入っている場合を想定
If b = False Then '右詰め
zi = Space(su - Len(Left(zi, su))) & zi 'スペースを設定してその数に合わせる
Else '左詰め
zi = zi & Space(su - Len(Left(zi, su)))
End If
For jCounter = 1 To Len(zi)
If jCounter = 1 Then
a = Mid(zi, jCounter, 1)
Else
a = a & vbTab & Mid(zi, jCounter, 1)
End If
Next
Tab区切 = a
End Function
Sub 電話(a As String) '#28140 20150716 ishikawa
If a Like "*-*-*" Then
Else
f = 1
End If
End Sub
Sub 郵便番号(a As String) '#28140 20150716 ishikawa
If a Like "*-*" Then
Else
f = 1
End If
End Sub
Sub 日付(a As String) '#28140 20150716 ishikawa
If a Like "*/*/*" Then
Else
f = 1
End If
End Sub
Sub 出産手当金印刷(TFname)
Dim i As Long
Dim n As Integer
Dim jCounter As Long
Dim MyStr As String
Dim MyTab As String
Dim TxtYohaku As String
With Worksheets("DATA")
If ActiveSheet.Name = "出産手当金" Then
'#36146 ito 20170125
'Dim MyD5(1 To 261, 1 To 3)
Dim MyD5(1 To 263, 1 To 3)
TxtYohaku = ThisWorkbook.Path & "\pdf\健康保険\出産手当金\"
TFname = ThisWorkbook.Path & "\pdf\健康保険\出産手当金\" & Trim(Cells(27, 16).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF"
Open TFname For Output As #1
Print #1, ""
'#36146 ito 20170125
'For i = 4 To 264
For i = 4 To 266
MyStr = Cells(.Cells(i, 12), .Cells(i, 13)).Value
MyD5(i - 3, 1) = .Cells(i, 11).Value '項目名
MyD5(i - 3, 2) = MyStr 'データ
MyD5(i - 3, 3) = MyStr '3列目は印刷用データ
' If InStr(MyD5(i - 3, 3), vbCrLf) > 0 Then 'テキストボックスで改行(コードを@に変換)
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbCrLf, "@")
' ElseIf InStr(MyD5(i - 3, 3), vbLf) > 0 Then 'セルで改行
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbLf, "@")
' End If
If i = 4 Then '記号
MyD5(i - 3, 3) = Tab区切(MyStr, 8, True)
ElseIf i = 5 Then '番号
MyD5(i - 3, 3) = Tab区切(MyStr, 7, True)
ElseIf i = 6 Then '生年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 10 Then '郵便番号 #28140 20150716 ishikawa
If MyStr <> "" Then
郵便番号 (MyStr)
End If
If f = 1 Then
MsgBox "郵便番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 14 Then '電話 #28140 20150716 ishikawa
If MyStr <> "" Then
電話 (MyStr)
End If
If f = 1 Then
MsgBox "電話番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 20 Then '口座番号
MyD5(i - 3, 3) = Tab区切(MyStr, 7, True)
ElseIf i = 21 Then '口座名義
MyD5(i - 3, 3) = Tab区切(MyStr, 30, True)
ElseIf i = 24 Then '年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 25 Then '郵便番号 #28140 20150716 ishikawa
If MyStr <> "" Then
郵便番号 (MyStr)
End If
If f = 1 Then
MsgBox "郵便番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 26 Then '電話 #28140 20150716 ishikawa
If MyStr <> "" Then
電話 (MyStr)
End If
If f = 1 Then
MsgBox "電話番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 33 Then '出産予定日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 34 Then '出産日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 35 Then '申請期間自
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 36 Then '申請期間至
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 37 Then '申請期間
If MyStr = "" Or MyStr = "0" Then
MyD5(i - 3, 3) = ""
Else
MyD5(i - 3, 3) = MyStr
End If
ElseIf i = 39 Then '期間自
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 40 Then '期間至
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 41 Then '報酬の額
If MyStr = "" Or MyStr = "0" Then
MyD5(i - 3, 3) = ""
Else
MyD5(i - 3, 3) = Format(MyStr, "#,###")
End If
ElseIf i = 43 Then '年月日1
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 77 Then '年月日2
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 111 Then '年月日3
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 145 Then '年月日4
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 179 Then '年月日5
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 218 Then '期間自1
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 219 Then '期間至1
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 220 Then '期間自2
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 221 Then '期間至2
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 222 Then '期間自3
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 223 Then '期間至3
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 259 Then '年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 264 Then '電話 #28140 20150716 ishikawa
If MyStr <> "" Then
電話 (MyStr)
End If
If f = 1 Then
MsgBox "電話番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
'#36146 ito 20170125 追加 -------------------
ElseIf i = 265 Then 'マイナンバー
MyD5(i - 3, 3) = Tab区切(MyStr, 12, True)
'#36146 ここまで -----------------------------
End If
For n = 226 To 257
' MyD5(n - 3, 3) = Format(MyStr, "#,###")
MyD5(n - 3, 3) = Format(MyStr, "#,##0") '#26749 20150107 ishikawa
Next
Print #1, MyD5(i - 3, 3)
Next
Close #1
End If
End With
End Sub
Sub 療養費装具印刷(TFname)
Dim i As Long
Dim jCounter As Long
Dim MyStr As String
Dim MyTab As String
Dim TxtYohaku As String
With Worksheets("DATA")
If ActiveSheet.Name = "療養費装具" Then
'#36146 ito 20170125
'Dim MyD5(1 To 52, 1 To 3)
Dim MyD5(1 To 53, 1 To 3)
TxtYohaku = ThisWorkbook.Path & "\pdf\健康保険\療養費装具\"
TFname = ThisWorkbook.Path & "\pdf\健康保険\療養費装具\" & Trim(Cells(27, 16).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF"
Open TFname For Output As #1
Print #1, ""
'#36146 ito 20170125
'For i = 4 To 55
For i = 4 To 56
MyStr = Cells(.Cells(i, 16), .Cells(i, 17)).Value
MyD5(i - 3, 1) = .Cells(i, 15).Value '項目名
MyD5(i - 3, 2) = MyStr 'データ
MyD5(i - 3, 3) = MyStr '3列目は印刷用データ
' If InStr(MyD5(i - 3, 3), vbCrLf) > 0 Then 'テキストボックスで改行(コードを@に変換)
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbCrLf, "@")
' ElseIf InStr(MyD5(i - 3, 3), vbLf) > 0 Then 'セルで改行
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbLf, "@")
' End If
If i = 4 Then '記号
MyD5(i - 3, 3) = Tab区切(MyStr, 8, True)
ElseIf i = 5 Then '番号
MyD5(i - 3, 3) = Tab区切(MyStr, 7, True)
ElseIf i = 6 Then '生年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 10 Then '郵便番号 #28140 20150716 ishikawa
If MyStr <> "" Then
郵便番号 (MyStr)
End If
If f = 1 Then
MsgBox "郵便番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 14 Then '電話 #28140 20150716 ishikawa
If MyStr <> "" Then
電話 (MyStr)
End If
If f = 1 Then
MsgBox "電話番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 20 Then '口座番号
MyD5(i - 3, 3) = Tab区切(MyStr, 7, True)
ElseIf i = 21 Then '口座名義
MyD5(i - 3, 3) = Tab区切(MyStr, 30, True)
ElseIf i = 24 Then '年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 25 Then '郵便番号 #28140 20150716 ishikawa
If MyStr <> "" Then
郵便番号 (MyStr)
End If
If f = 1 Then
MsgBox "郵便番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 26 Then '電話 #28140 20150716 ishikawa
If MyStr <> "" Then
電話 (MyStr)
End If
If f = 1 Then
MsgBox "電話番号の入力形式が不正です。ハイフンが含まれているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
ElseIf i = 35 Then '家族の場合生年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 37 Then '発病年月日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 46 Then '診療期間自
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 47 Then '診療期間至
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 48 Then '診療日数
If MyStr = "" Or MyStr = "0" Then
MyD5(i - 3, 3) = ""
Else
MyD5(i - 3, 3) = MyStr
End If
ElseIf i = 49 Then '入院期間自
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 50 Then '入院期間至
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 51 Then '入院日数
If MyStr = "" Or MyStr = "0" Then
MyD5(i - 3, 3) = ""
Else
MyD5(i - 3, 3) = MyStr
End If
ElseIf i = 52 Then '指示を受けた日
If MyStr = "" Or MyStr = "0:00:00" Then
MyD5(i - 3, 3) = ""
Else
日付 (MyStr) '#28140 20150716 ishikawa
If f = 1 Then
MsgBox "日付の形式が不正です。正しく入力されているか確認してください。", vbOKOnly + vbExclamation, "印刷"
Close #1
Kill TFname
End
End If
MyD5(i - 3, 3) = Format(MyStr, "yyyy/mm/dd")
End If
ElseIf i = 53 Then '療養の費用
If MyStr = "" Or MyStr = "0" Then
MyD5(i - 3, 3) = ""
Else
MyD5(i - 3, 3) = Format(MyStr, "#,###")
End If
'#36146 ito 20170125 追加 -------------------
ElseIf i = 56 Then 'マイナンバー
MyD5(i - 3, 3) = Tab区切(MyStr, 12, True)
'#36146 ここまで -----------------------------
End If
Print #1, MyD5(i - 3, 3)
Next
Close #1
End If
End With
End Sub
Sub 療養費立替払印刷(TFname)
Dim i As Long
Dim jCounter As Long
Dim MyStr As String
Dim MyTab As String
Dim TxtYohaku As String
With Worksheets("DATA")
If ActiveSheet.Name = "療養費立替払" Then
'#36146 ito 20170125
'Dim MyD5(1 To 56, 1 To 3)
Dim MyD5(1 To 57, 1 To 3)
TxtYohaku = ThisWorkbook.Path & "\pdf\健康保険\療養費立替払\"
TFname = ThisWorkbook.Path & "\pdf\健康保険\療養費立替払\" & Trim(Cells(27, 16).Value) & Format(Now(), "YYYYMMDDHHSS") & ".TDF"
Open TFname For Output As #1
Print #1, ""
'#36146 ito 20170125
'For i = 4 To 59
For i = 4 To 60
MyStr = Cells(.Cells(i, 20), .Cells(i, 21)).Value
MyD5(i - 3, 1) = .Cells(i, 19).Value '項目名
MyD5(i - 3, 2) = MyStr 'データ
MyD5(i - 3, 3) = MyStr '3列目は印刷用データ
' If InStr(MyD5(i - 3, 3), vbCrLf) > 0 Then 'テキストボックスで改行(コードを@に変換)
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbCrLf, "@")
' ElseIf InStr(MyD5(i - 3, 3), vbLf) > 0 Then 'セルで改行
' MyD5(i - 3, 3) = Replace(MyD5(i - 3, 3), vbLf, "@")
' End If
If i = 4 Then '記号
…
|
|||
Open this report in the interactive analyzer, or submit your own file for analysis.