Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Пользователи » splashsnake
Выбрать дату в календаре…Выбрать дату в календаре

Страницы: 1
Ошибка 462 при повторном запуске макроса экспорт файла из Excel в Word, Ошибка 462 при повторном запуске макроса экспорт файла из Excel в Word
 
#
30.08.2024 11:43:54
Нашел закономерность  при первичном запуске word.application имеет тип objet/aplication



при вторичном запуске word.application имеет тип integer

как можно word.application задать тип переменной?
Изменено: splashsnake - 30.08.2024 11:44:15
 
Перейти    
Перенос таблицы из Экселя в ворд с помощью VBA
 
#
29.08.2024 13:50:15
закладку в ворде bookmarks
Код
Set wdrange = objworddoc.bookmarks("Paste_work_people_tb").Range 'назначаем переменную
ActiveWorkbook.Sheets("dynamick_tb_system_substitution").Range("Paste_work_people_tb[#All]").Copy   'подцепляем наш выбранный файл
ActiveWorkbook.Sheets("dynamick_tb_system_substitution").Range("Paste_work_people_tb[#All]").Copy   'подцепляем наш выбранный файл

wdrange.Paste   'вставляем
Set wdrange = Nothing  'очищаем переменную
 
Перейти    
Формирование отчета по исполнению фонда оплаты труда, Подскажите пожалуйста, как сделать сравнительную таблицу (Пивот),
 
#
29.08.2024 13:38:09
1. делаешь выгрузку

