Сообщений в теме: 914

[sinsemilia]

Приветствую всех, уважаемые друзья!

Помогите, пожалуйста, доработать макрос. Он идеально работает, но не создает вложение. 

Макрос отправки почты. Я работаю в файле, там могут быть 3-10 листов. Затем мне надо этот файл отправить. Я нашла этот макрос, он подходит,

создает письмо, включает туда адресатов, тему, но не создает вложение - этот же открытий файл, в котором я работаю. Подскажите, пожалуйста, как сделать так, чтобы он еще и вкладывал текущий файл в тело письма? 

Sub LetterMail()

TM = ThisWorkbook.Worksheets(4).Range("A1")

Создаем письмо в  OUTLOOK

Dim objOl As Object

Dim objMail As Object

On Error GoTo 2

Set objOl = CreateObject("Outlook.Application")

2:

If objOl Is Nothing Then MsgBox "не удалось запустить", vbCritical: Exit Sub

Set objMail = objOl.createitem(0)

With objMail

 .To = TM 'получатели письма

 .Body = "Текст письма" 'Напишите текст письма

 .Subject = ThisWorkbook.Worksheets(4).Range("A2") 'Тема

 .Display

End With

Set objOl = Nothing

Set objMail = Nothing

Сообщение отредактировал sinsemilia: 18.11.2020, 15:44:02

[T-800 Danya]

Помогите, пожалуйста, доработать макрос.

 
ИМХО думаю что как-то вот так вот...  
 
Для ActiveWorkbook
 

Скрытый текст

 

Sub EmailWorkbook()
'PURPOSE: Create email message with ActiveWorkbook attached
'SOURCE: www.TheSpreadsheetGuru.com

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

Set SourceWB = ActiveWorkbook

'Check for macro code residing in
  If Val(Application.Version) >= 12 Then
    If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
      UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
        "If you proceed the VBA code will not be included in your email attachment. " & _
        "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
    
    If UserAnswer = vbNo Then Exit Sub 'Handle if user cancels
  
    End If
  End If

'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

'Ask user for a file name
  TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
    "File Name", Type:=2, Default:=DefaultName)
    
    If TempFileName = False Then Exit Sub 'Handle if user cancels
  
'Determine File Extension
  If SourceWB.Saved = True Then
    FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  Else
    FileExtStr = ".xlsx"
  End If

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Save Temporary Workbook
  SourceWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr
  Set DestinWB = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

'Break External Links
  ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

    'Loop Through each External Link in ActiveWorkbook and Break it
      On Error Resume Next
        For x = 1 To UBound(ExternalLinks)
          DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
        Next x
      On Error GoTo 0
      
'Save Changes
  DestinWB.Save

'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
    
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = "Please see attached." & vbNewLine & vbNewLine & "Chris"
     .Attachments.Add DestinWB.FullName
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
  
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub

Для  выбранных Worksheets

Скрытый текст

 

Sub EmailSelectedSheets()
'PURPOSE: Create email message with only Selected Worksheets attached
'SOURCE: www.TheSpreadsheetGuru.com

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.DisplayAlerts = False

'Copy only selected sheets into new workbook
  Set SourceWB = ActiveWorkbook
  SourceWB.Windows(1).SelectedSheets.Copy
  Set DestinWB = ActiveWorkbook

'Check for macro code residing in
  If Val(Application.Version) >= 12 Then
    If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
      UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
        "If you proceed the VBA code will not be included in your email attachment. " & _
        "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
    
    'Handle if user cancels
      If UserAnswer = vbNo Then
        DestinWB.Close SaveChanges:=False
        GoTo ExitSub
      End If
      
    End If
  End If

'Determine Temporary File Path
  TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
  If SourceWB.Saved Then
    DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
  Else
    DefaultName = SourceWB.Name
  End If

'Ask user for a file name
  TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
    "File Name", Type:=2, Default:=DefaultName)
    
    If TempFileName = False Then GoTo ExitSub 'Handle if user cancels
  
