Отправка письма происходит так: я выделяю 2 ячейки: одна с номером, другая с адресом. в тему письма вставляется соответствующая инфа. как избежать в коде [vba]
Код
InputBox("№ заявки")
[/vba]?? Чтобы прога сама подставляла номер?
спасибо.
код прикрепил ниже. не влезает в сообщение.
Код с отправкой прикрепленных файлов не работает. У меня папки выглядят так:
Отправка письма происходит так: я выделяю 2 ячейки: одна с номером, другая с адресом. в тему письма вставляется соответствующая инфа. как избежать в коде [vba]
Sub Pismo() If ActiveSheet.Name = "СиК" Then adresat = "Сети и Коммуникации" ElseIf ActiveSheet.Name = "ВИТА" Then adresat = "ВИТА-сервис" Else adresat = ActiveSheet.Name End If
For Each scel In Selection If tema <> "" Then tema = tema & " " & scel Else tema = scel Next Call SendMail(adresat, tema, att) End Sub
Sub SendMail(adresat, tema, att) On Error Resume Next Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim un As String un = Application.UserName 'создаем новое пустое сообщение в Outlook Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon On Error GoTo cleanup Set OutMail = OutApp.CreateItem(0)
'заполняем его адрес, тему и т.д. With OutMail
.To = adresat .Subject = tema ' .Body = telo For i = 1 To att.Count .Attachments.Add att(i) Next i 'вместо Send можно использовать Display, чтобы посмотреть сообщение перед отправкой .Display End With
On Error GoTo 0 Set OutMail = Nothing
cleanup: Set OutApp = Nothing Application.ScreenUpdating = True End Sub
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути найденных файлов ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
Set FilenamesCollection = New Collection ' создаём пустую коллекцию Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO ' перебор папок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных файлов в коллекцию FileNamesColl On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath) If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' раскомментируйте эту строку для вывода пути к просматриваемой ' в текущий момент папке в строку состояния Excel ' Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path Next SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках If SearchDeep Then ' если надо искать глубже For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing ' очищаем переменные End If End Function
[/vba]
[vba]
Код
Sub Pismo() If ActiveSheet.Name = "СиК" Then adresat = "Сети и Коммуникации" ElseIf ActiveSheet.Name = "ВИТА" Then adresat = "ВИТА-сервис" Else adresat = ActiveSheet.Name End If
For Each scel In Selection If tema <> "" Then tema = tema & " " & scel Else tema = scel Next Call SendMail(adresat, tema, att) End Sub
Sub SendMail(adresat, tema, att) On Error Resume Next Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim un As String un = Application.UserName 'создаем новое пустое сообщение в Outlook Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon On Error GoTo cleanup Set OutMail = OutApp.CreateItem(0)
'заполняем его адрес, тему и т.д. With OutMail
.To = adresat .Subject = tema ' .Body = telo For i = 1 To att.Count .Attachments.Add att(i) Next i 'вместо Send можно использовать Display, чтобы посмотреть сообщение перед отправкой .Display End With
On Error GoTo 0 Set OutMail = Nothing
cleanup: Set OutApp = Nothing Application.ScreenUpdating = True End Sub
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути найденных файлов ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
Set FilenamesCollection = New Collection ' создаём пустую коллекцию Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO ' перебор папок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных файлов в коллекцию FileNamesColl On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath) If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' раскомментируйте эту строку для вывода пути к просматриваемой ' в текущий момент папке в строку состояния Excel ' Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path Next SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках If SearchDeep Then ' если надо искать глубже For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing ' очищаем переменные End If End Function