выделяешь  уникальные значения дат из выгрузки
Код
Range("pd_1[Персонал]").Select: Selection.Copy
Range("H1").Select: Selection.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Range("H1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo: Selection.Copy
sh2.Select: sh2.Range("A2").Select: Selection.PasteSpecial Paste:=xlPasteValues: sh1.Select
2. на основании этого диапазона создаешь листы где создаёшь листы сразу фильтр по месяцам в основной таблице с копированием необходимых дат на новый лист
Код
 Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws.Name = ActiveWorkbook.Sheets("name").Range("A1")
        Sheets(ws.Name).Select
          Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
          For f = 2700 To 1 Step -1
    If Cells(f, 1) <> ActiveWorkbook.Sheets("name").Range("B1") Then
        'Range(Cells(i, 1), Cells(i, 2)).Select
        Cells(f, 1).EntireRow.Delete
        Cells.Select
        
    End If
Next f
 
Перейти    
Ошибка 462 при повторном запуске макроса экспорт файла из Excel в Word, Ошибка 462 при повторном запуске макроса экспорт файла из Excel в Word
 
#
29.08.2024 11:52:15
Добрый день
В наличие были 2 темы аналогичные на форме изучил ответа не нашел  мб не понял
462 462(2)

изначально был макрос экспорта из эксель  в word  затем запуск макроса в word решил их совместить врубил tools references - ofice  MS word 16  для форматирования текста
перенес данный код в эксель
при первичном запуске все идеально код проходит создает файл меняет форматы все отлично


но при повторном запуске макроса Word.Application. уходит в ошибку. после завершения ошибки код снова проходит. т.е работает через раз
Основная ошибка идет при повторном обращении Word.Application после завершения 462 ошибки  поломки код снова проходит.
Код
With objworddoc
Word.Application.ScreenUpdating = 0

Изображение
Т.е срабатывает через раз.

Если есть какие либо предположения почему повторно не идет подхват приложения. предположение что ошибка где то вначале но из за чего понять не могу.


полный код (без закладок bookmarks)
Код
Sub protokol_sverxnorma_na_obshestvo_bez_decretatest()  ' создание Протокол  сверх норм на общество без декрета
ActiveWorkbook.Sheets("system_substitution").Visible = xlSheetVisible


Dim path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail As String
Dim save_path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail As String
Dim name_protokol_sverxnorma_na_obshestvo_bez_decreta_fail As String
Dim objwrdapp As Word.Application
Dim objworddoc As Word.Document
'activeworkbook.Path &"\" ткущее местоположение


'path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail = ActiveWorkbook.Sheets("экспорт_ворд").Range("protokol_sverxnorma_na_obshestvo_bez_decreta_fail") ' указываем страницу и путь к нашему файлу
path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail = ActiveWorkbook.Path & "\"
save_path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail = ActiveWorkbook.Path & "\" ' указываем путь и путь к сохранению файла
'save_path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail = ActiveWorkbook.Sheets("экспорт_ворд").Range("rik_save_fail") вручную
name_protokol_sverxnorma_na_obshestvo_bez_decreta_fail = "Протокол  сверх норм на общество без декрета" ' название нашего шаблона



Set objwrdapp = CreateObject("Word.Application") ' создание вордовского документа из приложения
On Error Resume Next
Set objwrdapp = GetObject(, "Word.Application")
If Err <> 0 Then
Set objwrdapp = CreateObject("Word.Application")
End If
On Error GoTo 0



objwrdapp.Visible = True 'делали наш объект видимым
objwrdapp.Application.Activate

Set objworddoc = objwrdapp.Documents.Open(path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail & name_protokol_sverxnorma_na_obshestvo_bez_decreta_fail & ".docx") 'прописываем путь к нашему объекту для открытия.


With objworddoc

Word.Application.ScreenUpdating = 0

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\блок подстановки закладок

.bookmarks("Н_О_1").Range.Text = ActiveWorkbook.Sheets("system_substitution").Range("Q510")
'убраны из темы так как очень много их

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\работа с ворд документом
'objworddoc
objworddoc.Select
'Word.Application.ScreenUpdating = 0


Dim Таблица As Word.Table
For Each Таблица In objworddoc.Tables
    With Таблица
    
    .Rows.WrapAroundText = False
    .AutoFitBehavior (wdAutoFitWindow)
    .Rows.HeightRule = wdRowHeightAuto
    With .Range.Font
        .name = "times new roman"
        .Size = 12
    End With
End With
      Word.Selection.WholeStory
    With Word.Selection.ParagraphFormat
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineUnitBefore = 0
        .LineUnitAfter = 0
    End With
Next Таблица
Dim pr As Word.Paragraph
Dim j1                'текст в таблице
Dim s1                'текст параграфа
For Each pr In objworddoc.Paragraphs

pr.Range.Select
j1 = Word.Selection.Information(wdWithInTable)
s1 = pr.Range.Text

'Отделение таблиц, рисунков и пустых строк
If j1 = False And Len(s1) > 3 Then
        '(Обработка выделенного фрагмента)
       ' MsgBox ("Обработка выделенного фрагмента")
   Word.Selection.Font.name = "Times New Roman"
    Word.Selection.Font.Size = 12
    With Word.Selection.ParagraphFormat

        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceAtLeast
        .FirstLineIndent = CentimetersToPoints(1.25)
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
'        .Font.Size = 12
'        .Font.name = "times new roman"
        End With


End If
Next pr
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\удаление двойных абзацев
For pk = 1 To 20
    Word.Selection.WholeStory
    Word.Selection.Find.ClearFormatting
    Word.Selection.Find.Replacement.ClearFormatting
    With Word.Selection.Find
        .Text = "^p^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Word.Selection.Find.Execute Replace:=wdReplaceAll, _
 Forward:=True, Wrap:=wdFindNext
 With Word.Selection.Find
        .Text = "^p ^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Word.Selection.Find.Execute Replace:=wdReplaceAll, _
 Forward:=True, Wrap:=wdFindNext
 With Word.Selection.Find
        .Text = " ^p ^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Word.Selection.Find.Execute Replace:=wdReplaceAll, _
 Forward:=True, Wrap:=wdFindNext
 With Word.Selection.Find
        .Text = "  "
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Word.Selection.Find.Execute Replace:=wdReplaceAll, _
 Forward:=True, Wrap:=wdFindNext
 Next pk
'ActiveDocument.Paragraphs.CharacterUnitFirstLineIndent = 1.25
objworddoc.PageSetup.RightMargin = CentimetersToPoints(1)
objworddoc.PageSetup.LeftMargin = CentimetersToPoints(3)
'ActiveDocument.Paragraphs.FirstLineIndent = CentimetersToPoints(1.25)
Word.Application.ScreenUpdating = 1
objworddoc.SaveAs Filename:=save_path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail & "Протокол  сверх норм на общество без декрета по инвентаризации " & ActiveWorkbook.Sheets("AKT_zacheta").Range("N6") & " " & ActiveWorkbook.Sheets("AKT_zacheta").Range("N1") & ".docx"

End With

objworddoc.Close SaveChanges:=False
objwordapp.Quit
objworddoc.Quit
Word.Application.Quit

Kill path_protokol_sverxnorma_na_obshestvo_bez_decreta_fail & name_protokol_sverxnorma_na_obshestvo_bez_decreta_fail & ".docx"
ActiveWorkbook.Sheets("system_substitution").Visible = xlVeryHidden
ActiveWorkbook.Sheets("dynamick_tb_system_substitution").Visible = xlVeryHidden
Set objwrdapp = Nothing
Set objworddoc = Nothing
End Sub
Изменено: splashsnake - 29.08.2024 12:15:56
 
Перейти    
VBA AutoFilter and on error goto point1; on error goto point2, Ошибка с несколькими операторами On error go to
 
#
14.05.2024 09:29:58
Цитата
Sanja написал:
В общем случае, обработчик ошибок  On Error  не предназначен для условного перехода к выполнению каких-то подпрограмм.Для условного перехода используйте операторы GoTo или GoSubА по последнему Вашему коду, я бы так написалКодDim aRng As Range

Ту стать инструкций по операторам читал некоторых нюансов немного не понял поэтому тут и задал вопрос.
Не мог понять почему почему нельзя повторно on error  каждый раз использовать для перехода.
Код
On Error Resume Next
Set aRng = Range("Таблица4[проц]").SpecialCells(xlCellTypeVisible)
If Not aRng Is Nothing Then

А так вариант понравился. как решение
 
Перейти    
VBA AutoFilter and on error goto point1; on error goto point2, Ошибка с несколькими операторами On error go to
 
#
14.05.2024 09:19:09
Благодарю за помощь
 
Перейти    
VBA AutoFilter and on error goto point1; on error goto point2, Ошибка с несколькими операторами On error go to
 
#
13.05.2024 23:14:02
Нашел решение таким методом но возможно некорректно так писать
Код
dim a
On Error Resume Next
a = Range("Таблица4[проц]").SpecialCells(xlCellTypeVisible).Count
If a = "" Then GoTo point3


т.е задаем переменную.
к переменной считаем значения и тогда переходим по точкам а не через ошибки
 
Перейти    
VBA AutoFilter and on error goto point1; on error goto point2, Ошибка с несколькими операторами On error go to
 
#
13.05.2024 21:37:48
Добрый вечер
Не могу понять почему выдаётся ошибка при повторном пропуске ошибки vba

Суть макроса фильтрует в одной таблице данные несколько раз и переносит только видимые ячейки из таблицы в определённый диапазон но фильтрация может быть не только которые есть значения в таблице а даже которых нет в случае ошибки переходит к точке воспроизведения макроса.
но если уже повторно назначаешь on error go to point....
то он не пропускает ошибку  и не переходит к нужной точке воспроизведения а выдает ошибку срабатывания макроса
<Не найдено ни одной ячейки, удовлетворяющей указанным условиям.>
в файле лист 1 modul5

Код
Sub testcoppaste()
Range("Таблица3[проц]").Select
ActiveSheet.ListObjects("Таблица3").Range.AutoFilter Field:=2, Criteria1:="20"
On Error GoTo point2
    Range("Таблица3[проц]").SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Range("A8").Select
    ActiveSheet.Paste

point2:


Range("Таблица4[проц]").Select
ActiveSheet.ListObjects("Таблица4").Range.AutoFilter Field:=2, Criteria1:="10"
On Error GoTo point3 ' тут должен был перейти на точку 3 но не переходит а выдает ошибку
    Range("Таблица4[проц]").SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Range("b8").Select
    ActiveSheet.Paste
point3:

End Sub
Изменено: splashsnake - 13.05.2024 22:29:28
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
20.05.2021 16:23:25
Спасибо огромное
Цитата
Игорь написал:
Функция =DIR("маска имени файла со звездочкой")
спасибо огромное все работает не знал про данную функцию запомню так как можно много где применить.
только уточнить хотел а для чего $ в vba после mask$ и failname$
Код
' для ребят новичков не забудьте задать если кому понадобиться данная статья 
dim mask as string 
dim filename as string
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 18:07:08
любой файл из данного диапазона от 0000  до 2459 но файл один. поэтому и ищу помощи как оптимизировать код в строке
Код
sAttachment = "C:\1\check1043.txt"
'пример файл в папке "C:\1\check1043.txt" 

' завтра файл в папке "C:\1\check1158.txt" 

прописать так не подхватывает файлы
sAttachment = "C:\1\check****.txt"
sAttachment = "C:\1\check####.txt"
sAttachment = "C:\1\check*.txt"
sAttachment = "C:\1\check#.txt"

'как прописать чтоб подхватывал любой файлс с названием sAttachment = "C:\1\check****.txt" в котором **** могут быть любые 4 символа 
'вот это интересует
если есть любой файл у которого начало идет sAttachment = "C:\1\check*.txt" и + 4 неизвестных символа которые всегда есть
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 17:27:58
один файл но последние 4 символа рандомные
прописано много вложений чтоб он нашел нужный один файл. то есть одна и та-же строка дублируется с разными окончаниями 0001;0002;0003, для того что бы он нашел нужный файл с неизвестными последними 4 символами.  
Изменено: splashsnake - 17.05.2021 17:35:19
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 17:22:58
макрос должен понимать по первоначальному имени файла
Код
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1544.xml"

' т.е  если содержит начало .attachments.Add "\\10.35.24.68\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & ".xml"
' прикрепляет любой файл из папки с началом названия .attachments.Add "\\10.35.24.68\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "****.xml" 
' с последними любыми цифрами
 
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 17:19:48
С сервера подгружаться выгрузки с определенным названием датой и временем. время выгрузки в сетевую папку рандомное т.е. последний 4 символа неизвестный.
.файл с сервера выгружается один с уникальным названием

код примера с прикреплением нескольких файлов. тут с условием если вложение не пусто то поиск следующих вложений. список вложений сократил чтоб не был очень длинный код
Код
.attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1543.xml"

суть полного кода при пк врубается по времени через 5 мин срабатывает макрос который отправляет сообщение с вложением а затем вырубается пк
скидывал первичный код так как одно вложение с неизвестными последними 4 символами
Код
Sub Send_Mail_1()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, 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
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

    sTo = ""    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка tns"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Добрый день! прилагаю выгрузку tns. Excel-VBA ежедневная автоматическая отправка на данное сообщение просьба не отвечать. Обновление: файл check.txt необходим для подхвата нескольких файлов"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\1\check.txt"     'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)

    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии avsemashko@oilmurman.ru
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .attachments.Add sAttachment  'просто вложение
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1544.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1545.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1546.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1543.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1547.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1144.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1145.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1146.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1147.xml"
                .attachments.Add "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Лист1").Range("A1") & "1153.xml"

                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
