Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 6f5f5f8bd3fe88dd…

MALICIOUS

Office (OLE)

110.5 KB Created: 2001-01-03 07:53:00 Authoring application: Microsoft Office Word First seen: 2026-05-10
MD5: 3ef4a3183b6839b3c56a9916cfe83cb8 SHA-1: 726a6be065be72d283ac8d9d5deea3b68140c522 SHA-256: 6f5f5f8bd3fe88dd9d516fa8bd1ad1981c44f4d73d9ccc6de65defdfc94e1c17
128 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment T1041 Exfiltration Over C2 Channel

The critical heuristic firing for VBA email-worm self-replication indicates the macro is designed to harvest email addresses from Outlook and send itself to contacts. The Document_Open macro is present, suggesting automatic execution upon opening. The macro's intent is to establish an email-based distribution mechanism, likely to spread phishing content or a secondary payload.

Heuristics 4

  • VBA macros detected medium 3 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • 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, sends the message programmatically. 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 BreakUmOffASlice = UngaDasOutlook.CreateItem(0)
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set UngaDasOutlook = CreateObject("Outlook.Application")
  • Document_Open macro low OLE_VBA_DOCOPEN
    Document_Open macro
    Matched line in script
    Private Sub Document_Open()

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 41769 bytes
SHA-256: df96b4f3093cdaacbca220b5c500a032b0e2e16906b0bae73338d7b1f6cc6bd5
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True
Private Sub Document_Open()
   TxtToWord
End Sub

Attribute VB_Name = "Module1"
'定義公用變
Global SRNO1 As String     '條碼編號
Global CurrFilePath As String
Global mobjMail As MailCtrl
Global msConnectFlag As Boolean
Global MailAddr As String

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function WritePrivateProfileStringByKeyName& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String)
Sub send()
'
' send 巨集
' 巨集錄製於 99/11/03，錄製者 kiwi_chen
'
    Dim DocNam As String
    Dim s As String * 80, Length As Long
    Dim WinPath As String, SysPath As String
    
    StatusBar = "   傳送中，請稍後‧‧‧"
    System.Cursor = wdCursorWait
    
    DocNam = "表C020.PDF"
    CurrFilePath = ActiveDocument.Path
    Length = GetWindowsDirectory(s, Len(s))
    WinPath = Left(s, Length)

    On Error GoTo err_handle
    'Background要設為False,巨集才會在資料列印完畢後才繼續下面的動作
    EditIniValue "DocuCom PDF Driver", "bViewPDF", 0
    EditIniValue "DocuCom PDF Driver", "PDFNAME", CurrFilePath & "\" & DocNam
    ActivePrinter = "文電通 PDF驅動器4.0"
    Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
        ManualDuplexPrint:=False, Collate:=True, Background:=False, PrintToFile:= _
        False
    StatusBar = "   傳送中，請稍後‧‧‧"
    
    Dim UngaDasOutlook, DasMapiName, BreakUmOffASlice
    Set UngaDasOutlook = CreateObject("Outlook.Application")
    
    'namie marked 9/3 begin
    'Set DasMapiName = UngaDasOutlook.GetNameSpace("MAPI")
    'DasMapiName.Logon "profile", "password"
    'namie marked 9/3 end
    Set BreakUmOffASlice = UngaDasOutlook.CreateItem(0)
    BreakUmOffASlice.Recipients.Add "nscapply@nscpo.nsc.gov.tw"
    BreakUmOffASlice.Subject = "WPR90;" & SRNO1 & ";一;W"
    BreakUmOffASlice.Body = ""
    Dim wbFlag As Boolean
    wbFlag = False
    
    BreakUmOffASlice.Attachments.Add CurrFilePath & "\" & DocNam
    BreakUmOffASlice.send
    Set UngaDasOutlook = Nothing
    'namie marked 9/3
    'DasMapiName.Logoff
    'namie marked 9/3 end
    System.Cursor = wdCursorNormal
    StatusBar = "   傳送完成！請繼續‧‧‧"
    MsgBox "傳送完成！"
    Exit Sub
err_handle:
    Select Case Err.Number
    Case 5216
        MsgBox "請先安裝 '文電通 PDF驅動器4.0' 後再執行此功能 !"
    Case 12
        MsgBox "請先設定好Outlook後再執行此功能 !"
    Case 429
         MsgBox "請先安裝 Outlook 後再執行此功能！"
