excel郵件寄發多問題

Mindyj

請問各位先進郵件發送的問題，此檔案是根據使用者的選擇進行郵件發送，目前的問題如下：
1.讓使用者以sheet1選擇要夾帶的檔案位置，在點選import時會出現Application.GetOpenFilename，裡面可以選擇各式的檔案(ex：PDF、TXT、WORD、EXCEL)，在選取檔案後會將檔案位置顯示在儲存格c7的位置


2.根據使用者的選擇條件，將報告類別依sheet2中不同收信者的要求進行寄發郵件，當中所遇到的問題：
  2.1 將所選擇的報告轉為pdf並夾帶
  2.2 將所選擇的報告以html型式放在郵件的主文中
  2.3 選擇的報告型態，依收件者不同的需求進行發送(TRUE代表發送、FALSE代表不發送)
  2.4 郵件尾插入簽名檔
  2.5 SHEET1中的發送按鍵會依使用者所選取的功能進行郵局發送，顯示於OUTLOOK中進行確認

3. 增加收件者c.c.與b.c.c.，標題為報告型態，主文的問候語則參照A10之後的內文。

以上問題，資質不足，研究了一個月還是解決不了，麻煩大家幫忙。謝謝

Book1.rar (9.22 KB)

test
下載次數: 13

2013-5-23 10:50

Mindyj

目前研究出選取夾帶檔案路徑為：

1. Sub Import1()
   
2. Dim fd As FileDialog
   
3.     Set fd = Excel.Application.FileDialog(msoFileDialogFilePicker)
   
4.    
   
5.     fd.Filters.Add "Excel File", "*.xls*" 'set the catch function
   
6.     fd.Filters.Add "Word File", "*.doc*"
   
7.     fd.Filters.Add "Txt File", "*.txt*"
   
8.     fd.Filters.Add "all files", "*.*"
   
9.         
   
10.     fd.Show 'show the dialog window
    
11.    
    
12.     For i = 1 To fd.SelectedItems.Count
    
13.         strFullName = fd.SelectedItems(i)
    
14.         Sheet1.Cells(i, 1) = strFullName   'appear the selection file name
    
15.         
    
