Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 9cae9d0bac8112cf…

MALICIOUS

Office (OLE)

117.5 KB Created: 2005-10-09 04:16:39 Authoring application: Microsoft Excel First seen: 2018-06-25
MD5: 4a9272e6942c3790c0641636c3d848ae SHA-1: 1752a2dc0b0805e76aa7d71462c7f9974a8d4938 SHA-256: 9cae9d0bac8112cf77252705af19bfbb3e38e5cfb27a8983b98c512e800ca62b
68 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment

The sample is an Excel document containing VBA macros, including an Auto_Open macro, which is a common technique for initial execution. The document body presents a fake menu and instructions for managing HR documents, likely a lure to engage the user. The presence of ShellExecute API calls suggests the macro is designed to execute further malicious actions, such as downloading and running a second-stage payload.

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
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    End Sub
Sub Auto_Open()
初期処理

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 22128 bytes
SHA-256: 517181034f15f97abbbe77911301403c813b8813479d986ac786058a71227224
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 = "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 = "シート"
Attribute VB_Base = "0{F4FBB27A-751E-4132-81AD-EB096D2B4CE5}{AD6C6A57-CCC9-41B9-8167-552C4596FAB1}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False











Private Sub CommandButton1_Click()
If ListBox1.ListIndex = -1 Then
MsgBox "シートが選択されていません"
Else
Sheets(ListBox1.Value).Select
Unload Me
End If
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Dim S As Worksheet
  For Each S In Worksheets
    If S.Name <> ActiveSheet.Name Then
      ListBox1.AddItem S.Name
    End If
Next
End Sub

Attribute VB_Name = "フォーム読込"
Attribute VB_Base = "0{088BA692-4564-4D91-9C7D-E5C0B1DA2C4E}{4268FF72-9002-4CE5-B604-3CC361F9D7DE}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False





Dim n As Integer
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&
Dim strPath As String
Dim lngRet As Long
Dim Msg As String
Private Sub CommandButton1_Click()
On Error GoTo ErrorCheck
If ListBox1.ListIndex = -1 Then
    MsgBox "ファイルが選択されていません", 16, AA
  Else
    Dim Msg As Integer
    Msg = MsgBox(ListBox1.Value & "を削除します。一度削除すると元に戻すことはできません。" & Chr(13) & Chr(13) & _
    ListBox1.Value & "を削除する場合は[ＯＫ]をクリックしてください。" & Chr(13) & _
    "削除しない場合は[キャンセル]をクリックしてください。", 1 + 48, "削除")
    If Msg = 1 Then
        Kill Label1.Caption & "\" & ListBox1.Value & ListBox1.Text
        ListBox1.RemoveItem ListBox1.ListIndex
        MsgBox "削除しました", 64, AA
    End If
End If
Exit Sub
ErrorCheck:
MsgBox "削除できませんでした", , Error
End Sub

Private Sub CommandButton2_Click()
If ListBox1.ListIndex = -1 Then
    MsgBox "ファイルが選択されていません", 16, AA
    Exit Sub
End If
Application.ScreenUpdating = False
Me.Height = 330
Label3.Caption = ListBox1.Value & "の" & MENUF.ListBox1.Value & "を元に新規作成します。"
End Sub

Private Sub CommandButton3_Click()
If ListBox1.ListIndex = -1 Then
    MsgBox "ファイルが選択されていません", 16, AA
    Exit Sub
End If