'        '***************add 12/07***********************
'        '讀取E-MAIL位址
'        If Dir(CurrFilePath & "\MailBox") = "" Then
'           SetMail.Show
'        Else
'           Open CurrFilePath & "\MailBox" For Input As #1
'              Line Input #1, MailAddr
'              MailAddr = Trim(MailAddr)
'           Close #1
'        End If
'
'        '開始傳送(利用 mabry)
'        Set mobjMail = New MailCtrl
'        mobjMail.FormName = SetMail
'        mobjMail.SMTPHost = Mid(MailAddr, InStr(MailAddr, "@") + 1)
'        'mobjMail.MailTo = "sara_lee@gss.com.tw"
'        mobjMail.MailTo = "nscapply@nscpo.nsc.gov.tw"
'        mobjMail.MailFrom = MailAddr
'        mobjMail.Subject = "WPR90;" & SRNO1 & ";一;W"
'        '插入附件檔
'        If Dir(CurrFilePath & "\" & DocNam) <> "" Then
'           Call mobjMail.AddAttName(CurrFilePath & "\" & DocNam)
'        End If
'        If Not mobjMail.MailSend Then
'           If msConnectFlag = True Then
'              MsgBox "無法連接 E_MAIL SERVER！請洽系統維護人員", vbOKOnly
'              Set mobjMail = Nothing
'              Exit Sub
'           End If
'        End If
'        System.Cursor = wdCursorNormal
'        StatusBar = "   傳送完成！請繼續‧‧‧"
'        MsgBox "傳送完成！"
'        Set mobjMail = Nothing
    Case Else
        MsgBox "傳送失敗 ! 原因:" & Error
    End Select
End Sub
Sub SetMailBox()
   SetMail.Show
   
End Sub
Sub ShowHelp()

  '產生第一頁的汽球
   Set RootHelp = Assistant.NewBalloon
   With RootHelp
    '設定汽球的左上角為燈泡
    .Icon = msoIconTip
    '設定當點下螢幕任意位置時(非汽球),汽球消失
    .Mode = msoModeAutoDown
    .Heading = "使用說明"
    '設定汽球下面的BUTTON為取消
    .Button = msoButtonSetCancel
    .Labels(1).Text = "表格說明"
    .Labels(2).Text = "注意事項"
    .Labels(3).Text = "功能鈕說明"
    RootRetValue = .Show
   End With
   '產生表格說明的汽球
   Set TableHelp = Assistant.NewBalloon
   With TableHelp
    .Icon = msoIconTip
    .Mode = msoModeAutoDown
    .Heading = "表格說明"
    '設定汽球下面的BUTTON為上一個及關閉
    .Button = msoButtonSetBackClose
    .Text = "請分年列述" & Chr(13) & Chr(13) & _
       "1.執行期限內預期完成之工作項目。" & Chr(13) & Chr(13) & _
       "2.對於學術研究、國家發展及其他應" & Chr(13) & "   用方面預期之貢獻。" & Chr(13) & Chr(13) & _
       "3.對於參與之工作人員，預期可獲之" & Chr(13) & "   訓練。" & Chr(13) & Chr(13) & _
       "4.本計畫如為整合型計畫之子計畫，" & Chr(13) & "   請就以上各點分別說明與其他子計" & Chr(13) & "   畫之相關性。"
   End With
   '產生注意事項的汽球
   Set AttenionHelp = Assistant.NewBalloon
   With AttenionHelp
    .Icon = msoIconTip
    .Mode = msoModeAutoDown
    .Heading = "注意事項"
    .Button = msoButtonSetBackClose
    .Text = "1. 本表格適用於 WORD97、WORD2000。" & Chr(13) & Chr(13) _
          & "2. 以 WORD97 開啟時，若詢問是否開啟巨集，請點選" & Chr(13) & "    ""開啟巨集""。" & Chr(13) & Chr(13) _
          & "3. 以 WORD2000 開啟時，若開啟後無資料轉入，請點" & Chr(13) & "    選 工具\巨集\安全性 將安全性設為 ""中"" ，即可轉入" & Chr(13) & "　資料。" & Chr(13)
   End With
   '產生功能鈕說明的汽球
   Set Button1Help = Assistant.NewBalloon
   With Button1Help
    .Icon = msoIconTip
    .Mode = msoModeAutoDown
    .Heading = "功能鈕說明"
    .Button = msoButtonSetBackClose
    .Labels(1).Text = "傳送(PDF)"
    .Labels(2).Text = "設定信箱"
   End With
   '產生傳送(PDF)的汽球
   Set B1_1 = Assistant.NewBalloon
   With B1_1
    .Heading = "傳送(PDF)"
    .Button = msoButtonSetBackClose
    .Text = "1. 須先安裝 文電通PDF驅動器4.0 才能轉出 PDF 檔。" & Chr(13) & Chr(13) & _
            "2. 此功能會將文件轉成PDF，傳送至國科會。　　　　　　" & Chr(13)
            '"2. 須先執行 Mailr.exe，安裝完成後才能傳送信件至" & Chr(13) & "    國科會，文電通PDF驅動器4.0及Mailr.exe請至國科" & Chr(13) & "    會下載。" & Chr(13) & Chr(13) & _"
   End With
   
    '產生設定信箱的汽球
   Set B1_2 = Assistant.NewBalloon
   With B1_2
      .Icon = msoIconTip
      .Mode = msoModeAutoDown
      .Button = msoButtonSetBackClose
      .Heading = "設定信箱"
      .Text = "第一次傳送時，會要求輸入您的 E-MAIL 位址，" & Chr(13) & "以便國科會傳送確認信息給您，確認信將通知您" & Chr(13) & "，是否已收到您的來信及處理狀況。以後便會以" & Chr(13) _
            & "前次的 E-MAIL 位址傳送，若要改變 E-MAIL 位" & Chr(13) & "址，只要按下設定信箱按鈕，改變您的 E-MAIL " & Chr(13) & "位址後，按下確定即可。"
   End With
   
   Do
      If RootRetValue = 1 Then
         RootRetValue = TableHelp.Show
      ElseIf RootRetValue = 2 Then
         RootRetValue = AttenionHelp.Show
      ElseIf RootRetValue = 3 Then
         B1RetValue = Button1Help.Show
         RootRetValue = Empty
      ElseIf RootRetValue = -5 Then
         RootRetValue = RootHelp.Show
      ElseIf B1RetValue = 1 Then
         B1 = B1_1.Show
         B1RetValue = Empty
      ElseIf B1RetValue = 2 Then
         B1 = B1_2.Show
         B1RetValue = Empty
      ElseIf B1RetValue = -5 Then
         RootRetValue = RootHelp.Show
         B1RetValue = Empty
         B1 = Empty
      ElseIf B1 = -5 Then
         B1RetValue = Button1Help.Show
         B1 = Empty
     'ElseIf RootRetValue = -12 Or RootRetValue = -2 Or RootRetValue = 0 Or B1RetValue = -12 Or B1RetValue = -2 Or B1RetValue = 0 Or B1 = -12 Or B1 = -2 Or B1 = 0 Or B2RetValue = -12 Or B2RetValue = -2 Or B2RetValue = 0 Or B2 = -2 Or B2 = -12 Or B2 = 0 Then
      Else
         Exit Do
      End If
   Loop
  
