12
返回列表 上一主題 發帖

excel郵件寄發多問題

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
11# 跳轉到 »
發表於 2013-5-31 08:50 | 只看該作者
謝謝stillfish、是用反了，可是現在有另一個問題；資料有兩個人同時要接收時，程式判讀只會將最後一位列在收件者上面，請問這是哪個部份有誤?
另外請問夾帶檔案位置的部份一直測試不出來是語法錯誤嗎?謝謝
  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.     SendType = CStr(Sheets("Sheet2").Cells(2, 2))
  13.      If SendType = "1" Then
  14.         cell = 8
  15.      ElseIf SendType = "2" Then
  16.         cell = 9
  17.      ElseIf SendType = "3" Then
  18.         cell = 10
  19.      ElseIf SendType = "4" Then
  20.         cell = 11
  21.      Else
  22.         cell = 0
  23.      End If

  25.      If cell > 0 Then
  26.         For i = 4 To 6 Step 1
  27.             If CBool(Sheets("Sheet2").Cells(i, cell)) = "TRUE" Then
  28.                 EmailTo = CStr(Sheets("Sheet2").Range("G" & i)) & ";"
  29.             End If
  30.         Next
  31.             EmailCC = CStr(Sheets("Sheet2").Range("G" & 7))
  32.             EmailBCC = CStr(Sheets("Sheet2").Range("G" & 8))
  33.             EmailSubject = CStr(Sheet2.Cells(2, 3))
  34.             EmailBody = CStr(Sheet1.Range("A" & 11)) & vbNewLine
  35.             
  36.             'If [Sheet1].Cells(8, 1) <> "" Then .AddAttachment ([Sheet1].Cells(8, 1))

  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

  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

  55.                 Set OutApp = CreateObject("Outlook.Application")
  56.                 Set OutMail = OutApp.CreateItem(0)
  57.            
  58.                 On Error Resume Next
  59.                 On Error GoTo 0

  61.                 With OutMail
  62.                      .To = EmailTo
  63.                      .CC = EmailCC
  64.                      .BCC = EmailBCC
  65.                      .Subject = EmailSubject
  66.                      .body = EmailBody
  67. '                     .attachments.Add
  68.                      .display
  69.                  End With
  70.                 With Application
  71.                     .EnableEvents = True
  72.                     .ScreenUpdating = True
  73.                 End With
  74.                 Set OutMail = Nothing
  75.                 Set OutApp = Nothing
  76.             End If
  77.      End If
  78. End Sub
複製代碼

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
10#
發表於 2013-5-29 12:53 | 只看該作者
回復 9# Mindyj
Cells(列號，欄號)
你是不是弄反了?

TOP

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
9#
發表於 2013-5-29 07:41 | 只看該作者
更正、目前問題是出在收件者mail一直無法顯示在收件者欄(所有收件者在同一封信內)

TOP

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
8#
發表於 2013-5-29 07:32 | 只看該作者
目前程式代碼如下，一直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

  12.    

  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

  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

  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

  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

  55.                 Set OutApp = CreateObject("Outlook.Application")
  56.                 Set OutMail = OutApp.CreateItem(0)
  57.            
  58.                 On Error Resume Next
  59.                 On Error GoTo 0

  61.                 With OutMail

  63.                      .to = EmailTo
  64.                      .CC = EmailCC
  65.                      .BCC = EmailBCC
  66.                      .Subject = EmailSubject
  67.                      .body = EmailBody

  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
複製代碼

TOP

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
7#
發表於 2013-5-27 12:34 | 只看該作者
回復 6# stillfish00
收到、謝謝您!

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
6#
發表於 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 選項的。數字值，指出在判斷子字串時所使用的比較方法。如果忽略，則執行二進位比較。關於其值，請參閱「設定值」。

TOP

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
5#
發表於 2013-5-27 11:46 | 只看該作者
回復 4# stillfish00
謝謝stillfish，測試結果不論i=0 or=1皆可使用，可否請stillfish指教如何使用 InStrRev 呢?  謝謝

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
4#
發表於 2013-5-27 11:27 | 只看該作者
筆誤...if i=1 then 才對

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
3#
發表於 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 可利用

TOP

Mindyj
　暱稱: Mindy

中學生Rank: 2

帖子
31 
主題
6 
精華
0 
積分
59 
點名
0  
作業系統
win 7 
軟體版本
office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-4-4 
最後登錄
2013-9-2 
2#
發表於 2013-5-27 11:04 | 只看該作者
目前研究出選取夾帶檔案路徑為：
  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，請問要如何指定插入的儲存格位置呢?謝謝

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
12
返回列表 上一主題