Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 24c66ca31abc4664…

MALICIOUS

Office (OLE)

999.5 KB Created: 2010-11-01 01:30:12 Authoring application: Microsoft Excel First seen: 2018-07-18
MD5: f659edb893f5d1df314fcdca6f8a9028 SHA-1: 668ef206a5e5ee33e40ec441d3aaea012dad5bb5 SHA-256: 24c66ca31abc4664d0cc7c3a85559f0a9d11c862d4ae4fcba5bf292ef33cf614
100 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment T1203 Exploitation for Client Execution

The file is an Excel document containing VBA macros. Heuristics indicate the presence of a ShellExecute API reference and a CreateObject call, suggesting the macro is designed to execute arbitrary code. The macros themselves appear to be primarily focused on preventing saving and displaying messages, but the underlying functionality likely involves downloading and executing a secondary payload. The document body contains Japanese text related to employment and social insurance applications, which could be used as a lure.

Heuristics 3

  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • VBA macros detected medium 1 related finding OLE_VBA_MACROS
    Document contains VBA macro code
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Dim FSO, PathName As String, FileName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FileName = FSO.GetFileName(Name)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 82316 bytes
SHA-256: ebcb4f96a55580bba05d204046177c1c867abb7bb64d717fc540ed9bb52c0b2e
Preview script
First 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 = "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 = "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 = "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
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
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 = "Function1"
Option Explicit
'20110105 YBNO2948 笹
Public 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
'END 20110105 YBNO2948 笹
''' YBNO 20720
'Public Const AAA As String = "社会保険取得届"
Public Const AAA As String = "育児休業初回"
''' END YBNO 20720
Dim i As Integer
Dim n As Integer
Dim strg1 As String
Function TEL(Denwa As String)
            Dim j As Integer
            Dim k As Integer
            Dim l As Integer
            j = 0
            k = 0
            With Worksheets("社総括票")
                For l = 1 To Len(Denwa)
                    If Mid(Denwa, l, 1) = "-" Then
                        If j = 0 Then
                            j = l
                            Else
                            k = l
                        End If
                    End If
                Next
                If j = 0 Then 'ＴＥＬ１
                    .Cells(32, 2).Value = Denwa
                    Exit Function
                    Else
                    .Cells(32, 2).Value = Mid(Denwa, 1, j - 1)
                End If
                If k = 0 Then 'ＴＥＬ2
                    .Cells(33, 2).Value = Mid(Denwa, j + 1, Len(Denwa) - j)
                    Exit Function
                    Else
                    .Cells(33, 2).Value = Mid(Denwa, j + 1, k - j - 1)
                End If
                .Cells(34, 2).Value = Mid(Denwa, k + 1, Len(Denwa) - k) 'ＴＥＬ3
            End With
End Function
Public Sub Body(f As TextFile, Wh As String)
             '総括票XML作成
             With ThisWorkbook.Worksheets(Wh)
                 For i = 1 To .Cells(1005, 1).End(xlUp).Row
                     If .Cells(i, 2).Value = "" Then
                        f.TextWriteLine .Cells(i, 1).Value & .Cells(i, 3).Value
                         Else
                        f.TextWriteLine .Cells(i, 1).Value & .Cells(i, 2).Text & .Cells(i, 3).Value
                     End If
                 Next
            End With
            
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
Function FileNameCheck(Name As String) As Boolean
    
    '空欄だったら何もしない
    FileNameCheck = True
    If Name = "" Then Exit Function
    
    'ファイル名を取得
    Dim FSO, PathName As String, FileName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FileName = FSO.GetFileName(Name)
    
    '取得したファイル名をCheckHankakuで１文字ずつチェック
    If CheckHankaku(Left(FileName, Len(FileName) - 4)) = False Then
        FileNameCheck = False
        Exit Function
    End If
    
    Set FSO = Nothing
    FileNameCheck = True
    
End Function
Function CheckHankaku(strChkData As String) As Boolean

    Dim strHan As String, i As Integer

    '変数に半角カタカナを列挙した文字列をセットする
    strHan = "｡｢｣､･ｦｧｨｩｪｫｬｭｮｯｰｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜﾝﾞﾟ㈱ ㈲ ㈹ 　"
    
    '引数として受け取った文字列を1文字ずつ取り出して変数strHanの文字列に
    '該当するかチェックする。
    For i = 1 To Len(strChkData)
        If InStr(strHan, Mid(strChkData, i, 1)) <> 0 Then
            CheckHankaku = False
            Exit Function
        End If
    Next i
    
    CheckHankaku = True
    