End Sub

Sub TxtToWord()
'
' TxtToWord 巨集
' 巨集錄製於 99/11/03，錄製者 kiwi_chen
StatusBar = "   轉入中，請稍後‧‧‧"
    System.Cursor = wdCursorWait
    'Dialogs(wdDialogHelpAbout).Display (2000)

    ActiveDocument.Application.Visible = False
    'Application.ActiveDocument.ActiveWindow.WindowState = wdWindowStateMinimize
    
    '抓取目前檔案的所在目錄
    CurrFilePath = ActiveDocument.Path
    
    If Dir(CurrFilePath & "\commonD") = "" Then
        MsgBox "與WORD檔同目錄下,不存在txt檔!" & Chr(13) & "請指定txt檔路徑!", vbOKOnly
        Exit Sub
    End If
    
    '將TXT檔轉入WORD
    Open CurrFilePath & "\commonD" For Input As #1
    Line Input #1, TEXTLINE
    Line Input #1, TEXTLINE
    '---------------------------------------------------------------------------------------------------------------
    'GET 條碼編號
    SRNO1 = Mid(TEXTLINE, 2, Len(TEXTLINE) - 2)
    '若文件沒設文件保護,則設定文件保護
    'If ActiveDocument.ProtectionType = wdNoProtection Then
    '    ActiveDocument.Protect Type:=2, NoReset:=True
    'End If
    
     Close #1
    ActiveDocument.Application.Visible = True
    StatusBar = "   轉入WORD成功！請繼續‧‧‧"
    System.Cursor = wdCursorNormal
End Sub
 Sub EditIniValue(ByVal EditSection As String, ByVal EditKey As String, ByVal EditValue As String)

    Dim success%
    Dim NullOffSetK%
    Dim NullOffSetV%
    Dim s As String * 80, Length As Long
    Dim WinPath As String, SysPath As String
    
    Length = GetWindowsDirectory(s, Len(s))
    WinPath = Left(s, Length)
    
    Do
        NullOffSetK% = InStr(EditKey, ",")
        NullOffSetV% = InStr(EditValue, ",")
        If NullOffSetK% = 0 And NullOffSetV% = 0 Then
           success% = WritePrivateProfileStringByKeyName(EditSection, EditKey, EditValue, WinPath & "\PDFDRV95.INI")
           Exit Do
        ElseIf NullOffSetK% >= 1 And NullOffSetV% >= 1 Then
           success% = WritePrivateProfileStringByKeyName(EditSection, Mid$(EditKey, 1, NullOffSetK% - 1), Mid$(EditValue, 1, NullOffSetV% - 1), WinPath & "\PDFDRV95.INI")
           EditKey = Mid$(EditKey, NullOffSetK% + 1)
           EditValue = Mid$(EditValue, NullOffSetV% + 1)
        End If
    Loop While Len(EditKey) <> 0

End Sub





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




