Страницы: 1
RSS
Сохранение файла с выбором директории
 
Подскажите пожалуйста по коду,
макрос выделяет лист в отдельную книгу, сохраняет её и отправляет через Outlook,  
но сохранение работает некорректно, а именно:  дает выбрать папку куда сохранить файл с листом, но после выбора всё равно сохранение файла происходит в папку где находится начальная книга
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"
    ActiveSheet.Copy
    With ActiveWorkbook
 .sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
что то не так со строками  25,  26  
Изменено: vikttur - 21.09.2021 20:22:24
 
И Вам здравствуйте
в 25 строке Вы вызываете стандартное диалоговое окно Сохранить как, получаете в нем путь по которому нужно сохранять файл, но в 26 строке сохраняете по пути sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx", т.е. в папку активной книги.
 
bigorq,
Благодарю за ответ.  
Я поправил код,  теперь работает как надо
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

в строке 22 было прописано сохранять в текущую папку.  добавил туда диалоговое окно сохранять как и тогда заработало.  строку 25 удалил.  
Изменено: Валерий - 21.09.2021 21:46:15
 
только если не сложно  подскажите в чем была разница.  я к сожалению пока не понимаю что дает команда sAttachment  в первом и втором случае
Код
sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"    
ActiveSheet.Copy
    With ActiveWorkbook
 .sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
        .SaveAs sAttachment, xlOpenXMLWorkbook

и
Код
sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")    
ActiveSheet.Copy
    With ActiveWorkbook
        .SaveAs sAttachment, xlOpenXMLWorkbook
Изменено: Валерий - 21.09.2021 21:52:25
 
Валерий, это не команда, это переменная, в которую прописываем  путь для сохранения файла. В первом случае вычисляя его из пути активной книги, во втором с помощью окна сохранить как.
 
bigorq,  спасибо,  это понял.       а строка .SaveAs sAttachment  что выполняет?
Изменено: Валерий - 21.09.2021 22:06:46
 
Вы хотите, что бы я построчно весь макрос расписал :) Я не работаю с vba. SaveAs - это Сохранить как ,  она сохраняет документ по пути из sAttachment
 
bigorq,   нет конечно)    просто логику пытаюсь понять, в начале в переменную записано "как сохранять",  а потом написано "сохраняй так как написано в переменной".  

почему просто нельзя выполнить сразу, "сохраняй так как написал".  
Изменено: Валерий - 21.09.2021 22:29:07
 
Валерий, можно и сразу после SaveAs путь прописать куда будем сохранять.Наберите  в поисковике  vba saveas и читайте доки по методу и как им пользоваться
 
Код
Sub EXP() 'Макрос сохранения листа и отправки

    Dim objOutlookApp As Object, objMail As Object
    Dim wb As Workbook
    Dim sAttachment As String
  
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
 
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
     
    Application.DisplayAlerts = False
    Set wb = ActiveWorkbook
    sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
    ActiveSheet.Copy
    With ActiveWorkbook
        .sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment)
        .SaveAs sAttachment, xlOpenXMLWorkbook
        .Close False
    End With
    Application.DisplayAlerts = True
    'создаем сообщение
    With objMail
        .To = Range("A3").Value 'адрес получателя
        .Subject = ActiveSheet.Name 'тема сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
            End If
        End If
        .Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Добрый день!
Подскажите пожалуйста,  после перехода на Excel 2019 / Windows 10,   макрос перестал  в диалоговое окно сохранения файла автоматически подставлять имя файла, исходя из названия листа.   в чем может быть дело?
И пробовал прописть так:
Код
 sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
  но всё равно не работает.
Изменено: Валерий - 08.10.2021 18:54:26
 
Вопрос не по теме. Создайте отдельную тему. И код можно сократить, показать только то, что относится к вопросу
Страницы: 1
Наверх