End Function




Attribute VB_Name = "Module1"
Option Explicit
Public Const PROC_NAME As String = "育児休業給付"  'YBNO 31624  ito 20160509

Sub 初期処理()
    Dim ファイル名   As String
    Dim TextFilename As String
    Dim MyStr        As String
    Dim FileName     As String
    Dim n            As Integer
    Dim i            As Integer
    
    
    With ThisWorkbook.Worksheets("DATA")
        ファイル名 = Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 6)
        
        '存在するかチェック
        FileName = Workbooks("DaMenu.xls").path & "\DaProcess\MyTool\提出代行\" & ファイル名 & ".txt"
        If Dir(FileName) = "" Then
            MsgBox "電子申請用の会社情報が登録されていません。", 16, AAA
            ThisWorkbook.Close False
            Exit Sub
        End If
        

        '基本情報のパス
        n = Workbooks(.Cells(1, 1).Value).Worksheets("会社情報").Cells(86, 2).Value
        If n = 0 Then n = 1
        .Cells(2, 2).Value = Workbooks("DaMenu.xls").path & "\DaProcess\Da保存\電子申請申請者\申請者情報" & n & ".txt"
'### 23803
        If Not Application.Run("EAppCom.xla!IsFileExist", .Cells(2, 2).Value) Then
            MsgBox "電子申請用の申請者情報が登録されていません。", 16, AAA
            ThisWorkbook.Close False
            Exit Sub
        End If        '#2465 20120702
        '届の社労士名のために、データを取得する
        .Cells(12, 2).Value = Replace(GetTextData(16, .Cells(2, 2).Value), """", vbNullString)
        .Cells(13, 2).Value = Replace(GetTextData(24, .Cells(2, 2).Value), """", vbNullString)
        'END#2465 20120702
        
'        '提出代行パス
        .Cells(3, 2).Value = GetTextData(1, FileName)
        .Cells(4, 2).Value = GetTextData(2, FileName)
        .Cells(5, 2).Value = GetTextData(3, FileName)
        
        '提出先コードと名称
        .Cells(8, 2).Value = GetTextData(24, FileName)
        .Cells(9, 2).Value = GetTextData(25, FileName)
        
        '#40067/40288  ito 20180302　コメントに
        'Application.Calculation = xlCalculationManual
        'Workbooks.Open ThisWorkbook.path & "\提出先一覧.xls"
        '    For i = 1 To Cells(1005, 7).End(xlUp).Row
        '        If .Cells(9, 2).Value = Cells(i, 7).Value Then
        '            .Cells(8, 2).Value = Cells(i, 6).Value
        '            Exit For
        '        End If
        '    Next
        'Workbooks("提出先一覧.xls").Close False
        'Application.Calculation = xlCalculationAutomatic
        
 '#38985 saka 20171114 api対応
        '添付ファイルクリア
        'Range(.Cells(120, 2), .Cells(134, 2)).ClearContents
         Range(.Cells(120, 2), .Cells(149, 2)).ClearContents
    
    End With
    
    Call チェック("証明")
    Call チェック("登録")
    Call XML作成("証明", ThisWorkbook.Worksheets("DATA").Cells(102, 2).Value)
    Call XML作成("登録", ThisWorkbook.Worksheets("DATA").Cells(82, 2).Value)
    
    Application.ScreenUpdating = True
    プレビュー.Show
    Worksheets("MENU").Select
    'マスター.Show

End Sub
Sub 終了へ()
    Application.Run "DaAddin.xla!閉じる"

End Sub
Sub プレビューへ()
    プレビュー.Show
End Sub
Sub XML作成(sh As String, sh1 As String)
    Dim f1 As New TextFile
    Dim f2 As New TextFile
    Dim f3 As New TextFile
    
    Application.DisplayAlerts = (False)        'メッセージ非表示
    
    f1.FileCreate ThisWorkbook.path & "\スタイルシート\" & sh1 & "_01.xml", "UTF-8"
    Body f1, sh
    f1.FileClose
    Application.DisplayAlerts = (True)        'メッセージ非表示
    
    
End Sub
Sub チェック(sh As String) 'XMLシートのエラーチェック
    Dim i As Integer
    Dim n As Integer
    
    Application.Calculation = xlManual

    With ThisWorkbook.Worksheets(sh)
        For i = 10 To .Cells(3005, 1).End(xlUp).Row
            If .Cells(i, 20).Value = "??" Or .Cells(i, 26).Value = "??" Or .Cells(i, 28).Value = "??" Or .Cells(i, 42).Value = "??" Then
            MsgBox .Cells(i, 23).Value & "のデータが不正です。", 16, AAA
            Application.Calculation = xlAutomatic
            ThisWorkbook.Close False
            End If
        Next
    End With
    
    Application.Calculation = xlAutomatic
 
End Sub
Sub 数式作成()
Dim i As Long
Dim n As Long
Dim suusiki As String

suusiki = ""
For i = Cells(ActiveCell.Row - 1, ActiveCell.Column).Value To Cells(ActiveCell.Row - 1, ActiveCell.Column + 1).Value Step 4
Cells(ActiveCell.Row, ActiveCell.Column + 1).Value = suusiki & ActiveCell.Value & i & """,0)&"
suusiki = Cells(ActiveCell.Row, ActiveCell.Column + 1).Value
Next

End Sub
Sub 数式を作成()
数式.Show 0
End Sub
Public Function SetTelNumber(ByVal str As String, ByVal no As Long) As String

    If Len(str) - Len(Replace(str, "-", "")) = 2 Then
        SetTelNumber = Split(str, "-")(no - 1)
    Else
        SetTelNumber = vbNullString
    End If

End Function

Attribute VB_Name = "TextFile"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

' TextFile:
' VBA class module for creating UTF-8 textfiles
'
' Usage:
' Dim fd As New TextFile
' fd.FileCreate "c:\any\path\to\the\textfile", "UTF-8"
' fd.TextWrite "any text"
' fd.TextWriteLine "any text line"
' fd.FileClose
'
' You can also specify "UTF-16" for UTF-16 LE encoding, and other for your local encoding.
'
' Todo:
' Functions for reading such textfiles.
' (but I don't need this feature now, so ... :-P)
'
' Author: Hiroto Kagotani <kagotani@cne.okayama-u.ac.jp>
' Date: 2004-03-03
' Copyright: This is free software with absolutely no warranty.
'            You are permitted to use/copy/modify/redistribute this software freely.

Private propEncoding As String
Private propIsOpen As Boolean
Private propTextStream As Object
Private propFileNumber As Integer

Public Function FileCreate(path As String, enc As String) As Boolean
    Dim fs As Object
    
    On Error GoTo HandleError
    
    propEncoding = enc
    
    If Me.IsOpen Then
        Me.FileClose
    End If
    
    If Me.Encoding = "UTF-8" Then
        propFileNumber = FreeFile
        
        ' truncate
        Open path For Output As propFileNumber
        Close propFileNumber
        
        Open path For Binary Access Write As propFileNumber
    Else
        Set fs = CreateObject("Scripting.FileSystemObject")
        If Me.Encoding = "UTF-16" Then
            Set propTextStream = fs.CreateTextFile(path, True, True)
        Else
            Set propTextStream = fs.CreateTextFile(path, True)
        End If
    End If

    propIsOpen = True
    FileCreate = True
ExitProc:
    Exit Function

HandleError:
    FileCreate = False
    Resume ExitProc
End Function

Public Function FileClose() As Boolean
    On Error GoTo HandleError
        
    If Me.IsOpen Then
        If Me.Encoding = "UTF-8" Then
            Close propFileNumber
        Else
            propTextStream.Close
        End If
    End If
    
    propIsOpen = False
    FileClose = True
ExitProc:
    Exit Function

HandleError:
    FileClose = False
    Resume ExitProc
End Function

Public Function TextWrite(s As String) As Boolean
    On Error GoTo HandleError
    
    If Me.Encoding = "UTF-8" Then
        Put propFileNumber, , String2Utf8(s)
    Else
        If Me.Encoding = "UTF-16" Then
        Else
            s = StrConv(StrConv(s, vbFromUnicode), vbUnicode)
        End If
        propTextStream.Write s
    End If
    
    TextWrite = True
ExitProc:
    Exit Function

HandleError:
    TextWrite = False
    Resume ExitProc
End Function

Public Function TextWriteLine(s As String) As Boolean
    TextWriteLine = Me.TextWrite(s & vbCrLf)
End Function

Property Get IsOpen() As Boolean
    IsOpen = propIsOpen
End Property

Property Get Encoding() As String
    Encoding = propEncoding
End Property

#Const UCS4 = False

Public Function String2Utf8(s As String) As Byte()
    Dim b() As Byte
    Dim blength As Integer
    Dim bindex As Integer
    Dim ch As Long
    
    ' ftp://ftp.rfc-editor.org/in-notes/rfc2279.txt
    
    ' U+0000 - U+007F                             00000000.0zzzzzzz: 0zzzzzzz
    ' U+0080 - U+07FF                             00000yyy.yyzzzzzz: 110yyyyy 10zzzzzz
    ' U+0800 - U+FFFF                             xxxxyyyy.yyzzzzzz: 1110xxxx 10yyyyyy 10zzzzzz
    ' U+0001 0000 - U+001F FFFF 00000000.000wwwxx.xxxxyyyy.yyzzzzzz: 11110www 10xxxxxx 10yyyyyy 10zzzzzz
    ' U+0020 0000 - U+03FF FFFF 000000vv.wwwwwwxx.xxxxyyyy.yyzzzzzz: 111110vv 10wwwwww 10xxxxxx 10yyyyyy 10zzzzzz
    ' U+0400 0000 - U+7FFF FFFF 0uvvvvvv.wwwwwwxx.xxxxyyyy.yyzzzzzz: 1111110u 10vvvvvv 10wwwwww 10xxxxxx 10yyyyyy 10zzzzzz
    
    blength = 0
    For sindex = 1 To Len(s)
        ch = AscW(Mid(s, sindex, 1))
        If ch < 0 Then
            ch = ch + 65536
        End If
        If ch < &H80 Then
            blength = blength + 1
        ElseIf ch < &H800 Then
            blength = blength + 2
        ElseIf ch < &H10000 Then
            blength = blength + 3
#If UCS4 = True Then
        ElseIf ch < &H200000 Then
            blength = blength + 4
        ElseIf ch < &H4000000 Then
            blength = blength + 5
        ElseIf ch < &H80000000 Then
            blength = blength + 6
#End If
        Else
            ' unsupported
        End If
    Next sindex
    ReDim b(0 To blength - 1) As Byte
    bindex = 0
    For sindex = 1 To Len(s)
        ch = AscW(Mid(s, sindex, 1))
        If ch < 0 Then
            ch = ch + 65536
        End If
        If ch < &H80 Then
            b(bindex) = ch And &H7F
            bindex = bindex + 1
        ElseIf ch < &H800 Then
            b(bindex) = &HC0 Or ((ch And &H7C0) \ &H40)
            b(bindex + 1) = &H80 Or ch And &H3F
            bindex = bindex + 2
        ElseIf ch < &H10000 Then
            b(bindex) = &HE0 Or ((ch And &HF000) \ &H1000)
            b(bindex + 1) = &H80 Or ((ch And &HFC0) \ &H40)
            b(bindex + 2) = &H80 Or ch And &H3F
            bindex = bindex + 3
#If UCS4 = True Then
        ElseIf ch < &H200000 Then
            b(bindex) = &HF0 Or ((ch And &H1C0000) \ &H40000)
            b(bindex + 1) = &H80 Or ((ch And &H3F000) \ &H1000)
            b(bindex + 2) = &H80 Or ((ch And &HFC0) \ &H40)
            b(bindex + 3) = &H80 Or ch And &H3F
            bindex = bindex + 4
        ElseIf ch < &H4000000 Then
            b(bindex) = &HF8 Or ((ch And &H3000000) \ &H1000000)
            b(bindex + 1) = &H80 Or ((ch And &HFC0000) \ &H40000)
            b(bindex + 2) = &H80 Or ((ch And &H3F000) \ &H1000)
            b(bindex + 3) = &H80 Or ((ch And &HFC0) \ &H40)
            b(bindex + 4) = &H80 Or ch And &H3F
            bindex = bindex + 5
        ElseIf ch < &H80000000 Then
            b(bindex) = &HFC Or ((ch And &H40000000) \ &H40000000)
            b(bindex + 1) = &H80 Or ((ch And &H3F000000) \ &H1000000)
            b(bindex + 2) = &H80 Or ((ch And &HFC0000) \ &H40000)
            b(bindex + 3) = &H80 Or ((ch And &H3F000) \ &H1000)
            b(bindex + 4) = &H80 Or ((ch And &HFC0) \ &H40)
            b(bindex + 5) = &H80 Or ch And &H3F
            bindex = bindex + 6
#End If
        Else
            ' unsupported
        End If
    Next sindex

    String2Utf8 = b
    
End Function

Attribute VB_Name = "プレビュー"
Attribute VB_Base = "0{CE01B104-0335-4FFC-8E6E-2B0B90DAB6A3}{FB5CFDCF-A26A-49AC-A6D9-59AFDB67281C}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Private Sub UserForm_Activate()

    Dim FileName As String
    Dim i As Integer
    Dim MyStr As String
        
'    提出先
    TextBox6.Value = Worksheets("DATA").Cells(8, 2).Value
    TextBox1.Value = Worksheets("DATA").Cells(9, 2).Value
    TextBox20.Value = Worksheets("DATA").Cells(11, 2).Value '同意書

'    社労士情報
    FileName = Worksheets("DATA").Cells(2, 2).Value
    Open FileName For Input As #1
        For i = 1 To 16
            Input #1, MyStr
            TextBox3.Value = MyStr
        Next
    Close #1
    
'    日付
    Text1.Value = Format(Date, "yyyymmdd")
    
'    提出代行
    With Worksheets("DATA")
        If .Cells(10, 2).Value = "PDF" Then Me.OptionButton1.Value = True
        If .Cells(10, 2).Value = "DOC" Then Me.OptionButton2.Value = True
        
        'YB27996 20150622 fuku
'        If .Cells(10, 2).Value = "利用しない" Then Me.OptionButton3.Value = True
        If .Cells(10, 2).Value = "利用しない" Then Me.OptionButton3.Value = False
        
    End With
    
'    チェック
    If TextBox1.Value = "" Or TextBox3.Value = "" Then
        MsgBox "必要な情報が設定されていません。", 16, AAA
        Unload Me
        Application.Run "DaAddin.xla!閉じる"
        Exit Sub
    End If
    If Controls("Text" & 1).Value = "" Then
        MsgBox "必要な情報が設定されていません。", 16, AAA
        Application.Run "DaAddin.xla!閉じる"
        Unload Me
        Exit Sub
    End If
    
    WebBrowser1.Navigate ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(85, 2).Value
    WebBrowser2.Navigate ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(105, 2).Value
    
    Option4.Value = True
    Option4_Click
    
End Sub
Private Sub OptionButton1_Click() '提出代行ＰＤＦ
    SetDaikouSya 1, TextBox5, ThisWorkbook
End Sub
Private Sub OptionButton2_Click() '提出代行ＤＯＣ
    SetDaikouSya 2, TextBox5, ThisWorkbook
End Sub
Private Sub OptionButton3_Click() '提出代行利用しない(20100914masa)
    SetDaikouSya 3, TextBox5, ThisWorkbook
End Sub
Public Sub SetDaikouSya(ByVal no As Long, ByRef tb As MSForms.TextBox, ByRef wb As Workbook)

    If no = 1 Then
        tb.Value = wb.Worksheets("DATA").Cells(4, 2).Value
        tb.ForeColor = "&H000000"
        wb.Worksheets("DATA").Cells(10, 2).Value = "PDF"
    ElseIf no = 2 Then
        tb.Value = wb.Worksheets("DATA").Cells(5, 2).Value
        tb.ForeColor = "&H000000"
        wb.Worksheets("DATA").Cells(10, 2).Value = "DOC"
    Else
        tb.Value = vbNullString
        tb.ForeColor = "&H00E0E0E0"
        wb.Worksheets("DATA").Cells(10, 2).Value = "利用しない"
    End If

    If Me.WebBrowser1.LocationURL <> "" Then
    Call XML作成("証明", ThisWorkbook.Worksheets("DATA").Cells(102, 2).Value)
    Call XML作成("登録", ThisWorkbook.Worksheets("DATA").Cells(82, 2).Value)
        Me.WebBrowser1.Refresh
        Me.WebBrowser2.Refresh
    End If

End Sub
Private Sub CommandButton11_Click()
        
    Dim hWnd As Long, Ret As Long
    Dim getforgroundwindow As Long
    
    hWnd = getforgroundwindow
    Ret = ShellExecute(hWnd, "Open", TextBox20.Value, "", "", 5)

End Sub
Private Sub CommandButton2_Click()
    '''YBNO 18323
    '添付.Show
    Application.Run "EAppCom.xla!DisplayAttach", 2, 2, ThisWorkbook
    ''' END YBNO18323
End Sub
Private Sub Option4_Click()
    WebBrowser1.Visible = True
    WebBrowser2.Visible = False
    DoEvents
End Sub
Private Sub Option5_Click()
    WebBrowser1.Visible = False
    WebBrowser2.Visible = True
    DoEvents
End Sub
Private Sub CommandButton8_Click()
        Dim strFName As String
        '20080630 kon
        strFName = _
            Application.GetOpenFilename _
                 ("(*.*),*.*")
        If (strFName = "False") Then
            Exit Sub
        End If
'#38985 saka 20171114 api対応
        If Application.Run("EAppCom.xla!isNotDisPlayChar", strFName) Then
            MsgBox "ファイル名に使用できない文字が含まれています。", vbCritical + vbOKOnly, "添付ファイルエラー"
            Exit Sub
        End If
'saka ここまで

        '#39231 hara 20180416
        If Application.Run("EAppCom.xla!isSameFile", strFName, TextBox5) Then
            MsgBox "提出代行証明書とファイル名が同一です。", vbCritical + vbOKOnly, "添付ファイルエラー"
            Exit Sub
        End If
        '#39231 hara ここまで

        TextBox20.Value = strFName
End Sub
Private Sub CommandButton1_Click()

'総括票XML作成の準備
        Dim i As Integer
        Dim strPathName As String
        Dim myFso     As Scripting.FileSystemObject
        Dim FileName As String
        Dim ファイル名 As String
        Dim フォルダ As String
        Dim 申ID As String
        Dim 手ID As String
'#38985 saka 20171114 api対応
        Dim dic As Object
        Dim daikoPath As String
        Dim path() As String
        Dim address As Range
        
        Set dic = CreateObject("Scripting.Dictionary")
        Set myFso = New Scripting.FileSystemObject
        daikoPath = ""
        ReDim path(0)
'#38985 ここまで

        '添付ファイルチェック
        If 添付Check = False Then Exit Sub

        If MsgBox("電子申請データを作成しますか？", 1 + 32, "作成") <> 1 Then Exit Sub
        申ID = Worksheets("DATA").Cells(82, 2).Value
        手ID = Worksheets("DATA").Cells(92, 2).Value
        Application.ScreenUpdating = False
        
'#38985 saka 20171114 api対応
        '提出代行のファイル名をDATAシートに入れる
        If OptionButton3.Value = False Then
            daikoPath = TextBox5.Value
        End If
            
        If daikoPath <> "" And myFso.FileExists(daikoPath) Then
            ThisWorkbook.Worksheets("DATA").Cells(63, 2).Value = myFso.GetFile(daikoPath).Name
        Else
            ThisWorkbook.Worksheets("DATA").Cells(63, 2).ClearContents
            ThisWorkbook.Worksheets("DATA").Cells(64, 2).ClearContents
        End If
        
        '本人確認書
        If Trim(TextBox20.Value) <> "" Then
            path(UBound(path)) = CStr(TextBox20.Value)
        Else
            ThisWorkbook.Worksheets("DATA").Cells(65, 2).ClearContents
            ThisWorkbook.Worksheets("DATA").Cells(66, 2).ClearContents
        End If
        
        Set address = ThisWorkbook.Worksheets("DATA").Cells(63, 2)  '提出代行のセル番地を選択
        '添付ファイル1～10
        For i = 120 To 147 Step 3
            Set address = Union(address, ThisWorkbook.Worksheets("DATA").Cells(i, 2))
        Next
        
        Application.Run "EAppCom.xla!AssociatedFiles", address, daikoPath, path, dic
'#38985 ここまで

'       保存するフォルダを作る
        フォルダ = Format(Date, "YYYYMMDD") & Application.Run("EAppCom.xla!NowTimeString")
        strPathName = ThisWorkbook.path & "\" & "申請データ\" & フォルダ
        ''' YBNO 16940
        'MkDir strPathName
        Application.Run "EAppCom.xla!IsExistFolder", strPathName
        
'        入力された情報をもとに再度XMLを作成
'        Call XML編集("証明", "WebBrowser2")
'        Call XML編集("登録", "WebBrowser1")
'        Call XML作成("証明", "495000012371011854")
'        Call XML作成("登録", "495000012371011853")
                   
                  
        
'        申請書の構成情報を作成して､作成したフォルダに入れる
        Workbooks.Open FileName:=ThisWorkbook.path & "\XML作成\申請書.xls"
        Workbooks("申請書.xls").Activate
        With ThisWorkbook.Worksheets("DATA")
            '登録
            Cells(11, 2).Value = .Cells(93, 2).Value '手続き識別子
            Cells(13, 2).Value = .Cells(91, 2).Value '手続き名称
            Cells(139, 3).Value = .Cells(80, 2).Value '申請書属性情報
            Cells(3, 8).Value = strPathName & "\"  '保存先を書き込む
            Application.Run "申請書.xls!作成"
            .Cells(62, 2).Value = Cells(3, 10).Value                  '構成情報のファイル名を記録する
            '月額証明
            Cells(11, 2).Value = .Cells(95, 2).Value '手続き識別子
            Cells(13, 2).Value = .Cells(91, 2).Value '手続き名称
            Cells(139, 3).Value = .Cells(100, 2).Value '申請書属性情報
            Cells(3, 8).Value = strPathName & "\"  '保存先を書き込む
            Application.Run "申請書.xls!作成"
            .Cells(68, 2).Value = Cells(3, 10).Value                  '構成情報のファイル名を記録する
        End With
        Workbooks("申請書.xls").Close False
        ThisWorkbook.Activate
        

'        提出代行のKouseiファイルを作成して､作成したフォルダに入れる
        Workbooks.Open FileName:=ThisWorkbook.path & "\XML作成\添付.xls"
        Workbooks("添付.xls").Activate
        With Workbooks("添付.xls").Worksheets("XML作成")
            .Cells(13, 2).Value = ThisWorkbook.Worksheets("DATA").Cells(91, 2).Value '手続名称
            .Cells(3, 8).Value = strPathName & "\"  '保存先を書き込む
            .Cells(11, 2).Value = ThisWorkbook.Worksheets("DATA").Cells(94, 2).Value '手続識別子
            If OptionButton3.Value = False Then
                FileName = Dir(TextBox5.Value)
                .Cells(56, 2).Value = "提出代行証明書"
               '.Cells(57, 2).Value = FileName
                .Cells(57, 2).Value = dic(FileName)     '#38985 saka 20171114 api対応
                Application.Run "添付.xls!作成" '提出代行作成
               'ThisWorkbook.Worksheets("DATA").Cells(63, 2).Value = FileName '提出代行ファイル名を記録する
                ThisWorkbook.Worksheets("DATA").Cells(63, 2).Value = dic(FileName) '提出代行ファイル名を記録する    #38985 saka 20171114 api対応
                ThisWorkbook.Worksheets("DATA").Cells(64, 2).Value = .Cells(3, 9).Value '提出代行構成情報のファイル名を記録する
            Else
             '#38985 saka 20171114 api対応
                ThisWorkbook.Worksheets("DATA").Cells(63, 2).ClearContents
                ThisWorkbook.Worksheets("DATA").Cells(64, 2).ClearContents
            End If
            
            If TextBox20.Value <> "" Then
                 .Cells(11, 2).Value = ThisWorkbook.Worksheets("DATA").Cells(94, 2).Value '手続識別子
                 .Cells(56, 2).Value = "本人同意書"
                '.Cells(57, 2).Value = Dir(TextBox20.Value)
                 .Cells(57, 2).Value = dic(Dir(TextBox20.Value)) '#38985 saka 20171114 api対応
                 Application.Run "添付.xls!作成" '提出代行作成
                'ThisWorkbook.Worksheets("DATA").Cells(65, 2).Value = Dir(TextBox20.Value) '本人同意書
                 ThisWorkbook.Worksheets("DATA").Cells(65, 2).Value = dic(Dir(TextBox20.Value))  '本人同意書 #38985 saka  20171114 api対応
                 ThisWorkbook.Worksheets("DATA").Cells(66, 2).Value = .Cells(3, 9).Value '本人同意書構成情報のファイル名を記録する
            Else
                '#38985 saka 20171114 api対応
                ThisWorkbook.Worksheets("DATA").Cells(65, 2).ClearContents
                ThisWorkbook.Worksheets("DATA").Cells(66, 2).ClearContents
            End If
            
             'その他添付ファイル
            For i = 0 To 9
                If ThisWorkbook.Worksheets("DATA").Cells(120 + i * 3, 2).Value <> "" Then
                    .Cells(56, 2).Value = "その他添付ファイル"
                    .Cells(57, 2).Value = ThisWorkbook.Worksheets("DATA").Cells(120 + i * 3, 2).Value 'ファイル名
                    Application.Run "添付.xls!作成"
                    ThisWorkbook.Worksheets("DATA").Cells(121 + i * 3, 2).Value = .Cells(3, 9).Value '構成情報のファイル名を記録する
                End If
            Next
            
        End With
        Workbooks("添付.xls").Close False
        ThisWorkbook.Activate
        
'        提出代行JPG,スタイルシート、ＸＭＬを申請フォルダに入れる
        Set myFso = New Scripting.FileSystemObject
            If OptionButton3.Value = False Then myFso.CopyFile TextBox5.Value, strPathName & "\" '20100913masa 提出代行なしに対応
            myFso.CopyFile TextBox20.Value, strPathName & "\" '本人同意書
            myFso.CopyFile ThisWorkbook.path & "\スタイルシート\999000000000000001.xsl", strPathName & "\" 'スタイルシート
            myFso.CopyFile ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(82, 2).Value & ".xsl", strPathName & "\" 'XSL
            myFso.CopyFile ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(85, 2).Value, strPathName & "\" 'XML
            myFso.CopyFile ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(102, 2).Value & ".xsl", strPathName & "\"  '月額証明XSL
            myFso.CopyFile ThisWorkbook.path & "\スタイルシート\" & ThisWorkbook.Worksheets("DATA").Cells(105, 2).Value, strPathName & "\"  '月額証明XML
            'その他添付ファイル
            For i = 0 To 9
                If ThisWorkbook.Worksheets("DATA").Cells(120 + i * 3, 2).Value <> "" Then
                    myFso.CopyFile ThisWorkbook.Worksheets("DATA").Cells(122 + i * 3, 2).Value, strPathName & "\"
                End If
            Next
        'Set myFso = Nothing
'#38985 saka 20171114 api対応
        Application.Run "EAppCom.xla!fileRename", dic, strPathName
'#38985 ここまで
        
  '        申請者情報（kousei.xml)を作成して、作成したフォルダに入れる
        Workbooks.Open FileName:=ThisWorkbook.path & "\XML作成\申請者.xls"
        Workbooks("申請者.xls").Activate
        With ThisWorkbook.Worksheets("DATA")
            Cells(1, 8).Value = strPathName & "\kousei.xml" '保存先を書き込む
            Cells(10, 2).Value = 手ID
            Cells(12, 2).Value = .Cells(91, 2).Value '手続名称
            Cells(135, 2).Value = .Cells(8, 2).Value '職安コード
            Cells(136, 2).Value = .Cells(9, 2).Value '職安名称
            Cells(52, 3).Value = .Cells(60, 2).Value '添付ファイル
            Cells(137, 3).ClearContents '申請書属性情報は消す
            Cells(2, 9).Value = .Cells(2, 2).Value '事務所基本情報
            '提出先社保と会社名
            ファイル名 = Left(.Cells(1, 1).Value, Len(.Cells(1, 1).Value) - 6)
            FileName = Workbooks("DaMenu.xls").path & "\DaProcess\MyTool\提出代行\" & ファイル名 & ".txt"
            Cells(2, 11).Value = FileName               '電子申請会社情報
        End With
        'Application.Run "申請者.xls!作成"
        ''' YBNO16449
        If Trim(ThisWorkbook.Worksheets("DATA").Cells(10, 2).Value) = "利用しない" Then
            Application.Run "申請者.xls!作成", True
        Else
            Application.Run "申請者.xls!作成", False
        End If
        ''' END YBNO16449
        Workbooks("申請者.xls").Close False
        ThisWorkbook.Activate
        
'#38985 saka 20171114 api対応
        If ThisWorkbook.Worksheets("DATA").Cells(63, 2) <> "" Then
            ThisWorkbook.Worksheets("DATA").Cells(63, 2).Value = myFso.GetFileName(daikoPath) '提出代行のファイル名を戻す
        End If
        Application.Run "EAppCom.xla!FileUndo", ThisWorkbook.Worksheets("DATA").Range("B120,B123,B126,B129,B132,B135,B138,B141,B144,B147"), True  '添付ファイル名を戻す
    
        Set myFso = Nothing
        Set dic = Nothing
'#38985 ここまで
        
        
'        記録を書き込む
'        Application.Run "EAppCom.xla!DataAdd", strPathName, フォルダ
'        Application.ScreenUpdating = True
        
        'YBNO 31624  ito 20160509
        '個人番号があるときにログを作る
        '---------------------------------------------
        If ThisWorkbook.Worksheets("登録").Cells(38, 2).Value <> vbNullString And Application.Run("DaAddin.xla!MNMode", True, False) Then
            Dim guid As String
                                                            '#38247 taka 20170630
                                                '            guid = Workbooks("育児介護給付.xls").Worksheets("DATA").Cells(10, 1).Value
            With Workbooks("育児介護給付.xls")
                guid = .Worksheets(.Worksheets("DATA").Cells(1, 2).Value).Cells(10, 1).Value
            End With
            
            Dim ComAccount As String
            ComAccount = Application.Run("業務日誌.xlam!GetCompanyData", Workbooks(ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value))
        
            Application.Run "DaAddin.xla!ProcLogging", ComAccount, PROC_NAME, "電子申請データ作成", vbNullString, guid, ThisWorkbook.Worksheets("登録").Cells(184, 2).Value, "成功"
    
        End If
        '---------------------------------------------
        
'        If MsgBox("送信トレイに保存されました。作成したデータを電子申請しますか？", 1 + 32, "電子申請データ") <> 1 Then
…

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