Option Explicit
Sub Bsp()
Dim objMail As Outlook.MailItem
Dim objAttch As Outlook.Attachment
Dim xlApp As Object
Dim objWkb As Object
Dim strPathHTML As String
strPathHTML = "D:\"
Set objMail = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items(1)
Set objAttch = objMail.Attachments(1)
On Error GoTo ErrHandler
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
Call objAttch.SaveAsFile(Environ$("TMP") & "\" & objAttch.FileName)
Set objWkb = xlApp.Workbooks.Open(Environ$("TMP") & "\" & objAttch.FileName)
Call objWkb.SaveAs(strPathHTML & Left$(objWkb.Name, InStrRev(objWkb.Name, ".") - 1), FileFormat:=44)
Call objWkb.Close(False)
Call Kill(Environ$("TMP") & "\" & objAttch.FileName)
On Error GoTo 0
GoTo SafeExit
ErrHandler:
Call MsgBox(Err.Description, vbCritical, "Error " & Err.Number)
SafeExit:
If Not xlApp Is Nothing _
Then Call xlApp.Quit
End Sub