16.         n = rinstr(strFullName, "\")
    
17.       Next
    
18. End Sub
    
19. Function rinstr(ByVal t As String, ByVal s As String)
    
20.     'search the last string position
    
21.     Dim i As Integer
    
22.     Dim n As Integer   
    
23.     n = 0
    
24.     For i = 1 To Len(t)
    
25.         If Mid(t, i, 1) = s Then
    
26.            n = i
    
27.         End If
    
28.     Next
    
29.     rinstr = n
    
30. End Function

複製代碼

目前插入路徑的位置為a1，請問要如何指定插入的儲存格位置呢?謝謝

stillfish00

回復 2# Mindyj
14行改這樣就隨你指定了
if i=0 then
  Sheet1.Range("A1")= strFullName
else
  Sheet1.Range("A1").Offset(i - 1) = strFullName
end if


rinstr 其實有現成函數 InStrRev 可利用

stillfish00

筆誤...if i=1 then 才對

Mindyj

回復 4# stillfish00
謝謝stillfish，測試結果不論i=0 or=1皆可使用，可否請stillfish指教如何使用 InStrRev 呢?  謝謝

stillfish00

回復 5# Mindyj
用法和你原本的差不多，像2樓 16行 寫成 n = InStrRev(strFullName, "\") 一樣是找最後一個 "\"出現的位置。

其他選擇性引數就自己查看說明嚕。

InStrRev函數
描述
傳回一個字串在另一個字串中出現的位置，從字串的末尾算起。

語法
InstrRev(stringcheck, stringmatch[, start[, compare]])

InstrRev 函數語法有如下幾個指名引數：
stringcheck 必要引數。要執行搜尋的字串運算式。
stringmatch 必要引數。要搜尋的字串運算式。
Start 選擇性引數的。數值運算式，設定每次搜尋的開始位置。如果忽略，則使用 -1，它表示從上一個字元位置開始搜尋。如果 start 包含 Null，則產生一個錯誤。
Compare 選項的。數字值，指出在判斷子字串時所使用的比較方法。如果忽略，則執行二進位比較。關於其值，請參閱「設定值」。

Mindyj

回復 6# stillfish00
收到、謝謝您!

Mindyj

目前程式代碼如下，一直debug在If CBool(Sheets("Sheet2").Cells(cell, i)) Then這一行，請各位先進指教。

1. Sub SEND()
   
2.     Dim OutApp As Object
   
3.     Dim OutMail As Object
   
4.     Dim FileName As String
   
5.     Dim EmailTo As String
   
6.     Dim EmailCC As String
   
7.     Dim EmailBCC As String
   
8.     Dim EmailSubject As String
   
9.     Dim EmailBody As String
   
10.     Dim cell As Integer
    
11. 
    
12.    
    
13. 
    
14.     SendType = CStr(Sheets("Sheet2").Cells(2, 2))
    
15.      If SendType = "1" Then
    
16.         cell = 8
    
17.      ElseIf SendType = "2" Then
    
18.         cell = 9
    
19.      ElseIf SendType = "3" Then
    
20.         cell = 10
    
21.      ElseIf SendType = "4" Then
    
22.         cell = 11
    
23.      Else
    
24.         cell = 0
    
25.      End If
    
26. 
    
27.      If cell > 0 Then
    
28.         For i = 4 To 6 Step 1
    
29.           'debug一直停在下面這一行
    
30.             If CBool(Sheets("Sheet2").Cells(cell, i)) Then
    
31.                   EmailTo = CStr(Sheets("Sheet2").Cells(7, i))
    
32.             End If
    
33.             EmailCC = CStr(Sheets("Sheet2").Cells(8, i))
    
34.             EmailBCC = CStr(Sheets("Sheet2").Cells(9, i))
    
35.             EmailSubject = CStr(Sheet2.Range("B" & i))
    
36.             EmailBody = CStr(Sheet1.Range("A" & i)) & vbNewLine
    
37. 
    
38.             If EmailCC <> "" Then
    
39.                 Set rng = Sheets("Sheet1").Range("A11:G30").SpecialCells(xlCellTypeVisible)
    
40.                 On Error Resume Next
    
41.                 ' Only send the visible cells in the selection.
    
42.                 Set rng = Selection.SpecialCells(xlCellTypeVisible)
    
43.                 On Error GoTo 0
    
44.                 If rng Is Nothing Then
    
45. 
    
46.                     MsgBox "The selection is not a range or the sheet is protected. " & _
    
47.                            vbNewLine & "Please correct and try again.", vbOKOnly
    
48.                     Exit Sub
    
49.                 End If
    
50.                 With Application
    
51.                     .EnableEvents = False
    
52.                     .ScreenUpdating = False
    
53.                 End With
    
54. 
    
55.                 Set OutApp = CreateObject("Outlook.Application")
    
56.                 Set OutMail = OutApp.CreateItem(0)
    
57.            
    
58.                 On Error Resume Next
    
59.                 On Error GoTo 0
    
60. 
    
61.                 With OutMail
    
62. 
    
63.                      .to = EmailTo
    
64.                      .CC = EmailCC
    
65.                      .BCC = EmailBCC
    
66.                      .Subject = EmailSubject
    
67.                      .body = EmailBody
    
68. 
    
69.                 '     .attachments.add=strattached
    
70.                      .display
    
71.                  End With
    
72.                 With Application
    
73.                     .EnableEvents = True
    
74.                     .ScreenUpdating = True
    
75.                 End With
    
76.                 Set OutMail = Nothing
    
77.                 Set OutApp = Nothing
    
78.             End If
    
79.         Next
    
80.      End If
    
81. End Sub

複製代碼

Mindyj

更正、目前問題是出在收件者mail一直無法顯示在收件者欄(所有收件者在同一封信內)

stillfish00

回復 9# Mindyj
Cells(列號，欄號)
你是不是弄反了?