標題:
excel郵件寄發多問題
[打印本頁]
作者:
Mindyj
時間:
2013-5-23 10:51
標題:
excel郵件寄發多問題
請問各位先進郵件發送的問題，此檔案是根據使用者的選擇進行郵件發送，目前的問題如下：
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之後的內文。
以上問題，資質不足，研究了一個月還是解決不了，麻煩大家幫忙。謝謝
[attach]15058[/attach]
作者:
Mindyj
時間:
2013-5-27 11:04
目前研究出選取夾帶檔案路徑為：
Sub Import1()
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFilePicker)
fd.Filters.Add "Excel File", "*.xls*" 'set the catch function
fd.Filters.Add "Word File", "*.doc*"
fd.Filters.Add "Txt File", "*.txt*"
fd.Filters.Add "all files", "*.*"
fd.Show 'show the dialog window
For i = 1 To fd.SelectedItems.Count
strFullName = fd.SelectedItems(i)
Sheet1.Cells(i, 1) = strFullName 'appear the selection file name
n = rinstr(strFullName, "\")
Next
End Sub
Function rinstr(ByVal t As String, ByVal s As String)
'search the last string position
Dim i As Integer
Dim n As Integer
n = 0
For i = 1 To Len(t)
If Mid(t, i, 1) = s Then
n = i
End If
Next
rinstr = n
End Function
複製代碼
目前插入路徑的位置為a1，請問要如何指定插入的儲存格位置呢?謝謝
作者:
stillfish00
時間:
2013-5-27 11:20
本帖最後由 stillfish00 於 2013-5-27 11:23 編輯
回復
2#
Mindyj
14行改這樣就隨你指定了
if i=0 then
Sheet1.Range("A1")= strFullName
else
Sheet1.Range("A1").Offset(i - 1) = strFullName
end if
rinstr 其實有現成函數 InStrRev 可利用
作者:
stillfish00
時間:
2013-5-27 11:27
筆誤...if i=1 then 才對
作者:
Mindyj
時間:
2013-5-27 11:46
回復
4#
stillfish00
謝謝stillfish，測試結果不論i=0 or=1皆可使用，可否請stillfish指教如何使用 InStrRev 呢? 謝謝
作者:
stillfish00
時間:
2013-5-27 12:24
回復
5#
Mindyj
用法和你原本的差不多，像2樓 16行 寫成 n = InStrRev(strFullName, "\") 一樣是找最後一個 "\"出現的位置。
其他選擇性引數就自己查看說明嚕。
InStrRev函數
描述
傳回一個字串在另一個字串中出現的位置，從字串的末尾算起。
語法
InstrRev(stringcheck, stringmatch[, start[, compare]])
InstrRev 函數語法有如下幾個指名引數：
stringcheck 必要引數。要執行搜尋的字串運算式。
stringmatch 必要引數。要搜尋的字串運算式。
Start 選擇性引數的。數值運算式，設定每次搜尋的開始位置。如果忽略，則使用 -1，它表示從上一個字元位置開始搜尋。如果 start 包含 Null，則產生一個錯誤。
Compare 選項的。數字值，指出在判斷子字串時所使用的比較方法。如果忽略，則執行二進位比較。關於其值，請參閱「設定值」。
作者:
Mindyj
時間:
2013-5-27 12:34
回復
6#
stillfish00
收到、謝謝您!
作者:
Mindyj
時間:
2013-5-29 07:32
目前程式代碼如下，一直debug在If CBool(Sheets("Sheet2").Cells(cell, i)) Then這一行，請各位先進指教。
Sub SEND()
Dim OutApp As Object
Dim OutMail As Object
Dim FileName As String
Dim EmailTo As String
Dim EmailCC As String
Dim EmailBCC As String
Dim EmailSubject As String
Dim EmailBody As String
Dim cell As Integer
SendType = CStr(Sheets("Sheet2").Cells(2, 2))
If SendType = "1" Then
cell = 8
ElseIf SendType = "2" Then
cell = 9
ElseIf SendType = "3" Then
cell = 10
ElseIf SendType = "4" Then
cell = 11
Else
cell = 0
End If
If cell > 0 Then
For i = 4 To 6 Step 1
'debug一直停在下面這一行
If CBool(Sheets("Sheet2").Cells(cell, i)) Then
EmailTo = CStr(Sheets("Sheet2").Cells(7, i))
End If
EmailCC = CStr(Sheets("Sheet2").Cells(8, i))
EmailBCC = CStr(Sheets("Sheet2").Cells(9, i))
EmailSubject = CStr(Sheet2.Range("B" & i))
EmailBody = CStr(Sheet1.Range("A" & i)) & vbNewLine
If EmailCC <> "" Then
Set rng = Sheets("Sheet1").Range("A11:G30").SpecialCells(xlCellTypeVisible)
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
On Error GoTo 0
With OutMail
.to = EmailTo
.CC = EmailCC
.BCC = EmailBCC
.Subject = EmailSubject
.body = EmailBody
' .attachments.add=strattached
.display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next
End If
End Sub
複製代碼
作者:
Mindyj
時間:
2013-5-29 07:41
更正、目前問題是出在收件者mail一直無法顯示在收件者欄(所有收件者在同一封信內)
作者:
stillfish00
時間:
2013-5-29 12:53
回復
9#
Mindyj
Cells(列號，欄號)
你是不是弄反了?
作者:
Mindyj
時間:
2013-5-31 08:50
謝謝stillfish、是用反了，可是現在有另一個問題；資料有兩個人同時要接收時，程式判讀只會將最後一位列在收件者上面，請問這是哪個部份有誤?
另外請問夾帶檔案位置的部份一直測試不出來是語法錯誤嗎?謝謝
Sub SEND()
Dim OutApp As Object
Dim OutMail As Object
Dim FileName As String
Dim EmailTo As String
Dim EmailCC As String
Dim EmailBCC As String
Dim EmailSubject As String
Dim EmailBody As String
Dim cell As Integer
SendType = CStr(Sheets("Sheet2").Cells(2, 2))
If SendType = "1" Then
cell = 8
ElseIf SendType = "2" Then
cell = 9
ElseIf SendType = "3" Then
cell = 10
ElseIf SendType = "4" Then
cell = 11
Else
cell = 0
End If
If cell > 0 Then
For i = 4 To 6 Step 1
If CBool(Sheets("Sheet2").Cells(i, cell)) = "TRUE" Then
EmailTo = CStr(Sheets("Sheet2").Range("G" & i)) & ";"
End If
Next
EmailCC = CStr(Sheets("Sheet2").Range("G" & 7))
EmailBCC = CStr(Sheets("Sheet2").Range("G" & 8))
EmailSubject = CStr(Sheet2.Cells(2, 3))
EmailBody = CStr(Sheet1.Range("A" & 11)) & vbNewLine
'If [Sheet1].Cells(8, 1) <> "" Then .AddAttachment ([Sheet1].Cells(8, 1))
If EmailCC <> "" Then
Set rng = Sheets("Sheet1").Range("A11:G30").SpecialCells(xlCellTypeVisible)
On Error Resume Next
' Only send the visible cells in the selection.
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
On Error GoTo 0
With OutMail
.To = EmailTo
.CC = EmailCC
.BCC = EmailBCC
.Subject = EmailSubject
.body = EmailBody
' .attachments.Add
.display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
End Sub
複製代碼
作者:
stillfish00
時間:
2013-5-31 12:32
回復
11#
Mindyj
line#28
EmailTo =
EmailTo &
CStr(Sheets("Sheet2").Range("G" & i)) & ";"
line#67
.attachments.Add
"C:\aa.txt"
紅色為附檔的路徑
是這樣嗎?
作者:
Mindyj
時間:
2013-5-31 12:44
回復
12#
stillfish00
Hi stillfish,
夾帶檔案指定為shee1的a8儲存格，我使用了
.AddAttachment Sheet1.Cells(8, 1)
debug會停留在.addattachment
作者:
kimbal
時間:
2013-5-31 13:36
回復
13#
Mindyj
試試?
.attachments.add Sheet1.Cells(8, 1)
不行的話會不會是A8上的附件位置有錯?
作者:
Mindyj
時間:
2013-5-31 13:55
回復
14#
kimbal
還是不是、很納悶，因為這一行不執行的話整個程式是沒問題的，應該是不需要另外寫function?
作者:
Mindyj
時間:
2013-5-31 14:12
本帖最後由 Mindyj 於 2013-5-31 14:15 編輯
剛剛測試了如果將夾帶檔案直接輸入檔案位置是可行的，
可是使用者會依每次需求不同選擇不同的檔案、所以才將檔案位置指定輸入至Sheet1的A8儲存格，
但是當我將夾帶檔案改為指定至儲存格就一直出現錯誤，
而錯誤一直停留在.attachments.add Sheet1.Cells(8, 1)
作者:
stillfish00
時間:
2013-5-31 14:58
回復
16#
Mindyj
.attachments.add Sheet1.Cells(8, 1).value
作者:
Mindyj
時間:
2013-5-31 15:05
本帖最後由 Mindyj 於 2013-5-31 15:06 編輯
回復
17#
stillfish00
執行結果：object doesn't support this property or method
一個頭n個大、請問還有別的方式嗎?
作者:
stillfish00
時間:
2013-5-31 15:07
回復
18#
Mindyj
能附上執行會出錯的檔案看看嗎
作者:
Mindyj
時間:
2013-5-31 15:09
回復
17#
stillfish00
更正!!!!成功了!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
謝謝stillfish!!!!!!:handshake
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