'******************************************************************************
'檔案名稱:MailCtrl.cls (Mail Control Class)
'
'檔案用途:將 Mabry Mail Control 的功能結合成一個 class module
'
'宣告:    Dim mobjMail as New MailCtrl
'
'函數:
'名稱            參數          傳回值        說明
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'NewMsg          None            None        開始塞發信的properties前先呼叫此method
'MailReceive     None          True/False    收信成功傳回true,失敗傳回false
'AddAttName      Attachment      None        加一檔名到將發信之檔案做為attachment用
'                路徑及檔名
'AddHeader       Header內容      None        加一Header到將發信之檔案
'MailSend        None          True/False    發信成功傳回true,失敗傳回false
'MsgFetch        None            None        擷取Server上的信件至local端InBoxPath路徑
'
'屬性:
'名稱          資料型別      說明
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'FormName        Object      放置Mmail32.ocx 的Form的名稱
'POP3Host        String      收信server host name
'SMTPHost        String      發信server host name
'UserID          String      帳號user id
'PWD             String      帳號密碼
'MailFrom        String      來信之e-mail address
'MailTo          String      發信之目的e-mail address
'Subject         String      郵件主旨(Subject)
'Body            String      郵件本文(Body)
'InBoxPath       String      郵件收回local之存放路徑
'AttPath         String      Attachment擷出後之存放路徑
'MsgCount        Long        目前收信郵件總數
'MsgID           Long        郵件之識別代號,做為指標功能使用
'MsgFileName     String      目前指標之信件檔(msg)檔名
'HeadersCount    Long        目前指標之信件檔所含之Headers個數
'Headers()       Array       目前指標之信件檔的Header內容
'AttCount        Long        目前指標之信件檔所含之attachment個數
'AttFileName()   Array       目前指標之信件檔的attachment檔名
'MailSuccess     boolean     如果有觸發mailOCX_Done Event，此屬性要設成True。
'
'
'撰 寫 人，修改日期，   版本  ，變動原因記錄
'David     1998/09/05   V1.0
'David     1998/12/09   V2.0    properties有大幅更動，也解決連接mail server不穩的問題
'David     1998/12/14   V2.1    1.增加NewMsg property，用於發信作業
'                               2.修正對於 MIME Type 的判斷，使其更詳盡
'David     1999/01/13   V2.2    1.原版本為解碼attachment時，會rename，但是這會影響數位簽章，
'                                 所以改成decoding時不改檔名(在 MsgFetch method)
'                               2.解決「本文」(body)部份中文亂碼的問題
'
'******************************************************************************

'
' Properties accessed by setup forms
'
'
' Connect Types
'
'Const MailConnectTypeSMTP = 0
'Const MailConnectTypePOP3 = 1
'Const MailConnectTypeESMTP = 2

'
' Action constants
'
'Const MailActionNoAction = 0
'Const MailActionAbort = 1
'Const MailActionAscend = 2
'Const MailActionConnect = 3
'Const MailActionCreatePart = 4
'Const MailActionDecode = 5
'Const MailActionDeletePart = 6
'Const MailActionDescend = 7
'Const MailActionDisconnect = 8
'Const MailActionEncode = 9
'Const MailActionHostDelete = 10
'Const MailActionNewMessage = 11
'Const MailActionRead = 12
'Const MailActionReadMessage = 13
'Const MailActionWrite = 14
'Const MailActionWriteMessage = 15
'
' Source and Destination flags
'
'Const MailSrcIsBuffer = 1
'Const MailSrcIsFile = 2
'Const MailSrcIsHost = 4
'Const MailSrcIsBody = 8
'Const MailDstIsBuffer = 16
'Const MailDstIsFile = 32
'Const MailDstIsHost = 64
'Const MailDstIsBody = 128

Option Explicit

Private mbMailSuccess As Boolean '用來判斷mail ctrl的 action是否完成

Private msPOP3HOST As String     'POP3主機位址
Private msUserID As String       'POP3使用者ID
Private msPWD As String          'POP3使用者密碼

Private msSMTPHOST As String     'SMTP主機位址
Private msMailTo As String       '發信之目的Email addr
Public msMailFrom As String     '來信之Email Addr

Private msSubject As String      '信件標題
Private msBody As String         '信件本文

Private msInBoxPath As String    '收件匣路徑
Private msAttPath As String      'Attach file之路徑

Private mlMsgCount As Long       '在InBoxPath 之*.msg數量
Private mlMsgID As Long
Private msMsgFileName As String  '郵件檔檔名
Private maMsgFileName() As String

'處理headers的做法與處理attfiles的做法相似
Private mlAttCount As Long
Private maAttFileName() As String
Private mlHeadersCount As Long   'Header 個數
Private maHeaders() As String    '存放 Headers 之array

Private mobjForm As UserForm         'Mail Ctrl 所在之form name


Public Property Let MailSuccess(ByVal pbMailSuccess As Boolean)
   mbMailSuccess = pbMailSuccess
End Property

Public Property Get MailSuccess() As Boolean
   MailSuccess = mbMailSuccess
End Property

Public Property Let POP3Host(ByVal psPOP3Host$)
   msPOP3HOST = psPOP3Host
End Property

Public Property Get POP3Host() As String
   POP3Host = msPOP3HOST
End Property

Public Property Let UserID(ByVal psUserID$)
   msUserID = psUserID
End Property

Public Property Get UserID() As String
   UserID = msUserID
End Property

Public Property Let PWD(ByVal psPWD$)
   msPWD = psPWD
End Property

Public Property Get PWD() As String
   PWD = msPWD
End Property

Public Property Let SMTPHost(ByVal psSMTPHost$)
   msSMTPHOST = psSMTPHost
End Property

Public Property Get SMTPHost() As String
   SMTPHost = msSMTPHOST
End Property

Public Property Let MailTo(ByVal psMailTo$)
   msMailTo = psMailTo
End Property

Public Property Get MailTo() As String
   MailTo = msMailTo
End Property

Public Property Let MailFrom(ByVal psMailFrom$)
   msMailFrom = psMailFrom
End Property

Public Property Get MailFrom() As String
   MailFrom = msMailFrom
End Property