это решение если несколько файлов но имя так же полностью прописанно
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 16:53:34
файл прикрепил
строка в модуле  sAttachment = "C:\GOODSANDGROUPS_Import_AddOrUpdate_20210517####" & ".xml"  'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
убираем #### на нужные цифры работает
Option Explicit
Код
 
Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, 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
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = ""    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\GOODSANDGROUPS_Import_AddOrUpdate_20210517####" & ".xml"  'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
   
Изменено: splashsnake - 17.05.2021 17:43:14
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 16:03:50
пробывал менять по разному:
Код
sAttachment = ...& "****.xml"
sAttachment = ...& "####.xml"
sAttachment = ...& "*.xml"
sAttachment = ...& "****"&".xml"
sAttachment = ...& "####"& ".xml"

не подхватывает файл, а если конкретно указывать  1234 то идет подхват файла или любые другие
Код
sAttachment =...& "1234"& ".xml"
sAttachment = "E:\имя1\имяфайла_"&"1234"&".xml"

1234 - ****
1234 - ####
если я прописываю ####  или  **** то он ищет в названии файла  **** или #### то есть файл называется
Код
sAttachment = "E:\имя1\имяфайла_"&"####"&".xml"  а не sAttachment = "E:\имя1\имяфайла_"&"1234"&".xml"

