OUTLOOK的转发自动带附件功能及邮件分类功能

诺诺123123

现在经常用OUTLOOK进行工作的申请、批复，发现OUTLOOK的转发功能 ，有的附件可以在转发的时候还在，有的附件在转发的时候就消失了，请问有没有办法在转发的时候自动带之前邮件的附件？
想对OUTLOOK的文件进行分类，看了论坛里的那些插件，发现都是英文版的啊，看的是头晕眼花啊，有中文版的可以实现这个功能的吗？

刚下载了这个插件bxAutoZip for Outlook，插件介绍是可以对邮件的附件进行自动压缩，可是安装的时候都是英文版，装完没发现邮件有啥不同啊，请问有谁知道这个插件的吗？

OUTLOOK刚使用，还是菜鸟一只，希望大神能够出现啊

诺诺123123

在线等。。。。。。。。。。。。。。。。。。。。。。。。

Kelidai

1. 
   
2. Private Sub CommandButton4_Click()
   
3. Application.ScreenUpdating = False
   
4. Application.Calculation = xlCalculationManual
   
5. Dim i ,j As Integer
   
6. Sheet1.Hyperlinks.Delete
   
7. Sheet1.Columns("B:B").HorizontalAlignment = xlCenter
   
8. Dim MyName, dic, Did, t, F, TT, MyFileName, objShell, objFolder, lj, Ke, sz, Sh, rng As Range, cell As Range, Myr&, arr, d, k
   
9. Dim objOL As Object
   
10. Dim RS1, RS2, db1
    
11.     Dim itmNewMail As Object
    
12. lj = "D:\works\order\NORMAL"
    
13. 'lj = "C:\Documents and Settings\franklin.dai\My Documents\我的扫描"
    
14.     Set dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
15.     Set Did = CreateObject("Scripting.Dictionary")
    
16.     dic.Add (lj), ""
    
17.     i = 0
    
18.     Do While i < dic.Count
    
19.         Ke = dic.keys   '开始遍历字典
    
20.         MyName = Dir(Ke(i), vbDirectory)    '查找目录
    
21.         Do While MyName <> ""
    
22.             If MyName <> "." And MyName <> ".." Then
    
23.                 If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
24.                     dic.Add (Ke(i) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
25.                 End If
    
26.             End If
    
27.             MyName = Dir    '继续遍历寻找
    
28.         Loop
    
29.         i = i + 1
    
30.     Loop
    
31.     Did.Add ("文件清单"), ""
    
32.     For Each Ke In dic.keys
    
33.         MyFileName = Dir(Ke & "*.*")
    
34.         Do While MyFileName <> ""
    
35.             Did.Add (Ke & MyFileName), ""
    
36.             MyFileName = Dir
    
37.         Loop
    
38.     Next
    
39.     Sh = Did.keys
    
40. 
    
41. Set d = CreateObject("Scripting.Dictionary")
    
42. Myr = Sheet1.[A65536].End(xlUp).Row
    
43. arr = Sheet1.Range("B1:D" & Myr)
    
44. For i = 3 To UBound(arr)
    
45.     d(arr(i, 1) & "-" & arr(i, 3)) = arr(i, 2)
    
46. Next
    
47. k = d.keys
    
48. t = d.items
    
49. For i = 0 To d.Count - 1
    
50.     Set db1 = OpenDatabase(stpath, False, False, ";pwd=2345")
    
51.     Set RS2 = db1.OpenRecordset(Name:="供应商资料", Type:=dbOpenDynaset)
    
52.    RS2.FindFirst "Vendor_code ='" & t(i) & "'"
    
53.    For j = 0 To Did.Count - 1
    
54.    If Sh(j) Like "*" & k(i) & "*.*" Then
    
55.     Set objOL = CreateObject("Outlook.Application")
    
56.     Set itmNewMail = objOL.CreateItem(olMailItem)
    
57.     With itmNewMail
    
58.         .Subject = "订单" & "-" & k(i)
    
59.         .body = Left(RS2.Fields("Contact").Value, 1) & "经理" & ":" & Chr(13) & "请尽快安排附件的订单，记得及时回传确认，并每周四提供一次交期确认" & Chr(13) & Chr(13) & "ABC （ABC）" & Chr(13) & "采购经理" & Chr(13) & "深圳ABC数字通信有限公司" & Chr(13) & "Tel: 0755-888XXXXX-8888" & Chr(13) & "Fax: 0755-888XXXXX"
    
60.        .To = RS2.Fields("E-Mail").Value
    
61.         .Attachments.Add Sh(j)
    
62.         .Display
    
63.         DoEvents
    
64.         SendKeys "%s", Wait:=True
    
65.         SetTimer 0, 1000, 0, AddressOf WinProcA
    
66.         End With
    
67.     Set objOL = Nothing
    
68.     Set itmNewMail = Nothing
    
69.     Exit For
    
70.     End If
    
71.   Next j
    
72.   Next i
    
73. Application.ScreenUpdating = True
    
74. Application.Calculation = xlCalculationAutomatic
    
75. End Sub
    
76. 
    
77. 主要功能：查找指定文件下的文件。
    
78.               根据供应商资料查找邮件地址
    
79.               将符合要求的文件作为附件发送。
    

复制代码

Kelidai

Kelidai 发表于 2014-6-4 15:20

这个供参考。

诺诺123123

Kelidai 发表于 2014-6-4 15:25
这个供参考。

这是啥啊，

闻启学

OUTLOOK的文件进行分类
应该是邮件吧

这个可以用规则进行