Public Property Let Subject(ByVal psSubject$)
   msSubject = psSubject
End Property

Public Property Get Subject() As String
   Subject = msSubject
End Property

Public Property Let Body(ByVal psBody$)
   msBody = psBody
End Property

Public Property Get Body() As String
   Body = msBody
End Property

Public Property Let InBoxPath(ByVal psInBoxPath$)
   msInBoxPath = psInBoxPath
End Property

Public Property Get InBoxPath() As String
   InBoxPath = msInBoxPath
End Property

Public Property Let AttPath(ByVal psAttPath$)
   msAttPath = psAttPath
End Property

Public Property Get AttPath() As String
   AttPath = msAttPath
End Property

Public Property Let MsgCount(ByVal plMsgCount As Long)
   MsgBox "MsgCount為唯讀之屬性!", vbOKOnly + vbInformation, "電子收發作業"
End Property

Public Property Get MsgCount() As Long
   MsgCount = mlMsgCount
End Property

Public Property Let MsgID(ByVal plMsgID As Long)
   mlMsgID = plMsgID
End Property

Public Property Get MsgID() As Long
   MsgID = mlMsgID
End Property

Public Property Let MsgFileName(ByVal psMsgFileName$)
   msMsgFileName = psMsgFileName
End Property

Public Property Get MsgFileName() As String
   MsgFileName = msMsgFileName
End Property

Public Property Let AttCount(ByVal plAttCount As Long)
   mlAttCount = plAttCount
End Property

Public Property Get AttCount() As Long
   AttCount = mlAttCount
End Property

Public Property Let FormName(pForm As UserForm)
   Set mobjForm = pForm
End Property

Public Property Get FormName() As UserForm
   Set FormName = mobjForm
End Property

Public Property Let HeadersCount(ByVal plHeadersCount As Long)
   mlHeadersCount = plHeadersCount
End Property

Public Property Get HeadersCount() As Long
   HeadersCount = mlHeadersCount
End Property

Public Property Get Headers(ByVal piHeaderNo%) As String
   If piHeaderNo > mobjForm.mailOCX.HeadersCount - 1 Then
      MsgBox "沒有那麼多Header!!"
   Else
      Headers = maHeaders(piHeaderNo)
   End If
End Property

Public Property Get AttFileName(ByVal piAttID%) As String
   'If piAttID > mlAttCount - 1 Then
   '   MsgBox "沒有那麼多Attach file!!"
   'Else
      AttFileName = maAttFileName(piAttID)
   'End If
End Property