и не подкрепляет его
 
Перейти    
Автоподхват excel vba вложений с неизвестным окончанием
 
#
17.05.2021 15:10:26
добрый день кто то может подсказать  с именами подхватом файлов
Код
sAttachment = "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Eeno1").Range("A1") & "1232.xml"
но последние 4 знака динамические и меняются постоянно
& "****.xml"
& "*.xml"
пробовал менять концовки на **** но тогда подхват файла идет если есть в конце названия ****
как правильно прописать рандомное окончание чтоб не делать дубликаты
Код
sAttachment = "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Eeno1").Range("A1") & "1232.xml"
sAttachment = "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Eeno1").Range("A1") & "1233.xml"  
sAttachment = "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Eeno1").Range("A1") & "1234.xml"
то есть как правильное прописать чтоб захватывал любой файл в котором есть начало  
Код
sAttachment = "\\ip\TNS_Loyalty\GOODSANDGROUPS_Import_AddOrUpdate_" & ActiveWorkbook.Sheets("Eeno1").Range("A1")
и любое окончание из 4 символов "1234.xml"  
Изменено: splashsnake - 17.05.2021 16:54:45
 
Перейти    
vba Экспорт word shape объекта из экселя в ворд /подвязка файла shape (word), Экспорт word shape объекта из экселя ворд
 
