Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 782de2bd6f906af4…

MALICIOUS

Office (OOXML)

186.9 KB Created: 2021-02-25 06:40:00 UTC Authoring application: Microsoft Office Word 16.0000 First seen: 2022-06-20
MD5: 52c7c59691e457f468479c5d95b809c5 SHA-1: 0513c3e81daa68275334d0bc935b7f4f30369d27 SHA-256: 782de2bd6f906af4a623c7e0844934787de33bc3d1826934db57ac2bc806d010
330 Risk Score

Heuristics 9

  • VBA project inside OOXML medium 7 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
                                    Shell "WScript.exe """ & installerVbsPath & """"
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Set wshShell = CreateObject("Wscript.Shell")
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
                                    Shell "WScript.exe """ & installerVbsPath & """"
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set WshNetworkObject = CreateObject("WScript.Network")
  • VBA polls global keyboard state (keylogger) high OLE_VBA_KEYLOGGER_SPYWARE
    The macro declares or calls a Win32 keystroke-monitoring API (GetAsyncKeyState, SetWindowsHookEx WH_KEYBOARD, or GetKeyboardState) to capture keystrokes system-wide. No legitimate document automation polls global key state; this is the core of a VBA keylogger, usually paired with active-window capture (GetForegroundWindow) and a log file. A high-confidence spyware behaviour independent of any download / Shell evidence.
    Matched line in script
        Public Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As LongPtr) As Integer
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Triggers on the COMBINATION of two tokens co-occurring in the same compiled VBA/cache stream: an auto-execution entry point (Auto_Open / AutoOpen / Document_Open / Workbook_Open / Auto_Close / AutoClose) AND a shell/download/object-execution token (Shell, CreateObject, GetObject, PowerShell, cmd.exe, URLDownloadToFile, WinHttp, XMLHTTP, ADODB.Stream, ShellExecute, ExecuteExcel4Macro). Neither token alone fires it — it is the pairing that flags p-code-only or source-extraction-failure macro documents where the visible VBA source is unavailable. The matched tokens are named in the detail line below.
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        tempFolder = Environ("TEMP") & "\aonoSoft\" & thisProgName
  • 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://schemas.microsoft.com/office/word/2010/wordprocessingCanvas In document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2014/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2015/9/8/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2015/10/21/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/9/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/10/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/11/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/12/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/13/chartexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/5/14/chartexIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/markup-compatibility/2006In document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2016/inkIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/drawing/2017/model3dIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/relationshipsIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/mathIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/wordprocessingml/2006/mainIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2012/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2016/wordml/cidIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2015/wordml/symexIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingGroupIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingInkIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2006/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingShapeIn document text (OOXML body / shared strings)

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 120917 bytes
SHA-256: 7a76f718b4feed2b750dca7efba6546dae4f0ce2427f5661ec518a74d2e9cf82
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-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







Public Sub AutoExec()
    ' ▽　アドインの場合、Word起動時に「AutoExec」イベントが発生
    ' 2021.03/02 08:55
    
    initializeThisAddin
End Sub

Private Sub AutoExit()
    ' ▽　アドインの場合、Word終了時に「AutoExit」イベントが発生
    ' 2021.03/02 08:54
    
    ' ▽　wordApp_DocumentBeforeCloseに失敗したときの代替として
    finalizeThisAddin
End Sub

Private Sub Document_New()
    ' ▽　テンプレート文書なので？開いたら「Document_New」イベントが発生
    startupThisInstaller
End Sub

'Public Sub Document_Open()
'    ' ▽　いらないかも。テンプレート文書なので？
'    startupThisInstaller
'End Sub

Private Sub startupThisInstaller()
    ' 2021.03/02 09:07
    
    If isEmergencyLockout Then
        msg "エマージェンシーモード" & vbCrLf & _
            "エマージェンシーモードのためプログラムは稼働しません。", vbCritical + vbOKOnly
            
        Stop
            
        End
    End If
    
    Static alreadyRun As Boolean
    If Not alreadyRun Then
        alreadyRun = True
    
        Select Case UCase(cut(ThisDocument.FullName, "2-", delimiter:="\", reverseField:=True))
            Case UCase(aonoSoftDir), UCase(updateSearchDirNetwork), UCase(updateSearchDirNetworkSub)
                msg "マクロは配布用フォルダにあるため実行できません。" & vbCrLf & _
                    "ローカルにコピーして実行してください。", vbCritical + vbOKOnly
        
                Stop
                
                forceCloseAllDocuments
                End
                
        End Select
        
        If Not isThisAddinFile Then
            ' ▽　Wordスタートアップフォルダにインストールするか確認する
            
            On Error Resume Next
            Application.WindowState = wdWindowStateMaximize
            DoEvents
            On Error GoTo 0
            
            updateCheck secure:=secureChap
    
            If Documents.count <> 1 Then
                msg "aonoSoft 「" & prgInfo & "」をインストールするには、" & vbCrLf & _
                    "先に全てのWordを終了しておいてください。" & vbCrLf & _
                    vbCrLf & _
                    "マクロは、終了します。", vbOKOnly + vbExclamation
                    
                Stop
                Stop
                Stop
    
                forceCloseAllDocuments
                End
            Else
                On Error Resume Next
                ThisDocument.Windows(1).View.Zoom.PageFit = wdPageFitFullPage
                On Error GoTo 0
            
                doReleaseBuild
                ThisDocument.Saved = True
                
                Dim userCanceled As Boolean: userCanceled = False
                Dim installerVbsPath As String
                Select Case showMsgDlg(mainMsg:=thisProgName, _
                        subMsg:="aonoSoft 「" & prgInfo & "」をインストールしますか？" & vbCrLf & _
                        vbCrLf & _
                        "不明な場合はキャンセルを押してください。", Buttons:=vbYesNoCancel, _
                        cbtn1Text:="インストール／アップデート", cbtn2Text:="アンインストール")
                    Case vbYes
                        ' ▽　インストーラーの準備
                        installerVbsPath = createInstaller(ThisDocument.FullName, sinkPath:=Application.StartupPath & "\aonoSoft_WordToolAddin.dotm", _
                            sinkPath2:=Application.StartupPath & "\" & thisProgName & ".dotm")
                    
                        Select Case showMsgDlg(mainMsg:="メッセージを閉じると、次の処理が開始します。", _
                                subMsg:="メッセージを閉じた後、次の処理が始まるまで２秒ほどかかります。" & vbCrLf & _
                                vbCrLf & _
                                "（インストールは、VBScriptで処理されます。）", _
                                Buttons:=vbOKCancel + vbDefaultButton2)
                            Case vbOK
                                
                                Shell "WScript.exe """ & installerVbsPath & """"
                                
                                Stop
                                
                                forceCloseAllDocuments
                                End
                                
                            Case Else
                                userCanceled = True
                            
                        End Select
                    
                    Case vbNo
                        ' ▽　アンインストーラーの準備
                        
                        installerVbsPath = createInstaller(ThisDocument.FullName, sinkPath:=Application.StartupPath & "\aonoSoft_WordToolAddin.dotm", _
                            sinkPath2:=Application.StartupPath & "\" & thisProgName & ".dotm", uninstallOnly:=True)
                        
                        Select Case showMsgDlg(mainMsg:="（？）削除確認", _
                                subMsg:="「" & thisProgName & "」をアンインストールしますか？", _
                                Buttons:=vbYesNo + vbDefaultButton2)
                            Case vbYes
                                Select Case showMsgDlg(mainMsg:="メッセージを閉じると、次の処理が開始します。", _
                                        subMsg:="メッセージを閉じた後、次の処理が始まるまで２秒ほどかかります。" & vbCrLf & _
                                        vbCrLf & _
                                        "（アンインストールは、VBScriptで処理されます。）", _
                                        Buttons:=vbOKCancel + vbDefaultButton2)
                                    Case vbOK
                                        
                                        Shell "WScript.exe """ & installerVbsPath & """"
                                        
                                        Stop
                                        
                                        forceCloseAllDocuments
                                        End
                                        
                                    Case Else
                                        userCanceled = True
                                    
                                End Select
                            
                            Case Else
                                userCanceled = True
                            
                        End Select
                    
                    Case Else
                        userCanceled = True
                        
                End Select
                    
                If userCanceled Then
                    msg "ユーザー操作により「" & prgInfo & "」のインストール／アンインストールをキャンセルしました。" & vbCrLf & _
                        vbCrLf & _
                        "このマクロは終了します。", vbOKOnly + vbInformation
            
                    Stop
                    
                    forceCloseAllDocuments
                    End
                End If
            End If
        End If
    End If
End Sub























Attribute VB_Name = "apiDeclarationModule"
Option Explicit
Option Private Module



#If Win64 Or Not (VBA5 Or VBA6) Then
    Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As LongPtr 'システムを起動した後の経過時間を、ミリ秒（ms）単位で取得
    
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    
    Public Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As LongPtr
    
    Public Declare PtrSafe Function SetWindowPos Lib "user32" ( _
            ByVal hwnd As LongPtr, _
            ByVal hWndInsertAfter As LongPtr, _
            ByVal X As LongPtr, _
            ByVal Y As LongPtr, _
            ByVal cx As LongPtr, _
            ByVal cy As LongPtr, _
            ByVal wFlags As LongPtr) As LongPtr
    
    Public Declare PtrSafe Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As LongPtr) As Integer
    Public Declare PtrSafe Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As LongPtr) As Integer

    Public Declare PtrSafe Sub keybd_event Lib "user32" ( _
        ByVal bVk As Byte, _
        ByVal bScan As Byte, _
        ByVal dwFlags As LongPtr, _
        ByVal dwExtraInfo As LongPtr)
        
    Public Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" ( _
        ByVal hwnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageId As LongPtr, _
        ByVal dwMilliseconds As LongPtr) As LongPtr

    Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
    Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr, ByVal dwNewLong As LongPtr) As LongPtr
    Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Public Declare Function GetTickCount Lib "kernel32" () As Long 'システムを起動した後の経過時間を、ミリ秒（ms）単位で取得
    
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    
    Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
            ByVal lpClassName As String, _
            ByVal lpWindowName As String) As Long
    
    Public Declare Function SetWindowPos Lib "user32" ( _
            ByVal hwnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal X As Long, _
            ByVal Y As Long, _
            ByVal cx As Long, _
            ByVal cy As Long, _
            ByVal wFlags As Long) As Long
    
    Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Long
    Public Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Long

    Public Declare Sub keybd_event Lib "user32" ( _
        ByVal bVk As Byte, _
        ByVal bScan As Byte, _
        ByVal dwFlags As Long, _
        ByVal dwExtraInfo As Long)
        
    Public Declare Function MessageBoxTimeoutA Lib "user32" ( _
        ByVal hwnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageId As Long, _
        ByVal dwMilliseconds As Long) As Long
    
    Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
#End If




' ▼ SetWindowPos とか用
    Public Const HWND_TOP = 0 '手前にセット
    Public Const HWND_BOTTOM = 1 '後ろにセット
    Public Const HWND_TOPMOST = -1 '常に手前にセット
    Public Const HWND_NOTOPMOST = -2 '常に手前を解除
    Public Const SWP_NOSIZE As Long = &H1&
    Public Const SWP_NOMOVE As Long = &H2&
    
' ▼ GetAsyncKeyState とか用
'    Public Const vbKeyPause = 19 ' Pauseキー
'    Public Const vbKeyEscape = 27 ' Escキー
    Public Const VK_SHIFT = 16
    Public Const VK_CONTROL = 17
    Public Const VK_MENU = 18 ' Alt
    Public Const VK_PAUSE = 19
    Public Const VK_ESCAPE = 27
    Public Const VK_END = 35
    Public Const VK_HOME = 36
    Public Const VK_LSHIFT = 160
    Public Const VK_RSHIFT = 161
    Public Const VK_SCROLL = &H91
    Public Const VK_LCONTROL = &HA2
    Public Const VK_RCONTROL = &HA3
    Public Const VK_LMENU = &HA4
    Public Const VK_RMENU = &HA5
    Public Const VK_SNAPSHOT = &H2C

' ▼ GetWindowLong, SetWindowLong, DrawMenuBar 等用
    Public Const GWL_STYLE = -16& 'ウィンドウスタイルを取得する
    Public Const WS_SYSMENU = &H80000 'タイトルバーにコントロールメニューボックスを持つウィンドウ
'    Public Const SC_CLOSE = &HF060&
'    Public Const MF_BYCOMMAND = &H0&

' ▼ keybd_event用
    Public Const EXTENDED_KEY = &H1 ' 押す dwFlags
    Public Const KEYUP = &H2        ' 放す dwFlags
    Public Const vbKeyReturn = 13
    Public Const vbKeyMenu = 18
    Public Const vbKeySpace = 32
    Public Const vbKeyX = 88
    Public Const vbKeyY = 89








Attribute VB_Name = "informationShowModule"
Option Explicit
Option Private Module



' ▼ 進捗情報タイプ ▼
    Public Const pit_Error = -900
    Public Const pit_Failure = -400
    Public Const pit_Warning = -300
    Public Const pit_Caution = -200
    Public Const pit_Notice = -100
    Public Const pit_Info = 100
    Public Const pit_Sucsess = 200
' ▲ 進捗情報タイプ ▲



Public Sub showProgressInfo(Optional mainMsg As String = "", Optional subMsg As String, _
        Optional initialize As Boolean = False, Optional hide As Boolean = False, _
        Optional infoType As Long = pit_Info)
    ' 2020.05/22 11:29
    
    load ufrmProgressInformation
    With ufrmProgressInformation
        Do
            DoEvents
            If .standby Then Exit Do
        Loop
        
        Select Case infoType
            Case pit_Error
                .backColor = &HFF&
                
            Case pit_Failure
                .backColor = &H8080FF
            
            Case pit_Warning
                .backColor = &H80C0FF
            
            Case pit_Caution
                .backColor = &HC0FFFF
            
            Case pit_Notice
                .backColor = &HFFC0C0
            
            Case pit_Info
                .backColor = &HFFFFC0
            
            Case pit_Sucsess
                .backColor = &H80FF80
            
            Case Else
                .backColor = &HE0E0E0
        
        End Select
        
        If initialize Then
            .lablProgressMain = ""
            .lablProgressSub = ""
        End If
        
        If hide Then
            .hide
        Else
            If mainMsg <> "" Then .lablProgressMain = mainMsg
            If subMsg <> "" Then .lablProgressSub = subMsg
            
            Call SetWindowPos(.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'            Call SetWindowPos(.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE)
            .Show
            DoEvents
            
        End If
        
        If Not .Visible Then
            ' 暫定対策：Bookが最小化しているときにHideするとBookが最小化でなくなった時にフォームが復活してしまう
            
            On Error Resume Next
            If Application.Windows(1).WindowState = wdWindowStateMinimize Then Unload ufrmProgressInformation
            On Error GoTo 0
        End If
    End With
End Sub




Attribute VB_Name = "ufrmProgressInformation"
Attribute VB_Base = "0{97F3F6C9-DDB3-4712-8F25-686FE9D1003A}{4F6B143A-EE88-4F4B-84AE-2448387235F2}"
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 standby As Boolean

Public Function hwnd() As Long
    Static hWndMemory As Long
    
    If hWndMemory = 0 Then hWndMemory = FindWindow(vbNullString, Me.Caption)
    hwnd = hWndMemory
End Function

Private Sub clicked()
    Me.hide
End Sub

'Private Sub lablProgressMain_Click()
'    clicked
'End Sub
'
'Private Sub lablProgressSub_Click()
'    clicked
'End Sub
'
'Private Sub UserForm_Click()
'    clicked
'End Sub

Private Sub UserForm_Initialize()
    Me.Caption = prgInfo & " - 情報表示ウィンドウ"

    standby = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        Cancel = True
        clicked
    End If
End Sub

'Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'    ' 19.12/25 09:27
'
'    lastStrReceive = CDbl(Timer)
'
'    Dim thisChr As String
'    thisChr = Chr(KeyAscii)
'    Select Case KeyAscii
'        Case vbKeyBack
'            If Len(barcode) > 0 Then
'                barcode = left(barcode, Len(barcode) - 1)
'            Else
'                barcode = ""
'            End If
'
'        Case vbKeyReturn
'            Select Case UCase(extractionCommandBarcode(barcode))
'                Case UCase("OK")
'                    beepNotice bt_readCommandBarcode
'                    If enableInformationAck Then clicked
'
'                Case Else
'                    beepNotice bt_barcodeReadDisabled
'
'            End Select
'            barcode = ""
'
'        Case Else
'            barcode = barcode & thisChr
'
'    End Select
'End Sub

Attribute VB_Name = "aonoSofttandardFunctions"
Option Explicit
Option Private Module

Public Const thisProgName = "aonoSoft_Wordツールアドイン"
Public Const thisProgVersionMajor = "0"
Public Const thisProgVersionMinor = "1"
Public Const thisProgVersionRevesion = "0"
Public Const thisProgVersionFix = "4"
Public Const thisProgVersionFooter = "Debug"
'Public thisProgVersion As String
Public Const sheetProtectPassword = "rootSheet"
Public Const secureChap = "pahCeruces"


' ##### ↓デバッグモード ON/OFF↓ #####
    ' 0：OFF     1 : ON     3 : ON (SirentDebug)
'    Public Const cDebugDefault = dlInfo
    Public Const securityPassword = 789156
    Public Const debugPCName = "NPC37725#"
    Public Const debugUserName = "j46079#"
    Public Const cAlphaModeDefault = 0 ' リリース版:0, α版：1, β版:2, RC版:3
' ##### ↑デバッグモード ON/OFF↑ #####
Public debugLevel As Long '0:NoDebug 1:allmessage 2:debug 3:info 4:notice 5:warn 6:error 7:crit 8:alert 9:emerg
    Public Const NoDebug = 0
    Public Const dlAll = 1
    Public Const dlDebug = 2
    Public Const dlInfo = 3
    Public Const dlNotice = 4
    Public Const dlWarn = 5
    Public Const dlErr = 6
    Public Const dlCrit = 7
    Public Const dlAlert = 8
    Public Const dlEmerg = 9

'    Public Const debugLevelDefault = dlAll
    Public Const debugLevelDefault = dlDebug
'    Public Const debugLevelDefault = dlInfo
    Public Const am_release = 0
    Public Const am_alpha = 1
    Public Const am_beta = 2

Public Const aonoSoftDir = "\\hqfs1\share\SP\LLC\連絡用\LAT2\青野\【aonoSoft】"
Public Const updateSearchDirNetwork = "\\hqfs1\share\SP\LLC\連絡用\LAT2\青野\【aonoSoft】\59. aonoSoft_Wordツールアドイン"
'Public Const updateSearchDirNetworkSub = "C:\Users\j46079\localDataRoot\softwareDevelopment\VBA, VBS Projects\59. aonoSoft_Wordツールアドイン"
Public Const updateSearchDirNetworkSub = ""
Public Const productNumber = 59


Public debugReportFileName As String



Public Function thisProgVersion() As String
    thisProgVersion = "v" & thisProgVersionMajor & "." & thisProgVersionMinor & "." & thisProgVersionRevesion & "." & thisProgVersionFix
End Function

Function prgInfo() As String
    prgInfo = thisProgName & " " & thisProgVersion & " " & thisProgVersionFooter
End Function

Function msg(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title, Optional HelpFile, Optional Context, Optional timeoutMillis As Long = -1, _
        Optional noWatchdogUpdate As Boolean = False) As VbMsgBoxResult
    ' 2020.02/07 10:36
        
'    If ufrmProgressInfo.Visible Then Call SetWindowPos(ufrmProgressInfo.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
    
    If timeoutMillis <= 0 Then
        msg = MsgBox(Prompt:=Prompt, _
            Buttons:=Buttons Or vbApplicationModal Or vbSystemModal Or vbMsgBoxSetForeground, _
            Title:=thisProgName & " " & thisProgVersion & " " & thisProgVersionFooter, _
            HelpFile:=HelpFile, _
            Context:=Context)
    Else
        msg = MessageBoxTimeoutA(0&, _
            Prompt, _
            thisProgName & " " & thisProgVersion & " " & thisProgVersionFooter, _
            Buttons Or vbMsgBoxSetForeground Or vbSystemModal, _
            0, _
            dwMilliseconds:=timeoutMillis)
    End If
    
    If Not noWatchdogUpdate Then
'        watchDogSetup secure:=secureChap
'        If watchDogRunning Then watchDogUpdateServicePulse
    End If
        
'    If ufrmProgressInfo.Visible Then Call SetWindowPos(ufrmProgressInfo.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function

Function debugMsg(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title, Optional HelpFile, Optional Context, Optional timeoutMillis As Long = 0) As VbMsgBoxResult
    If isThisDebugPC Or isThisDebugUser Then
        debugMsg = msg(Prompt:="【debugMsg】" & vbCrLf & Prompt, _
            Buttons:=Buttons Or vbSystemModal Or vbMsgBoxSetForeground, _
            Title:=thisProgName & " " & thisProgVersion & " " & thisProgVersionFooter, _
            HelpFile:=HelpFile, _
            Context:=Context, _
            timeoutMillis:=timeoutMillis)
        
        debugPrint "【debugMsg】" & Prompt, msgDebugLevel:=dlNotice
    End If
End Function

Function tempRoot() As String
    '2020.03/19 10:50
    
    tempRoot = ";notReady;"
    
    Dim tempFolder As String
    tempFolder = Environ("TEMP") & "\aonoSoft\" & thisProgName
    
    setupFolder tempFolder

    If fso.FolderExists(tempFolder) Then
        tempRoot = tempFolder
    Else
        debugPrint "<ASREC-75148> tempRoot Setup FAILED !", msgDebugLevel:=dlWarn
    End If
End Function

Function isThisDebugPC() As Boolean
    ' 2020.03/23 18:58
    
    isThisDebugPC = False
    
    If UCase(getComputerName) = UCase(debugPCName) Then isThisDebugPC = True
End Function

Public Function isThisDebugUser(Optional username As String = "") As Boolean
    ' 2020.03/24 13:28
    
    isThisDebugUser = False
    If getUserName = debugUserName Then isThisDebugUser = True
    
'    setupSettings
    
    Select Case True
        Case UCase(username) Like "*\*"
            If UCase(username) = UCase("nichia.local\" & debugUserName) Then isThisDebugUser = True
        
        Case UCase(username) <> ""
            If UCase(username) = UCase(debugUserName) Then isThisDebugUser = True
    End Select
End Function

Sub updateCheck(secure As String, Optional disableClose As Boolean = False)
    ' 2021.03/02 10:33
    
    If secure <> secureChap Then
        msg "<ASREC-82450> (!) Error. Fail updateCheck()"
        Exit Sub
    End If
    
    showProgressInfo mainMsg:="アップデートを確認しています...", subMsg:="", initialize:=True, infoType:=pit_Info: DoEvents
    
    Dim updateSearchDir As String: updateSearchDir = ""
    
    If updateSearchDir = "" Then
        updateSearchDir = updateSearchDirNetwork
        
        If updateSearchDir <> "" Then
            showProgressInfo mainMsg:="アップデートを確認しています...", _
                subMsg:="接続試行：" & updateSearchDir, initialize:=True, infoType:=pit_Info: DoEvents
        End If
        If Not fso.FolderExists(updateSearchDir) Then updateSearchDir = ""
    End If
    
    If updateSearchDir = "" Then
        updateSearchDir = updateSearchDirNetworkSub
        
        If updateSearchDir <> "" Then
            showProgressInfo mainMsg:="アップデートを確認しています...", _
                subMsg:="接続試行：" & updateSearchDir, initialize:=True, infoType:=pit_Info: DoEvents
        End If
        If Not fso.FolderExists(updateSearchDir) Then updateSearchDir = ""
    End If

    
'    showProgressInfo mainMsg:="アップデートを確認しています...", subMsg:=updateSearchDir, initialize:=True, infoType:=pit_Info
    
    ' アップデートチェック
    If updateSearchDir = "" Then
        showProgressInfo mainMsg:="（！）アップデートの確認に失敗しました", subMsg:=updateSearchDirNetwork, initialize:=True, infoType:=pit_Failure
        
'        ' update用ディレクトリに到達できない
        Select Case msg("アップデートの確認に失敗しました。" & vbCrLf & _
                "このバージョンは最新版ではないかもしれません。" & vbCrLf & _
                "このバージョンを使用しますか？", vbExclamation + vbYesNo + vbDefaultButton2)
            Case vbYes
                msg "アップデート確認に失敗しましたが、" & vbCrLf & _
                    "ユーザー操作によりこのバージョンを使用します。", vbExclamation + vbOKOnly
                
            Case Else
                msg "ユーザーの操作により終了します。", vbInformation + vbOKOnly
                
'                If Workbooks.Count = 1 Then Application.Quit
'                ThisDocument.Close savechanges:=True
                If Not disableClose Then forceCloseAllDocuments
                End
            
        End Select
    Else
        ' update用ディレクトリに到達可能　（アップデートチェックを実施）
        Dim latestVersion As String: latestVersion = "0"
        Dim latestVersionDir As String
        Dim searchNum As String, lngStaring As String
        
        Dim file As file, files As files
        Set files = fso.GetFolder(updateSearchDir).files
        For Each file In files
            searchNum = InStrRev("*" & Dir(file.path), thisProgName)
            
            If searchNum <> 0 And searchNum <> lngStaring Then
                searchNum = searchNum - 1
                Dim searchVersion As String, searchVersionNum As Long
                searchVersion = "0"
                searchVersionNum = 0
                On Error Resume Next
'                searchVersion = CLng(Mid(Dir(File.Path), Len(thisProgName) + searchNum + 1, 3))
                ' ▽　2021.02/26 12:54 修正
                searchVersion = Mid(Replace(Dir(file.path), " ", ""), Len(thisProgName) + searchNum + 1, 4)
                
                On Error GoTo 0
                If searchVersion = "" Then
                    searchVersion = "0"
                Else
                    searchVersionNum = 0
                    Dim i As Long
                    For i = 1 To Len(searchVersion)
                        If isInteger(Mid(searchVersion, i, 1)) Then
                            searchVersionNum = searchVersionNum * 10 + Mid(searchVersion, i, 1)
                        Else
                            Exit For
                        End If
                    Next i
                End If
                If searchVersionNum > CLng(thisProgVersionMajor & thisProgVersionMinor & thisProgVersionRevesion & thisProgVersionFix) Then
                    If searchVersionNum > CLng(latestVersion) Then
                        latestVersion = Str(searchVersionNum)
                        latestVersionDir = file.path
                    
                        showProgressInfo mainMsg:="アップデートを確認しています...", _
                            subMsg:=updateSearchDir & vbCrLf & _
                            "（検出バージョン:" & latestVersion & "）", initialize:=True, infoType:=pit_Info: DoEvents
                    End If
                End If

            End If
        Next file
        Set file = Nothing
        Set files = Nothing
        
        If Not CLng(latestVersion) = 0 Then
            Select Case msg("新しいバージョンの """ & thisProgName & """があるようです。" & vbCrLf & _
                    "最新版は、「" & Dir(latestVersionDir) & "」だと思われます。" & vbCrLf & _
                    "最新版のあるフォルダを開きますか？", vbQuestion + vbYesNo)
                Case vbYes
                    Shell "explorer.exe " & """" & Replace(latestVersionDir, Dir(latestVersionDir, vbDirectory), "") & """", vbMaximizedFocus
                    
                    
                    Stop
                    Stop
                    Stop
                    
'                    ThisWorkbook.save
'                    If Workbooks.Count = 1 Then Application.Quit
'                    ThisDocument.Close savechanges:=True
                    If Not disableClose Then forceCloseAllDocuments
                    End
                
                Case Else
                
            End Select
        Else
            showProgressInfo mainMsg:="インストーラーは最新のバージョンです", subMsg:=updateSearchDir, initialize:=True, infoType:=pit_Sucsess
            Sleep 500
        End If
    End If
    
    fso release:=True
    
    showProgressInfo hide:=True
End Sub

Sub openTempFolder(secure As String)
    ' 2021.01/19 14:19
    
    If secure <> secureChap Then
        msg "<ASREC-28546> (!) Error. Fail openTempFolder"
        Exit Sub
    End If
    debugPrint "openTempFolder() called.", msgDebugLevel:=dlDebug
    
'    If Dir(tempRoot, vbDirectory) <> "" Then Shell "rundll32.exe url.dll,FileProtocolHandler " & tempRoot, vbNormalFocus
    If fso.FolderExists(tempRoot) Then Shell "rundll32.exe url.dll,FileProtocolHandler " & tempRoot, vbMaximizedFocus
End Sub

Function isDecimal(value As Variant, Optional allowBlank As Boolean = False, Optional allowNegative As Boolean = False, Optional allowZero As Boolean = True) As Boolean
    ' 小数かどうか判断する関数「isDecimal」 ver19052101
    isDecimal = False
    
    Dim temp As String
    On Error Resume Next
    
    temp = value
    If Err.Number <> 0 Then Exit Function
    
    temp = CDbl(temp)
    If Err.Number = 0 Then
        If temp > 0 Then isDecimal = True
        If temp = 0 And allowZero Then isDecimal = True
        If temp < 0 And allowNegative Then isDecimal = True
        Exit Function
    End If
    
    On Error GoTo 0
End Function

Public Function isInteger(value As Variant, Optional allowBlank As Boolean = False, Optional allowNegative As Boolean = False, Optional allowZero As Boolean = True) As Boolean
    ' 整数かどうか判断する関数「isInteger」 ver19022201
    isInteger = False
    
    Dim temp As String
    On Error Resume Next
        temp = value
        If Err.Number <> 0 Then Exit Function
    On Error GoTo 0
        
    If allowNegative Then
        If left(temp, 1) = "-" Then
            temp = Mid(temp, 2, Len(temp) - 1)
        End If
    End If
    
    ' 引数は空か？
    If temp <> vbNullString Then
        ' 数字（0～9）を削除
        Dim i As Long
        For i = 0 To 9
            temp = Replace(temp, i, "")
        Next i
        ' 文字（数字以外）が残っているか？
        If temp = vbNullString Then
            isInteger = True
        End If
    Else
        If allowBlank Then
            isInteger = True
        End If
    End If
    
    If isInteger And (value = 0) Then
        If Not allowZero Then isInteger = False
    End If
End Function

'Function numToString(ByVal number As String, ByVal digit As Long) As String
'    numToString = String(digit - Len(number), "0") & number
'End Function

'Function isLocalDir(path As String) As Boolean
'    ' 2020.03/06 17:12
'
'    isLocalDir = False
'    If path <> "" Then
'        If left(path, 1) = "\" Then
'            isLocalDir = False
'        Else
'            If fso.FolderExists(path) Then
'                isLocalDir = True
'            End If
'        End If
'    End If
'End Function

Function isLocalDir(path As String) As Boolean
    ' ローカルパスか判定する関数 19052801
    isLocalDir = False
    
    If path = "" Then Exit Function
    If Not fso.DriveExists(left(path, 3)) Then Exit Function
    
    If fso.FolderExists(path) Or fso.FileExists(path) Then isLocalDir = True
End Function

'Public Function isLocalFile(path As String) As Boolean
'    ' ローカルのファイルか判定する関数 19052801
'    isLocalFile = False
'
'    If path = "" Then Exit Function
'    If Not fso.DriveExists(left(path, 3)) Then Exit Function
'
'    If fso.FileExists(path) Then isLocalFile = True
'End Function

Function isLocalFile(path As String) As Boolean
    ' 19.12/18 13:12
    ' ローカルのファイルか判定する関数
    isLocalFile = False
    
    If path = "" Then Exit Function
    If Not fso.DriveExists(left(path, 3)) Then Exit Function
    
    If fso.FileExists(path) Then isLocalFile = True
    If fso.FolderExists(path) Then isLocalFile = True
End Function

'Function isThisLocalBook() As Boolean
'    ' ローカルのブックか確認する関数 19052801
'    isThisLocalBook = False
'
'    If isLocalDir(ThisWorkbook.path) Then isThisLocalBook = True
'End Function

'Function isLocalBook() As Boolean
'    isLocalBook = False
'    If left(ThisWorkbook.path, 1) = "\" Then
'        isLocalBook = False
'    Else
'        isLocalBook = True
'    End If
'End Function

Public Function cut(text As String, fieldNo As Variant, Optional delimiter As String = ",", Optional reverseField As Boolean = False) As String
    cut = ""
'    If Not Len(delimiter) = 1 Then Exit Function
    If text = "" Then Exit Function
    If TypeName(fieldNo) = "Integer" Then
        If fieldNo < 0 Then Exit Function
    End If
    
    Dim tmpArray As Variant
    tmpArray = Split(text, delimiter)
    
    Dim fieldCount As Long
    fieldCount = UBound(tmpArray) - LBound(tmpArray) + 1
    
    Dim fieldStart As Long, fieldEnd As Long
    Dim tmpFieldNumArray As Variant
    Select Case True
        Case fieldNo Like "*-"
            fieldStart = Mid(fieldNo, 1, Len(fieldNo) - 1)
            fieldEnd = fieldCount
        Case fieldNo Like "-*"
            fieldStart = 1
            fieldEnd = Mid(fieldNo, 2, Len(fieldNo) - 1)
        Case fieldNo Like "*-*"
            tmpFieldNumArray = Split(fieldNo, "-")
            fieldStart = tmpFieldNumArray(LBound(tmpFieldNumArray))
            fieldEnd = tmpFieldNumArray(LBound(tmpFieldNumArray) + 1)
        Case Else
            fieldStart = fieldNo
            fieldEnd = fieldNo
    End Select
    
    If reverseField Then
        fieldStart = fieldCount - fieldStart + 1
        fieldEnd = fieldCount - fieldEnd + 1
    End If
    
    Dim tmpFieldNo As Long
    If fieldEnd < fieldStart Then
        tmpFieldNo = fieldStart
        fieldStart = fieldEnd
        fieldEnd = tmpFieldNo
    End If
    
    If fieldStart < 1 Then Exit Function
    If fieldEnd > fieldCount Then Exit Function
    
    Dim f As Long
    For f = fieldStart To fieldEnd Step 1
        If cut = "" Then
            If f > fieldStart Then
                cut = delimiter
            Else
                cut = tmpArray(LBound(tmpArray) + f - 1)
            End If
        Else
            cut = cut & delimiter & tmpArray(LBound(tmpArray) + f - 1)
        End If
    Next
End Function

Function isAonoSoftDirReachable() As Boolean
    ' 19.11/08 19:06
    
    isAonoSoftDirReachable = False
…
vbaProject_00.bin vba-project OOXML VBA project: word/vbaProject.bin 453120 bytes
SHA-256: f11d40e7a5eaeb75242196d7f55503dda6182a9884091949cbf187d7852ea741

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