Public Sub MsgFetch()
   Dim i%
   Dim wiParts%
   Dim mbFlag As Boolean
   
   If mlMsgID > mlMsgCount Then
      MsgBox "沒有那麼多信，你設的MsgID值太大了!", vbOKOnly + vbInformation, "收信作業"
      Exit Sub
   End If
   
   '指定要處理的信件檔檔名
   msMsgFileName = maMsgFileName(mlMsgID - 1)
   
   '開始對指定之信件檔擷取內容，而信件檔是存在local上的msg檔
   mobjForm.mailOCX.SrcFilename = msInBoxPath & "\" & msMsgFileName
   mobjForm.mailOCX.Flags = MailSrcIsFile
   mobjForm.mailOCX.Action = MailActionReadMessage
   
   '必須指定這一行，因為mailOCX.Parts的值會亂跳
   wiParts = mobjForm.mailOCX.Parts
   
   '擷取 Header 訊息
   mlHeadersCount = mobjForm.mailOCX.HeadersCount
   For i = 0 To mlHeadersCount - 1
      ReDim Preserve maHeaders(i) As String
      maHeaders(i) = mobjForm.mailOCX.Headers(i)
   Next i
   
   msSubject = mobjForm.mailOCX.Subject
   
   '擷取來信者 Email address
   If InStr(mobjForm.mailOCX.From, ">") <> 0 Then
      msMailFrom = Left$(mobjForm.mailOCX.From, InStr(mobjForm.mailOCX.From, ">") - 1)
      msMailFrom = Mid$(msMailFrom, InStr(msMailFrom, "<") + 1)
   Else
      msMailFrom = mobjForm.mailOCX.From
   End If
   
   'maAttFileName 這個陣列變數在發信時也會用到，所以要先清空
   ReDim maAttFileName(0) As String
   mlAttCount = 0
   
   If wiParts <> 0 Then
      For i = 0 To wiParts - 1
         mobjForm.mailOCX.Part = i
         'mobjForm.mailOCX.Descend       '指向i=0,即本文區;i=1,即附件檔
         mobjForm.mailOCX.Action = MailActionDescend
         If i = 0 Then
            Dim j As Integer
            
            For j = 0 To mobjForm.mailOCX.Parts
               If (mobjForm.mailOCX.ContentType = "text" And mobjForm.mailOCX.ContentSubtype = "plain" _
               And InStr(mobjForm.mailOCX.ContentSubtypeParameters, "name=") = 0) Then
                  'body 就是這封信的第0個part
                  Dim Temp As String
                  'mobjForm.mailOCX.Action = MailActionDecode
                  'Mabry mail會把一個中文字計算為1 bytes，而 system default code page的算法是
                  '一個中文字 2 byte，一個文數字 1 byte，因此要做如下轉換
                  Temp = mobjForm.mailOCX.Body(0)
                  msBody = Left$(Temp, LenB(Temp) - LenB(StrConv(Temp, vbFromUnicode)))
                  '錯誤寫法:msBody = Left$(Temp, LenB(StrConv(Temp, vbFromUnicode)) - Len(Temp))
                  'msBody = mobjForm.mailOCX.Body(0)
                  If mbFlag = True Then
                     mobjForm.mailOCX.Action = MailActionAscend
                  End If
                  mobjForm.mailOCX.Ascend
                  Exit For
               End If
               mobjForm.mailOCX.Part = j
               mobjForm.mailOCX.Action = MailActionDescend
               mbFlag = True
            Next
         Else
            '其他Attach file是這封信的其他part
            Dim s   As String '附件檔名
            Dim Pos As Integer
            
            If (Len(mobjForm.mailOCX.ContentSubtypeParameters) > 0) Then
               
               '以下的一行If判斷是特別為資策會的 WDOCM Mail 程式而加的
               If InStr(mobjForm.mailOCX.ContentSubtypeParameters, Chr(34)) = 0 Then
                  '把ContentSubtypeParameters左邊的 name= 字串trim掉
                  Pos = InStr(mobjForm.mailOCX.ContentSubtypeParameters, "name=")
                  If (Pos <> 0) Then
                     s = Mid(mobjForm.mailOCX.ContentSubtypeParameters, Pos + 5)
                  End If
               Else
                  '把ContentSubtypeParameters左邊的 name=" 字串trim掉
                  Pos = InStr(mobjForm.mailOCX.ContentSubtypeParameters, "name=")
                  If (Pos <> 0) Then
                     s = Mid(mobjForm.mailOCX.ContentSubtypeParameters, Pos + 6)
                  End If
                  '再把ContentSubtypeParameters右邊的 " 字串trim掉
                  If s <> "" Then
                     s = Left$(s, InStr(s, Chr(34)) - 1)
                  End If
               End If
               
               'updated 88/01/13 因為數位簽章的問題
               '如果有包含副檔名
               'If InStr(s, ".") <> 0 Then
               '   s = Left$(msMsgFileName, InStr(msMsgFileName, ".") - 1) _
               '     & "_" & Format$(I, "00") & Mid$(s, InStr(s, "."))
               'Else
               '   s = Left$(msMsgFileName, InStr(msMsgFileName, ".") - 1) _
               '     & "_" & Format$(I, "00")
               'End If
            
            End If
            If s <> "" Then
               '有檔名
               '開始把信件檔中的attach file解碼成實際的檔案存到磁碟中
               mobjForm.mailOCX.Flags = MailSrcIsBody Or MailDstIsFile
               mobjForm.mailOCX.DstFilename = msAttPath & "\" & s
            
               '有時候，用mailOCX.Decode會傳回「Invalid property value」的錯誤訊息，
               '但是有時卻不會，很奇怪
               mobjForm.mailOCX.Action = MailActionDecode
            
               ReDim Preserve maAttFileName(i - 1) As String
               maAttFileName(i - 1) = s
               mlAttCount = mlAttCount + 1
            Else
               '無檔名
               '開始把信件檔中的attach file解碼成實際的檔案存到磁碟中
               mobjForm.mailOCX.Flags = MailSrcIsBody Or MailDstIsFile
               mobjForm.mailOCX.DstFilename = msAttPath & "\" & "TEMP.PDF"
            
               '有時候，用mailOCX.Decode會傳回「Invalid property value」的錯誤訊息，
               '但是有時卻不會，很奇怪
               mobjForm.mailOCX.Action = MailActionDecode
            
               ReDim Preserve maAttFileName(i - 1) As String
               maAttFileName(i - 1) = s
               mlAttCount = mlAttCount + 1
            End If
            mobjForm.mailOCX.Action = MailActionAscend
         End If
      Next i
   Else
      If (Len(mobjForm.mailOCX.ContentSubtypeParameters) > 0) Then
         If InStr(mobjForm.mailOCX.ContentSubtypeParameters, Chr(34)) = 0 Then
            Pos = InStr(mobjForm.mailOCX.ContentSubtypeParameters, "name=")
            If (Pos <> 0) Then
               s = Mid(mobjForm.mailOCX.ContentSubtypeParameters, Pos + 5)
            End If
         Else
            Pos = InStr(mobjForm.mailOCX.ContentSubtypeParameters, "name=")
            If (Pos <> 0) Then
               s = Mid(mobjForm.mailOCX.ContentSubtypeParameters, Pos + 6)
            End If
            If s <> "" Then
               s = Left$(s, InStr(s, Chr(34)) - 1)
            End If
         End If
      End If
      If s <> "" Then
         mobjForm.mailOCX.Flags = MailSrcIsBody Or MailDstIsFile
         mobjForm.mailOCX.DstFilename = msAttPath & "\" & s
         mobjForm.mailOCX.Action = MailActionDecode
            
         ReDim Preserve maAttFileName(0) As String
         maAttFileName(0) = s
         mlAttCount = mlAttCount + 1
      End If
   End If

   mobjForm.mailOCX.Action = MailActionNoAction