#
07.10.2019 17:01:07
Проблему решил
сохранение объекта ворда в текущею папку

Sub Sample()
   Application.ScreenUpdating = False

   Dim shp As Shape
   Dim objWord As Object
   Dim objOLE As OLEObject

   Set shp = ThisWorkbook.Sheets("экспорт_ворд").Shapes("Объект_Протокол_рик_шаблон")

   shp.OLEFormat.Activate

   Set objOLE = shp.OLEFormat.Object

   Set objWord = objOLE.Object

   objWord.SaveAs Filename:=ActiveWorkbook.Path & "\" & "Рик от " & ThisWorkbook.Sheets("рик").Range("i2") & " " & ThisWorkbook.Sheets("рик").Range("h2") & ".docx"


   objWord.Application.Quit

   Set objWord = Nothing
   Set shp = Nothing
   Set objOLE = Nothing

   Application.ScreenUpdating = True
End Sub
 
Перейти    
vba Экспорт word shape объекта из экселя в ворд /подвязка файла shape (word), Экспорт word shape объекта из экселя ворд
 
#
07.10.2019 15:26:48
Добрый день товарищи по экселю

есть такой код

Sub protokol_rik()  ' создание протокола рик


Dim path_rik_fail As String
Dim save_path_rik_fail As String
Dim namerikDoc As String
Dim objwrdapp As Object
Dim objworddoc As Object
'activeworkbook.Path &"\" ткущее местоположение

path_rik_fail = ThisWorkbook.Sheets("экспорт_ворд").Range("rik_fail") ' указываем страницу и путь к нашему файлу
save_path_rik_fail = ActiveWorkbook.Path & "\" ' указываем путь и путь к сохранению файла save_path_rik_fail = ThisWorkbook.Sheets("экспорт_ворд").Range("rik_save_fail") вручную
namerikDoc = "Протокол рик шаблон" ' название нашего шаблона
Set objwrdapp = CreateObject("word.application") ' создание вордовского документа из приложения
objwrdapp.Visible = True 'делали наш объект видимым
Set objworddoc = objwrdapp.documents.Open(path_rik_fail & namerikDoc & ".docx") 'прописываем путь к нашему объекту для открытия.
With objworddoc
.bookmarks("д_инв").Range.Text = ThisWorkbook.Sheets("рик").Range("i2") ' в нашу закладку д_инв заносим нашу дату.
.bookmarks("д_инв1").Range.Text = ThisWorkbook.Sheets("рик").Range("i2")