'Determine File Extension
  If SourceWB.Saved = True Then
    FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
  Else
    FileExtStr = ".xlsx"
  End If

'Break External Links
  ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

    'Loop Through each External Link in ActiveWorkbook and Break it
      On Error Resume Next
        For x = 1 To UBound(ExternalLinks)
          DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
        Next x
      On Error GoTo 0
      
'Save Temporary Workbook
  DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Create Instance of Outlook
  On Error Resume Next
    Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
  Err.Clear
    If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
    
    If Err.Number = 429 Then
      MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
      GoTo ExitSub
    End If
  On Error GoTo 0

'Create a new email message
  Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
  On Error Resume Next
    With OutlookMessage
     .To = ""
     .CC = ""
     .BCC = ""
     .Subject = TempFileName
     .Body = "Please see attached." & vbNewLine & vbNewLine & "Chris"
     .Attachments.Add TempFilePath & TempFileName & FileExtStr
     .Display
    End With
  On Error GoTo 0

'Close & Delete the temporary file
  DestinWB.Close SaveChanges:=False
  Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
  Set OutlookMessage = Nothing
  Set OutlookApp = Nothing
  
'Optimize Code
ExitSub:
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True

End Sub

Сообщение отредактировал T-800 Danya: 18.11.2020, 16:19:51

[sinsemilia]

Для ActiveWorkbook

 

Ой))) такой большой ))) 

Что-то он не работает, ругается на книги 

[T-800 Danya]

 

Для ActiveWorkbook

 
Что-то он не работает, ругается на книги

 

Ну так надо наверное позвать Телепатов в тред...    - Как ругается то?

ЗЫ А про большой - ну так как иначе то... 

 

Вы хотите из файла макросом отправить сам файл... Соотвественно,  ему надо спера сделать свою копию...

 

Создать временный файл... Затем создать письмо приаттачить к нему этот временный файл  и отправить...

Сообщение отредактировал T-800 Danya: 18.11.2020, 17:54:11

[trnj]

 

Sub LetterMail()

TM = ThisWorkbook.Worksheets(4).Range("A1")

Создаем письмо в  OUTLOOK

Dim objOl As Object

Dim objMail As Object

On Error GoTo 2

Set objOl = CreateObject("Outlook.Application")

2:

If objOl Is Nothing Then MsgBox "не удалось запустить", vbCritical: Exit Sub

Set objMail = objOl.createitem(0)

With objMail

 .To = TM 'получатели письма

 .Body = "Текст письма" 'Напишите текст письма

 .Subject = ThisWorkbook.Worksheets(4).Range("A2") 'Тема

 .Display

End With

Set objOl = Nothing

Set objMail = Nothing

 

А если сюда просто добавить 

 

.Attachments.Add "Путь к файлу"

 

 .To = TM 'получатели письма

 .Body = "Текст письма" 'Напишите текст письма

 .Subject = ThisWorkbook.Worksheets(4).Range("A2") 'Тема

 .Attachments.Add "C:\1\ВашФайл.xlsx"

 

можно ещё так попробовать 

 

.To = TM 'получатели письма

.Body = "Текст письма" 'Напишите текст письма

.Subject = ThisWorkbook.Worksheets(4).Range("A2") 'Тема

.Attachments.Add (ActiveDocument.FullName)

 

Тогда приложит текущий документ динамически (не надо прописывать путь)

Сообщение отредактировал trnj: 18.11.2020, 18:17:32

[sinsemilia]

Вы хотите из файла макросом отправить сам файл... Соотвественно,  ему надо спера сделать свою копию...   Создать временный файл... Затем создать письмо приаттачить к нему этот временный файл  и отправить...

Спасибо вам большое за помощь!      

 

А если сюда просто добавить 

Да! То, что надо! Воспользовалась вашим вариантом 2, только он сначала ругался и тут до меня дошло почему. Я заменила (ActiveDocument.FullName) на (ActiveWorkbook.FullName) и все заработало! Спасибо вам огромное! 

Сообщение отредактировал sinsemilia: 19.11.2020, 08:45:48