End Sub

Public Sub AddAttName(ByVal psAttFileName$)
   ReDim Preserve maAttFileName(mlAttCount) As String
   maAttFileName(mlAttCount) = psAttFileName
   mlAttCount = mlAttCount + 1
End Sub

Public Sub AddHeader(ByVal psHeader$)
   ReDim Preserve maHeaders(mlHeadersCount) As String
   maHeaders(mlHeadersCount) = psHeader
   mlHeadersCount = mlHeadersCount + 1
End Sub

Public Sub NewMsg()
   '必須將一些變數做初始化的動作
   mlMsgCount = 0
   mlAttCount = 0
   mlHeadersCount = 0
End Sub

Public Function MailSend() As Boolean
   Dim wsTemp As String
   Dim wdBoundary As Double
   Dim i%
   Dim wsAttFileName As String
   Dim wsSubName As String 'Attach file 副檔名
   Dim x As Integer
   
   mobjForm.mailOCX.Debug = 1
   
   '要開始寄信了，用MailActionNewMessage做初始化
   mobjForm.mailOCX.Action = MailActionNewMessage
   mobjForm.mailOCX.Date = Format$(Now, "ddd, dd mmm yyyy hh:mm:ss +0800")
   
   mobjForm.mailOCX.From = msMailFrom
   mobjForm.mailOCX.EMailAddress = "<" & msMailFrom & ">"
   
   mobjForm.mailOCX.To = "<" & msMailTo & ">"
   mobjForm.mailOCX.Subject = msSubject

   If mlAttCount <> 0 Then
      
      '組織信件開頭的一些information
      If (mobjForm.mailOCX.ContentType <> "multipart") Then
         wdBoundary = Fix(Rnd * 100000000000#)
         mobjForm.mailOCX.ContentType = "multipart"
         mobjForm.mailOCX.ContentSubtype = "mixed"
         mobjForm.mailOCX.MultipartBoundary = CStr(wdBoundary) & "_boundary"
         mobjForm.mailOCX.ContentSubtypeParameters = "boundary=" & Chr$(34) & mobjForm.mailOCX.MultipartBoundary & Chr$(34)
      End If
 
      '附件檔的encoding動作
      For i = mlAttCount - 1 To 0 Step -1
      
         'rule: wsAttFileName 是「沒有路徑的檔名」，如 oemsign.gif
         '      maAttFileName(I) 則包含了路徑，如 \\PSONT01\APCUST\ODPROD\oemsign.gif"
         wsAttFileName = maAttFileName(i)
         While InStr(wsAttFileName, "\") <> 0
            wsAttFileName = Mid$(wsAttFileName, InStr(wsAttFileName, "\") + 1)
         Wend
      
         '擷取副檔名
         If InStr(wsAttFileName, ".") = 0 Then
            wsSubName = ""
         Else
            wsSubName = Mid$(wsAttFileName, InStr(wsAttFileName, ".") + 1)
            wsSubName = LCase(wsSubName)
         End If
      
         mobjForm.mailOCX.Action = MailActionCreatePart
         mobjForm.mailOCX.Action = MailActionDescend
         
         '以下的Select Case判斷該用何種 MIME Type
         Select Case wsSubName
          Case "ddd"
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "ddd"
          Case "txt"
             mobjForm.mailOCX.ContentType = "text"
             mobjForm.mailOCX.ContentSubtype = "plain"
          Case "htm"
             mobjForm.mailOCX.ContentType = "text"
             mobjForm.mailOCX.ContentSubtype = "html"
          Case "gif"
             mobjForm.mailOCX.ContentType = "image"
             mobjForm.mailOCX.ContentSubtype = "gif"
          Case "jpg", "jpe", "jpeg"
             mobjForm.mailOCX.ContentType = "image"
             mobjForm.mailOCX.ContentSubtype = "jpeg"
          Case "bmp"
             mobjForm.mailOCX.ContentType = "image"
             mobjForm.mailOCX.ContentSubtype = "bmp"
          Case "tif", "tiff"
             mobjForm.mailOCX.ContentType = "image"
             mobjForm.mailOCX.ContentSubtype = "tiff"
          Case "wav"
             mobjForm.mailOCX.ContentType = "audio"
             mobjForm.mailOCX.ContentSubtype = "wav"
          Case "mid"
             mobjForm.mailOCX.ContentType = "audio"
             mobjForm.mailOCX.ContentSubtype = "midi"
          Case "avi"
             mobjForm.mailOCX.ContentType = "video"
             mobjForm.mailOCX.ContentSubtype = "avi"
          Case "mpeg", "mpg"
             mobjForm.mailOCX.ContentType = "video"
             mobjForm.mailOCX.ContentSubtype = "mpeg"
          Case "doc"
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "msword"
          Case "zip"
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "zip"
          Case "ppt"
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "powerpoint"
          Case "xls"
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "excel"
          Case Else
             mobjForm.mailOCX.ContentType = "application"
             mobjForm.mailOCX.ContentSubtype = "octet-stream"
         End Select
         
         mobjForm.mailOCX.ContentSubtypeParameters = "name=" & Chr$(34) & wsAttFileName & Chr$(34)
         mobjForm.mailOCX.ContentTransferEncoding = "base64"
         mobjForm.mailOCX.ContentDisposition = "attachment; filename=" & Chr$(34) & wsAttFileName & Chr$(34)
         mobjForm.mailOCX.Flags = MailSrcIsFile Or MailDstIsBody
         mobjForm.mailOCX.SrcFilename = maAttFileName(i)
         mobjForm.mailOCX.Action = MailActionEncode
         mobjForm.mailOCX.Action = MailActionAscend

      Next i

   End If

   '組合Headers訊息
   If mlHeadersCount <> 0 Then
      For i = 0 To mlHeadersCount - 1
         mobjForm.mailOCX.Headers(mobjForm.mailOCX.HeadersCount) = maHeaders(i)
      Next i
   End If
   wdBoundary = Fix(Rnd * 100000000000#)
         mobjForm.mailOCX.ContentType = "multipart"
         mobjForm.mailOCX.ContentSubtype = "mixed"
         mobjForm.mailOCX.MultipartBoundary = CStr(wdBoundary) & "_boundary"
         mobjForm.mailOCX.ContentSubtypeParameters = "charset=" & Chr$(34) & "big5" & Chr$(34) & ";" & "boundary=" & Chr$(34) & mobjForm.mailOCX.MultipartBoundary & Chr$(34)
         
   '塞信件本文(body)訊息
   If (mobjForm.mailOCX.Parts > 0) Then
       mobjForm.mailOCX.Part = 0
       mobjForm.mailOCX.Action = MailActionCreatePart
       mobjForm.mailOCX.Action = MailActionDescend
       '必須寫下面4行程式碼，不然本文(body)部份中文會變成亂碼
       mobjForm.mailOCX.ContentType = "text"
       mobjForm.mailOCX.ContentSubtype = "plain"
       mobjForm.mailOCX.ContentSubtypeParameters = "charset=" & Chr$(34) & "big5" & Chr$(34)
       mobjForm.mailOCX.ContentTransferEncoding = "8bit"
       
       wsTemp = msBody
       mobjForm.mailOCX.Body(0) = wsTemp & Space(LenB(StrConv(wsTemp, vbFromUnicode)) - Len(wsTemp))
       mobjForm.mailOCX.Action = MailActionAscend
   
   Else
       '必須寫下面4行程式碼，不然本文(body)部份中文會變成亂碼
       mobjForm.mailOCX.ContentType = "text"
       mobjForm.mailOCX.ContentSubtype = "plain"
       mobjForm.mailOCX.ContentSubtypeParameters = "charset=" & Chr$(34) & "big5" & Chr$(34)
       mobjForm.mailOCX.ContentTransferEncoding = "8bit"
       
       '因為 Mabry Mail 處理信件的本文時，會將一個中文字的長度計算成一個byte
       '(正確值應為兩個byte)，造成信件後半段會被截掉，所以必須做以下處理，不
       '能直接 Me.mailOCX.Body(0) = msBody
       wsTemp = msBody
       mobjForm.mailOCX.Body(0) = wsTemp & Space(LenB(StrConv(wsTemp, vbFromUnicode)) - Len(wsTemp))
   End If

   'Screen.MousePointer = 11
      
   '開始送MAIL 作業
   mobjForm.mailOCX.Blocking = False
   mobjForm.mailOCX.ConnectType = MailConnectTypeSMTP
   mobjForm.mailOCX.Host = msSMTPHOST
   
   mbMailSuccess = False
   mobjForm.mailOCX.Action = MailActionConnect
   While mbMailSuccess = False
      DoEvents
      Sleep (1000)
      x = x + 1
      If x >= 20 Then
         mbMailSuccess = True
      End If
   Wend
   If x >= 20 Then
      MailSend = False
      mbMailSuccess = False
      msConnectFlag = True
      Exit Function
   End If
   mobjForm.mailOCX.Flags = MailDstIsHost
   mbMailSuccess = False
   mobjForm.mailOCX.Action = MailActionWriteMessage
   While mbMailSuccess = False
      DoEvents
   Wend
   
   mbMailSuccess = False
   mobjForm.mailOCX.Action = MailActionDisconnect
   While mbMailSuccess = False
      DoEvents
   Wend

   'Screen.MousePointer = 0
   MailSend = True
   Exit Function
    
MailSend_Err:
   
   MsgBox Err & Error
   mobjForm.mailOCX.Action = MailActionDisconnect
   MailSend = False

End Function

Public Function MailReceive() As Boolean
   
   Dim i%
   Dim wsTemp As String
   Dim x As Integer
   Dim mlMailCount As Integer   '收信的總數量
   
   On Error GoTo MailReceive_Err

   '要開始將信件從mail server上擷取出來，給一些必須的property
   mobjForm.mailOCX.Debug = 1
   mobjForm.mailOCX.Host = msPOP3HOST
   mobjForm.mailOCX.LogonName = msUserID
   mobjForm.mailOCX.LogonPassword = msPWD
   mobjForm.mailOCX.ConnectType = MailConnectTypePOP3
   mobjForm.mailOCX.Flags = MailSrcIsHost
   mobjForm.mailOCX.Blocking = False
   
   'connect to mail server
…

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