!!紧急求助！！-关于修改保存好邮件的标题及文件名。

jesse8010

老板刚刚安排我一个工作，把outlook导出邮件更改格式保存。具体的要求是：在邮件标题前加入日期发送的日期，格式为："yymmdd - ",并且要把这份邮件的文件名前面也插入日期：格式为"yymmdd - ".
如：请看附件。
更改前，邮件的标题为"this is a test",邮件的文件名也是"this is a test".
更改后，邮件的标题为"081201 - this is a test" 邮件的文件名也改为"081201 - this is a test"

我这儿有一堆上千封邮件，求各位达人帮忙！

jesse8010

各位老大们，帮帮忙啊。我要哭了。。。书到用时方恨少！

jesse8010

求人不如求已。搞了个半自动的。依次打开每个文件，运行代码。修改后文件的保存路径可自行修改，此例为"d:\test\"。
Sub save_mail()

    'Declaration
    Dim myItems, myItem As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Object
    'Ask for destination folder
    myOrt = "d:\test\"
   
   
    'work on selected items
    Set myOlExp = myOlApp.ActiveExplorer
    Set myItem = Outlook.ActiveInspector.CurrentItem

    'Create filename
  
    strdate = myItem.SentOn
    newdate = Format(strdate, "yymmdd")
    myItem.Subject = newdate & " - " & myItem.Subject
    strSub = CleanFileName(myItem.Subject)
    strname = strSub & ".msg"
    'Save file
    myItem.SaveAs myOrt & strname
    myItem.Close olSave
  
   
'free variables
    Set myItems = Nothing
    Set myItem = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub
Function CleanFileName(strText As String) As String
    Dim strStripChars As String
    Dim intLen As Integer
    Dim i As Integer
    strStripChars = "/\[]:=," & Chr(34)
    intLen = Len(strStripChars)
    strText = Trim(strText)
    For i = 1 To intLen
        strText = Replace(strText, Mid(strStripChars, i, 1), "")
    Next
    CleanFileName = strText
End Function

aaaaabbbbb

参考一下本帖置顶的VBA集中营。下面的帖子实际上就很容易改造成你所需要的功能。
http://club.excelhome.net/viewthread.php?tid=252928&px=0

以下代码请参考。我测试过，在XP+OUTLOOK2007下运行正常。
Sub Savethemail()
    Dim olApp As New Outlook.Application
    Dim nmsName As Outlook.NameSpace
    Dim fldFolder As Outlook.Folder
    Dim vItem As Object
    Set nmsName = olApp.GetNamespace("MAPI")
    Set fldFolder = nmsName.GetDefaultFolder(olFolderInbox)
    If fldFolder.Items.count > 0 Then
        For Each vItem In fldFolder.Items
           strname = vItem.Subject '
           strname = Replace(strname, "*", "_") '
           strname = Replace(strname, "\", "_") '
           strname = Replace(strname, "/", "_") '
           strname = Replace(strname, "$", "_") '
           strname = Replace(strname, "%", "_") '
           strname = Replace(strname, "!", "_") '
           strname = Replace(strname, "~", "_") '
           strname = Replace(strname, "(", "_") '
           strname = Replace(strname, ")", "_") '
           strname = Replace(strname, "+", "_") '
           strname = Replace(strname, ":", "_") '
           strdate = Format(vItem.SentOn, "yymmdd")
           vItem.SaveAs "C:\OLtemp\" & strdate & " - " & strname & ".txt", olTXT '
        Next
    End If
    Set fldFolder = Nothing
    Set nmsName = Nothing
End Sub

blueemmma

aaaaabbbbb 发表于 2008-12-6 22:12
参考一下本帖置顶的VBA集中营。下面的帖子实际上就很容易改造成你所需要的功能。
http://club.excelhome.n ...

你好，运行时老是提示strdate = Format(vItem.SentOn, "yymmdd") 对象不支持该属性和方法，这是怎么回事呢？