[trnj]

 Да! То, что надо! Воспользовалась вашим вариантом 2, только он сначала ругался и тут до меня дошло почему. Я заменила (ActiveDocument.FullName) на (ActiveWorkbook.FullName) и все заработало! Спасибо вам огромное! 

 

 

Упс, сорри за очепятку, сто лет уже не работал с макросами.

 

Тогда ещё есть смысл добавить после end with

ActiveWorkbook.Save 

Чтобы сохранить текущий файл

 

Или как Козырь вам советовал выше, сохранить во временный файл, и его прикладывать, потом удалить (по желанию)

 

ActiveWorkbook.SaveAs "C:\ВременныйФайл.xls", FileFormat:=52

[sinsemilia]

 

Упс, сорри за очепятку, сто лет уже не работал с макросами.

 

Тогда ещё есть смысл добавить после end with

ActiveWorkbook.Save 

Чтобы сохранить текущий файл

 

Или как Козырь вам советовал выше, сохранить во временный файл, и его прикладывать, потом удалить (по желанию)

 

ActiveWorkbook.SaveAs "C:\ВременныйФайл.xls", FileFormat:=52

Да, отлично! Добавила автосохранение, теперь даже кнопку не надо нажимать)))

Там путь к файлу прописывать не вариант, потому что папки каждый раз новые, дублируются, а файлом много + надо смотреть прежде чем отправляешь) 

Спасибо вам большое за помощь! Супер      

[punter]

Всем, добрый день! Кто может подсказать как при сцеплении двух ссылок (числа и текста) группа разрядов числа отображались раздельно? (как в ячейке А1)

 

 

Спасибо авансом!

[Elimoe]

Всем, добрый день! Кто может подсказать как при сцеплении двух ссылок (числа и текста) группа разрядов числа отображались раздельно? (как в ячейке А1)

 

 

Спасибо авансом!

В данном примере можно как форматом ячейки это решить без сцепки - просто в Custom вставить, что-то вроде этого  #,##0.00 [$KZT];-$#,##0.00 [$KZT]

 

Либо при сцепке использовать функцию TEXT(ссылка на ячейку с числом, формат для этой ячейки) и уже её сцеплять со второй частью. Только при использовании пробела в качестве разделителя возможно придётся ещё поверх этого использовать TRIM - для случаем когда число меньше 1000, иначе Эксель вам может туда ведущий пробел вставить (т.е. не "109.96", а " 109.96")

Сообщение отредактировал Elimoe: 30.11.2020, 06:31:06

[maclien800]

Я вообще не шарю в ексель

[makemake96]

Подскажите пж-та как в excel формулами убрать последние три слова?

 

Например:

Есть: "Генеральный директор Иванов Иван Иванович", нужно: "Генеральный директор"

 

 

а также превратить "Генеральный директор Иванов Иван Иванович" в "Генеральному директору Иванов И. И."

Сообщение отредактировал makemake96: 20.03.2022, 18:32:43

[punter]

Добрый день, подскажите пж-та как в столбце F прописать формулу, которая будет по суммам в столбцах B и Е находить поставщиков в столбце А, а также суммировать значения в столбце B, чтобы потом сопоставив сумму в столбе Е дать результат

 

Сообщение отредактировал punter: 25.03.2022, 18:39:35

[sinsemilia]

Добрый день, подскажите пж-та как в столбце F прописать формулу, которая будет по суммам в столбцах B и Е находить поставщиков в столбце А, а также суммировать значения в столбце B, чтобы потом сопоставив сумму в столбе Е дать результат

 

Можно написать формулу СУММЕСЛИМН, в которой можно указать все диапазоны и все условия. Только я не поняла, в каждой ячейке свое условие должно быть или как?  

[sinsemilia]

Подскажите пж-та как в excel формулами убрать последние три слова?

 

Например:

Есть: "Генеральный директор Иванов Иван Иванович", нужно: "Генеральный директор"

 

 

а также превратить "Генеральный директор Иванов Иван Иванович" в "Генеральному директору Иванов И. И."

Подумаю над формулой, в ближайшее время отвечу.