Dim ファイル名 As String
Application.ScreenUpdating = False
ファイル名 = Left(Me.Caption, Len(Me.Caption) - 8)
If TextBox1.Value = "" Then
MsgBox "ファイル名を入力してください", 16, AA
Exit Sub
End If
If Len(Dir(Label1.Caption & "\" & TextBox1.Value & ListBox1.Text, [vbNormal])) <> 0 Then
MsgBox "このファイル名はすでに存在します。ファイル名を変更するか、このファイルを削除（「保存データ」から「削除」）してからおこなってください。", , AA
Exit Sub
End If
'ファイルを名前を変えてコピーして作成する
If MsgBox(ListBox1.Value & "の" & ファイル名 & "をファイル名「" & TextBox1.Value & "」で作成しますか？", 1 + 32, AA) <> 1 Then Exit Sub
Dim 新ファイル As String
Dim oApp As Object
新ファイル = Label1.Caption & "\" & TextBox1.Value & ListBox1.Text
FileCopy Label1.Caption & "\" & ListBox1.Value & ListBox1.Text, 新ファイル
MsgBox "作成しました。このファイルを終了する場合は必ず「上書保存」をおこなってから終了してください。", 64, AA
Application.ScreenUpdating = True
Me.Hide
strPath = 新ファイル
lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            Msg = "どのアプリとも関連付けがされていません。"
        Case ERROR_FILE_NOT_FOUND
            Msg = "ファイルが見つかりませんでした。!"
    End Select
Unload Me
End Sub

Private Sub CommandButton4_Click()
検索.Caption = "保存データの検索"
検索.Show
End Sub

Private Sub Command読込_Click()
If ListBox1.ListIndex = -1 Then
    MsgBox "ファイルが選択されていません", 16, AA
    Exit Sub
End If
Application.ScreenUpdating = True
Me.Hide
strPath = Label1.Caption & "\" & ListBox1.Value & ListBox1.Text
lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            Msg = "どのアプリとも関連付けがされていません。"
        Case ERROR_FILE_NOT_FOUND
            Msg = "ファイルが見つかりませんでした。!"
    End Select
Unload Me
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
Command読込_Click
End Sub
Private Sub UserForm_Initialize()
Me.Height = 230
End Sub


Attribute VB_Name = "シート選択"
Option Explicit
Dim Msg As Integer
Public Const AA As String = "Cells"
Sub 初期処理()
ActiveWindow.WindowState = xlMaximized
シートの保護
End Sub
Sub Auto_Open()
初期処理
End Sub
Private Sub シートの保護()
  Application.ScreenUpdating = False
  Dim SS As Worksheet
  For Each SS In Worksheets
    With SS
      .Activate
      .EnableSelection = xlUnlockedCells
      .Protect UserInterfaceOnly:=True
    ActiveWindow.DisplayHeadings = False
    End With
Next
ActiveWindow.DisplayWorkbookTabs = False
Sheets("MENU").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
MENUFへ
End Sub
Sub 保護の解除()
ActiveSheet.Unprotect
MsgBox "保護を解除しました"
End Sub
Sub MENUFへ()
Sheets("MENU").Select
MENUF.Show
End Sub
Sub 印刷()
If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
Application.ScreenUpdating = False
ActiveSheet.PrintOut
Application.ScreenUpdating = True
End Sub
Sub A保存()
KURIA
    Application.EnableEvents = False
    ThisWorkbook.Save
    Application.EnableEvents = True
End Sub
Sub KURIA()
    Sheets("MENU").Select
End Sub




Attribute VB_Name = "MENUF"
Attribute VB_Base = "0{5106BFA0-1442-456A-8BA6-80FDAEBC2E9A}{674FE266-C0EF-4CAB-AA8C-C0D0533532EE}"
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
Public oPercent As Integer
Public oWid     As Integer
Public oHi      As Integer
Public oTop     As Integer
Public oLeft    As Integer
Dim ファイル名 As String
Dim i As Integer
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&

Sub hirakuAnyFile()
    Dim strPath As String
    Dim lngRet As Long
    Dim Msg As String
    strPath = ActiveWorkbook.Path & "\就業規則\" & ListBox1.Value & ListBox1.Text
    lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case lngRet
        Case SE_ERR_NOASSOC
            Msg = "どのアプリとも関連付けがされていません。"
        Case ERROR_FILE_NOT_FOUND
            Msg = "ファイルが見つかりませんでした。!"
    End Select
If Msg = "" Then Exit Sub
End Sub


Private Sub CommandButton1_Click()
If ListBox1.ListIndex = -1 Then
MsgBox "リストが選択されていません。", 16, AA
Exit Sub
End If
新規.Caption = ListBox1.Value & "の新規作成"
新規.Label3 = ListBox1.Text '拡張子
新規.Show
End Sub
Private Sub CommandButton2_Click()
If ListBox1.ListIndex = -1 Then
MsgBox "リストを選択してからおこなってください。", 16, AA
Exit Sub
End If
'この規則集のフォルダがなければないものとする
'If Dir(ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ListBox1.Value, 16) = "" Then
'MsgBox ListBox1.Value & "の保存データはありません。", 16, AA
'Exit Sub
'End If
i = 0
ファイル名 = Dir(ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ListBox1.Value & "\*.*")
   Do While ファイル名 <> ""
        If ファイル名 Like "~*" Then
        Else
        フォーム読込.ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
        フォーム読込.ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
        i = i + 1
        End If
        ファイル名 = Dir()
    Loop
If フォーム読込.ListBox1.ListIndex = -1 Then
Else
フォーム読込.ListBox1.Selected(0) = True
End If
フォーム読込.Caption = ListBox1.Value & "の保存データ読込"
'パスを表示させる
フォーム読込.Label1.Caption = ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ListBox1.Value
フォーム読込.Show
End Sub

Private Sub CommandButton3_Click()
Application.DisplayAlerts = (False)
Dim ブックの数 As Integer
Dim WB As Object
ブックの数 = 0
For Each WB In Application.Workbooks
 If UCase(WB.Name) = "PERSONAL.XLS" Then
  Else
  ブックの数 = ブックの数 + 1
 End If
Next
Dim Msg As Integer
Msg = MsgBox("終了しますか？", 1 + 32, AA)
  If Msg <> 1 Then
    Exit Sub
  End If
  If ブックの数 = 1 Then '開いているブックがパーソナル以外になければ、エクセルを終了
      Application.Quit
    Else
      Application.Run "DaAddin.xla!閉じる"
    Exit Sub
  End If
End Sub
Private Sub CommandButton4_Click()
Dim fileToOpen
'ファイルをコピーする。ただし、同じファイル名が既に存在すれば警告し実行しない
'この場合同じファイル名でも拡張子が違えば同じファイルではない
fileToOpen = Application.GetOpenFilename("エクセルやプログラム以外のファイル(*.*),*.*")
If fileToOpen <> False Then
    
    If UCase(Right(fileToOpen, 4)) = ".XLS" Or UCase(Right(fileToOpen, 4)) = ".EXE" Then
    MsgBox "このファイルはテンプレートにできません。"
    Exit Sub
    End If
    If Len(Dir(ActiveWorkbook.Path & "\就業規則\" & Dir(fileToOpen), [vbNormal])) <> 0 Then
        MsgBox "このファイル名はすでに存在します。ファイル名を変更してから実行してください。", , AA
        Exit Sub
    End If
    FileCopy fileToOpen, ActiveWorkbook.Path & "\就業規則\" & Dir(fileToOpen)
    'リストに追加する。
    ListBox1.AddItem Left(Dir(fileToOpen), Len(Dir(fileToOpen)) - 4)
    ListBox1.List(ListBox1.ListCount - 1, 1) = Right(Dir(fileToOpen), 4)
    MsgBox "「" & Left(Dir(fileToOpen), Len(Dir(fileToOpen)) - 4) & "」を追加しました。"
End If
End Sub

Private Sub CommandButton5_Click()
If ListBox1.ListIndex = -1 Then
MsgBox "リストを選択してからおこなってください。", , AA
Exit Sub
End If
hirakuAnyFile
End Sub

Private Sub CommandButton7_Click()
On Error GoTo ErrorCheck
If ListBox1.ListIndex = -1 Then
    MsgBox "ファイルが選択されていません", , AA
  Else
    Dim Msg As Integer
    Msg = MsgBox(ListBox1.Value & "を削除します。一度削除すると元に戻すことはできません。" & Chr(13) & Chr(13) & _
    ListBox1.Value & "を削除する場合は[ＯＫ]をクリックしてください。" & Chr(13) & _
    "削除しない場合は[キャンセル]をクリックしてください。", 1 + 48, "削除")
    If Msg = 1 Then
        Kill ActiveWorkbook.Path & "\就業規則\" & ListBox1.Value & ListBox1.Text
        ListBox1.RemoveItem ListBox1.ListIndex
        MsgBox "削除しました", , AA
    End If
End If
Exit Sub
ErrorCheck:
MsgBox "削除できませんでした", , Error
End Sub

Private Sub CommandButton8_Click()
検索.Show
End Sub

Private Sub CommandButton9_Click()
   ListBox1.Clear
   i = 0
   ファイル名 = Dir(ActiveWorkbook.Path & "\就業規則\*.*")
   Do While ファイル名 <> ""
        If ファイル名 Like "~*" Then
        Else
        ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
        ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
        i = i + 1
        End If
        ファイル名 = Dir()
    Loop
CommandButton9.Visible = False
End Sub
Private Sub ScrollBarZoom_Change()
    Zoom = ScrollBarZoom.Value
    oPercent = ScrollBarZoom.Value
    LabelZoom.Caption = oPercent & "%"
End Sub
Private Sub UserForm_Activate()
    oTop = Me.Top
    oLeft = Me.Left
End Sub

Private Sub UserForm_Initialize()
    Dim zom As Integer
    oWid = Me.Width
    oHi = Me.Height
    zom = IIf(Worksheets("MENU").Cells(110, 1) = "", 100, Worksheets("MENU").Cells(110, 1))
    Zoom = zom
    'スクロールバーの初期設定
    ScrollBarZoom.Value = zom
    oPercent = 100
    LabelZoom.Caption = zom & "%"
   i = 0
   ファイル名 = Dir(ActiveWorkbook.Path & "\就業規則\*.*")
   Do While ファイル名 <> ""
        If ファイル名 Like "~*" Then
        Else
        ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
        ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
        i = i + 1
        End If
        ファイル名 = Dir()
    Loop

Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Zoom(Percent As Integer)
    Dim MyResult As Double
    MyResult = oWid * (Percent / 100)
    Width = MyResult
    MyResult = oHi * (Percent / 100)
    Height = MyResult
    Worksheets("MENU").Cells(110, 1).Value = Percent

End Sub



Attribute VB_Name = "新規"
Attribute VB_Base = "0{24C35722-CDB2-4B7D-86E9-DB6F72812126}{362540B0-1475-48C5-950E-4F6002C48FB0}"
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 ファイル名 As String
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
ファイル名 = Left(Me.Caption, Len(Me.Caption) - 5)
If TextBox1.Value = "" Then
    MsgBox "ファイル名を入力してください", 16, AA
    Exit Sub
End If
If Len(Dir(ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ファイル名 & "\" & TextBox1.Value & Label3, [vbNormal])) <> 0 Then
    MsgBox "このファイル名はすでに存在します。ファイル名を変更するか、このファイルを削除（「保存データ」から「削除」）してからおこなってください。", , AA
    Exit Sub
End If
'フォルダがなかったら作成
Dim strPathName As String

strPathName = Dir(ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ファイル名, 16)
If strPathName = "" Then
    MkDir ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ファイル名
Else
End If

'ファイルを名前を変えてコピーして作成する
If MsgBox(ファイル名 & "をファイル名「" & TextBox1.Value & "」で作成しますか？", 1 + 32, AA) <> 1 Then Exit Sub
Dim 新ファイル As String
Dim oApp As Object
Application.ScreenUpdating = True
Me.Hide
新ファイル = ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ファイル名 & "\" & TextBox1.Value & Label3



'20100325 kon

'FileCopy ActiveWorkbook.Path & "\就業規則\" & ファイル名 & Label3, 新ファイル
Call chk_rtn(ActiveWorkbook.Path & "\就業規則\" & ファイル名 & Label3, 新ファイル)

MsgBox "作成しました。このファイルを終了する場合は必ず「上書保存」をおこなってから終了してください。", 64, AA
Dim strPath As String
Dim lngRet As Long
Dim Msg As String
strPath = ActiveWorkbook.Path & "\Da保存\就業規則保存\" & ファイル名 & "\" & TextBox1.Value & Label3
lngRet = ShellExecute(0, "Open", strPath & vbNullString, _
                          vbNullString, vbNullString, SW_SHOWNORMAL)
Select Case lngRet
        Case SE_ERR_NOASSOC
            Msg = "どのアプリとも関連付けがされていません。"
        Case ERROR_FILE_NOT_FOUND
            Msg = "ファイルが見つかりませんでした。!"
End Select
Unload Me




End Sub

Function chk_rtn(fName As String, Nfile)
    Dim tCnt As Integer
        
    On Error GoTo err_rtn
    
    chk_rtn = False
    tCnt = 0
    If Dir(fName, vbNormal) <> "" Then
        FileCopy fName, Nfile
        tCnt = tCnt + 1
    Else
        MsgBox "ファイルが見つかりません。", vbInformation, "新規作成"
        Exit Function
    End If
        
    chk_rtn = True
        
Exit Function
err_rtn:
    If tCnt >= 20 Then
        MsgBox "新規作成に失敗しました。", vbInformation, "新規作成"
        Exit Function
    Else
        Resume
    End If

End Function


Attribute VB_Name = "Module1"
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



Attribute VB_Name = "検索"
Attribute VB_Base = "0{AA44FBB7-32FD-42AF-B123-AA991649554E}{F1860B8F-1325-444C-BEFA-D80E8D1A69E0}"
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 CommandButton1_Click()
    Dim ファイル名 As String
    Dim Moji As String
    Dim i As Integer
    Moji = TextBox1.Value
    If Moji = "" Then
    MsgBox "検索する「文字」を入力してください。", 16, AA
    Exit Sub
    End If
    If Me.Caption = "保存データの検索" Then
        フォーム読込.ListBox1.Clear
           ファイル名 = Dir(フォーム読込.Label1.Caption & "\*.*")
           i = 0
           Do While ファイル名 <> ""
                If ファイル名 Like "~*" Then
                    ElseIf ファイル名 Like "*" & Moji & "*" Then
                    フォーム読込.ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
                    フォーム読込.ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
                    i = i + 1
                End If
                ファイル名 = Dir()
            Loop
        i = フォーム読込.ListBox1.ListCount
        If i = 0 Then
        MsgBox "「" & Moji & "」は見つかりませんでした。", 16, AA
        
           ファイル名 = Dir(フォーム読込.Label1.Caption & "\*.*")
            Do While ファイル名 <> ""
                 If ファイル名 Like "~*" Then
                 Else
                 フォーム読込.ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
                 フォーム読込.ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
                 i = i + 1
                 End If
                 ファイル名 = Dir()
             Loop
        Else
        MsgBox "「" & Moji & "」は" & i & "件見つかりました。", 64, AA
        End If
        Unload Me
    
    Else
        MENUF.ListBox1.Clear
           ファイル名 = Dir(ActiveWorkbook.Path & "\就業規則\*.*")
           i = 0
           Do While ファイル名 <> ""
                If ファイル名 Like "~*" Then
                    ElseIf ファイル名 Like "*" & Moji & "*" Then
                    MENUF.ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
                    MENUF.ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
                    i = i + 1
                End If
                ファイル名 = Dir()
            Loop
        i = MENUF.ListBox1.ListCount
        If i = 0 Then
        MsgBox "「" & Moji & "」は見つかりませんでした。", 16, AA
        
           ファイル名 = Dir(ActiveWorkbook.Path & "\就業規則\*.*")
           Do While ファイル名 <> ""
                If ファイル名 Like "~*" Then
                Else
                MENUF.ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 4)
                MENUF.ListBox1.List(i, 1) = Right(ファイル名, 4) '拡張子
                i = i + 1
                End If
                ファイル名 = Dir()
            Loop
        Else
        MsgBox "「" & Moji & "」は" & i & "件見つかりました。", 64, AA
        MENUF.CommandButton9.Visible = True
        End If
        Unload Me
    End If

End Sub

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