.bookmarks("м_азк").Range.Text = ThisWorkbook.Sheets("рик").Range("h2")
.bookmarks("м_азк1").Range.Text = ThisWorkbook.Sheets("рик").Range("h2")
.bookmarks("м_азк2").Range.Text = ThisWorkbook.Sheets("рик").Range("h2")

.bookmarks("номер_приказа").Range.Text = ThisWorkbook.Sheets("рик").Range("c2")
.bookmarks("номер_приказа1").Range.Text = ThisWorkbook.Sheets("рик").Range("c2")

.bookmarks("дата_приказа").Range.Text = ThisWorkbook.Sheets("рик").Range("d2")
.bookmarks("дата_приказа1").Range.Text = ThisWorkbook.Sheets("рик").Range("d2")

.bookmarks("вид2").Range.Text = ThisWorkbook.Sheets("рик").Range("g2")

.bookmarks("нед").Range.Text = ThisWorkbook.Sheets("рик").Range("j2")
.bookmarks("нед18").Range.Text = ThisWorkbook.Sheets("рик").Range("k2")
.bookmarks("нед10").Range.Text = ThisWorkbook.Sheets("рик").Range("l2")

.bookmarks("изл").Range.Text = ThisWorkbook.Sheets("рик").Range("m2")
.bookmarks("изл18").Range.Text = ThisWorkbook.Sheets("рик").Range("n2")
.bookmarks("изл10").Range.Text = ThisWorkbook.Sheets("рик").Range("o2")

.bookmarks("пер").Range.Text = ThisWorkbook.Sheets("рик").Range("p2")

.bookmarks("окн").Range.Text = ThisWorkbook.Sheets("рик").Range("s2")
.bookmarks("окн18").Range.Text = ThisWorkbook.Sheets("рик").Range("t2")
.bookmarks("окн10").Range.Text = ThisWorkbook.Sheets("рик").Range("u2")

.bookmarks("оки").Range.Text = ThisWorkbook.Sheets("рик").Range("v2")
.bookmarks("оки18").Range.Text = ThisWorkbook.Sheets("рик").Range("w2")
.bookmarks("оки10").Range.Text = ThisWorkbook.Sheets("рик").Range("x2")

.bookmarks("д_пред").Range.Text = ThisWorkbook.Sheets("рик").Range("et2")
.bookmarks("пред_рик").Range.Text = ThisWorkbook.Sheets("рик").Range("es2")
.bookmarks("Д_чл1").Range.Text = ThisWorkbook.Sheets("рик").Range("ev2")
.bookmarks("Чл_1").Range.Text = ThisWorkbook.Sheets("рик").Range("eu2")
.bookmarks("Д_чл2").Range.Text = ThisWorkbook.Sheets("рик").Range("ex2")
.bookmarks("ЧЛ_2").Range.Text = ThisWorkbook.Sheets("рик").Range("ew2")


End With
objworddoc.SaveAs Filename:=save_path_rik_fail & "Рик от " & ThisWorkbook.Sheets("рик").Range("i2") & " " & ThisWorkbook.Sheets("рик").Range("h2") & ".docx"

End Sub


хотел бы откорректировать но знаний у самоучки не хватает.

В чем суть корректировки у меня все файлы лежать в определенных папках путях c них эксель подвязывает шаблоны . но хотелось бы каждых образец шаблона ворд был внутри экселя. и ненужно было перепривязывать пути.

когда вставляешь объект ворд в эксель он становиться shape. то есть объектом похож на картинку.


как пытался решить данную проблему:
1. вариант подвязать пути напрямую к объекту но тогда  закладки .bookmarks("д_инв1").Range.Text = ThisWorkbook.Sheets("рик").Range("i2") становятся ошибочными

2. вариант вставлял данные шаблоны как объекты в эксель. и пытался из экселя данные объекты  экспортировать их как файл word в текущую папку. (провал не получилось) а затем путем из текущей директории подхватывать данные шаблоны.


Вдруг кто знает как можно сделать
1. настроить прямую подвязку из объектов  (ворд) в excele
или 2 вариант
сохраненный объект в экселе экспортировать в текущую папку сохранив формат ворда а от туда я уже сам восстановлю подвязку пути шаблона

или если знаете то какой вариант возможен?.
 
Перейти    
Страницы: 1
Наверх