Перейти из форума на сайт.

НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Подскажите, как реализовать при помощи VBA или ...

Модерирует : ShIvADeSt

 Версия для печати • ПодписатьсяДобавить в закладки

Открыть новую тему     Написать ответ в эту тему

Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Необходимо:
1) скачать вложение (.doc) от определенного адресата и сохранить его в папку на компьютере (получилось сделать при помощи outlook + vba)
2) взять из скачанного word-файла (.doc), часть таблицы (первую и последнюю строку определять по ключевым словам) и скопировать ее в определенное место другого word-файла (1.docx). (самая сложная для меня задача на данный момент)
3) отправить 1.docx на определенную почту
 
В идеале в п. 2 еще добавить дополнительную колонку, в которую автоматически поставятся значения, в зависимости от первой колонки (удалось отдельно реализовать в excel)
 
Подскажите, пожалуйста, куда копать .)

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 12:09 12-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
п.2 пока без дополнительной колонки

Код:
Sub test1()
    Call copyReceivedTable(Application.Documents("received.doc"), Application.Documents("tosend.doc"))
End Sub
 
Sub copyReceivedTable(docReceive As Word.Document, docSend As Word.Document)
    Dim iCell As Word.Cell
    Dim Rng As Word.Range
    Dim l As Long, k As Long, kk As Long
     
    If docReceive.Tables.Count >= 1 Then
        For Each iCell In docReceive.Tables(1).Range.Cells
            l = Len(iCell.Range.Text) - 2
            If Len(iCell.Range.Text) >= 0 Then
                If Left(iCell.Range.Text, l) = "KeywordStart" Then k = iCell.RowIndex
                If Left(iCell.Range.Text, l) = "KeywordEnd" Then kk = iCell.RowIndex
            End If
        Next iCell
        If k > 0 And kk >= k Then
            docReceive.Range(Start:=docReceive.Tables(1).Rows(k).Range.Start, End:=docReceive.Tables(1).Rows(kk).Range.End).Select
            Selection.Copy
            Set Rng = docSend.Content
            Rng.Collapse Direction:=wdCollapseEnd
            Rng.Paste
        End If
    End If
End Sub

 
файлы received.doc и tosend.doc должны существовать и быть открыты. если требуется вставлять таблицу в новый документ необходимо прописать его создание. вставка части таблицы сейчас идет в конец документа tosend.doc, определенное место надо чем-то определить. попробуйте создать процедуру copyReceivedTable прямо в аутлуке и вызвать оттуда, если не получится, то создать ее в шаблоне Normal для ворда

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 11:36 14-05-2018 | Исправлено: DenSyo, 14:28 14-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
DenSyo, спасибо большое, я сдвинулся с мертвой точки
 
 
Outlook со словами "user-defined type not defined" ругается на строку:  

Код:
Sub copyReceivedTable(docReceive As Word.Document, docSend As Word.Document)

 
В word в шаблоне Normal получилось исполнить код, правда наткнулся на то, что в моем документе есть объединенные ячейки по вертикали и они мешают. Если я их убираю, то копирование происходит успешно.

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 22:59 14-05-2018 | Исправлено: Steile_Ei, 22:59 14-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору

Цитата:
есть объединенные ячейки по вертикали и они мешают

то же самое может происходить при добавлении столбца в скопированную часть таблицы, и если скопированная таблица примкнет в новом документе к другой таблице, то добавление столбца стандартными средствами добавит столбец во всей объединенной таблице. в этом случае границы надо рисовать карандашом и подгонять ширины ячеек самостоятельно.  

Цитата:
user-defined type not defined

для запуска из аутлука надо объявлять все объекты ворда как неопределенный Object и по ходу создавать объекты. вот неплохая статья и вот. но для разработки лучше иметь копию функций в ворде с правильно объявленными объектами, будут видны методы и свойства.  
 
сделал в алгоритме проход по всем существующим таблицам с копированием всех совпадающих диапазонов

Код:
Sub copyReceivedTable(docReceive As Object, docSend As Object)
    Dim iCell As Object
    Dim Rng As Object
    Dim l As Long, i As Long, j As Long, k() As Long, kk() As Long, t() As Long
     
    If docReceive.Tables.Count >= 1 Then
        i = 0
        ReDim kk(0 To 0)
        kk(0) = 1
        For j = 1 To docReceive.Tables.Count
            For Each iCell In docReceive.Tables(j).Range.Cells
                l = Len(iCell.Range.Text) - 2
                If Len(iCell.Range.Text) >= 0 Then
                    If Left(iCell.Range.Text, l) = "KeywordStart" And kk(i) <> 0 Then
                        i = i + 1
                        ReDim Preserve k(0 To i)
                        ReDim Preserve kk(0 To i)
                        ReDim Preserve t(0 To i)
                        t(i) = j
                        k(i) = iCell.RowIndex
                    End If
                    If (Left(iCell.Range.Text, l) = "KeywordEnd" Or iCell.RowIndex = docReceive.Tables(j).Rows.Count) And kk(i) = 0 Then kk(i) = iCell.RowIndex
                End If
            Next iCell
        Next j
        If i > 0 Then
            For j = 1 To i
                docReceive.Range(Start:=docReceive.Tables(t(j)).Rows(k(j)).Range.Start, End:=docReceive.Tables(t(j)).Rows(kk(j)).Range.End).Select
                Selection.Copy
                Set Rng = docSend.Content
                Rng.Collapse Direction:=wdCollapseEnd
                Rng.Paste
            Next j
        End If
    End If
End Sub

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 05:02 15-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
DenSyo, для чистоты эксперимента пока что в ворде тестирую.
Доработанная версия перестала ругаться на сдвоенные ячейки, теперь просто игнорирует их. Без сдвоенных работает как часы.
 
У меня исходная таблица получается вида:  
-------------------------
заголовок|заголовок|
-------------------------
текст       |текст        |
-----------|                |
текст       |                |
-------------------------
текст       |текст        |
-----------|                |
текст       |                |
-------------------------
 
Может, можно перед выполнением скрипта проигнорировать первую строку, а потом в первой колонке каждые 2 ячейки объединять? Чтобы получилась "ровная таблица" (и скрипт работал) вида:
 
-------------------------
заголовок|заголовок|
-------------------------
текст       |текст        |
текст       |                |
-------------------------
текст       |текст        |
текст       |                |
-------------------------  

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 13:15 15-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
красивше все сделал, тестируйте. попробуйте с разным keySet от 0 до 7, второй и третий бит не имеет смысла устанавливать вместе, но проверьте на всякий случай разные варианты. не все случаи отрабатывает объединение по вертикали, но ваш случай отработает верно.  

Код:
Sub test1()
    Call copyReceivedTable(Application.Documents("received.docm"), Application.Documents("tosend.docx"), "KeywordStart", "KeywordEnd", 0, 0)
End Sub
 
' процедура копирования из таблиц документа docReceive частей таблиц определяемых по ключевым словам keywordStart и keywordEnd в документ docSend
' документы docReceive и docSend должны быть открыты
' необязательные параметры:
' withTables - номер таблицы в документе docReceive к которой применить процедуру, 0 - применить ко всем таблицам
' keySet - флаги обработки копируемых таблиц:
'   младший бит - добавить столбец справа
'   второй бит - разбить таблицу, убрать объединение ячеек
'   третий бит - произвести объединение по вертикали в строках в которых присутствуют объединенные ячейки
' addedColWidth - ширина добавляемого столбца. по умолчанию 30
Sub copyReceivedTable(docReceive As Word.Document, docSend As Word.Document, keywordStart As String, keywordEnd As String, Optional withTables As Long = 0, Optional keySet As Byte = 0, Optional addedColWidth As Double = 30)
    Dim iCell As Word.Cell
    Dim Rng As Word.Range
    Dim l As Long, n As Long, i As Long, j As Long, k() As Long, kk() As Long, t() As Long, doIt() As Long
     
    If docReceive.Tables.Count >= 1 Then
        i = 0
        ReDim kk(0 To 0)
        kk(0) = 1   'задаем флаг чтения ключевого слова начала блока для первого блока (<>0)
        For j = 1 To docReceive.Tables.Count
          If withTables = 0 Or j = withTables Then
            If (keySet And 2) And docReceive.Tables(j).Columns.Count > 1 And docReceive.Tables(j).Rows.Count > 1 Then   'разбить таблицу
                docReceive.Tables(j).Range.Cells.Split NumRows:=docReceive.Tables(j).Rows.Count, NumColumns:=docReceive.Tables(j).Columns.Count, MergeBeforeSplit:=True
            End If
            If (keySet And 4) And docReceive.Tables(j).Columns.Count > 1 And docReceive.Tables(j).Rows.Count > 1 Then  'объединение ячеек по вертикали
                ReDim doIt(1 To docReceive.Tables(j).Rows.Count)
                For Each iCell In docReceive.Tables(j).Range.Cells
                    If iCell.RowIndex > 1 Then
                        If Not iCell.Previous Is Nothing Then If (iCell.Previous.RowIndex < iCell.RowIndex Or iCell.ColumnIndex - iCell.Previous.ColumnIndex > 1) And iCell.ColumnIndex > 1 Then doIt(iCell.RowIndex) = 1
                        If Not iCell.Next Is Nothing Then If (iCell.Next.RowIndex > iCell.RowIndex Or iCell.Next.ColumnIndex - iCell.ColumnIndex > 1) And iCell.ColumnIndex < docReceive.Tables(j).Columns.Count Then doIt(iCell.RowIndex) = 1
                    End If
                Next iCell
                For l = docReceive.Tables(j).Range.Cells.Count To 1 Step -1
                    If doIt(docReceive.Tables(j).Range.Cells(l).RowIndex) > 0 Then
                        For n = docReceive.Tables(j).Range.Cells(l).RowIndex - 1 To 1 Step -1
                            On Error Resume Next
                            If Not docReceive.Tables(j).Cell(Row:=n, Column:=docReceive.Tables(j).Range.Cells(l).ColumnIndex) Is Nothing Then Exit For
                        Next n
                        docReceive.Tables(j).Cell(Row:=n, Column:=docReceive.Tables(j).Range.Cells(l).ColumnIndex).Merge mergeto:=docReceive.Tables(j).Range.Cells(l)
                    End If
                Next l
            End If
            If keySet And 1 Then    'добавление столбца справа
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width - addedColWidth
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Select
                Selection.InsertColumnsRight
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = addedColWidth
            End If
            For Each iCell In docReceive.Tables(j).Range.Cells
                l = Len(iCell.Range.Text) - 2
                If l > 0 Then
                    If Left(iCell.Range.Text, l) Like keywordStart & "*" And kk(i) <> 0 Then
                        i = i + 1
                        ReDim Preserve k(0 To i)
                        ReDim Preserve kk(0 To i)
                        ReDim Preserve t(0 To i)
                        t(i) = j
                        k(i) = iCell.RowIndex
                    End If
                    If (Left(iCell.Range.Text, l) Like keywordEnd & "*" Or iCell.RowIndex = docReceive.Tables(j).Rows.Count) And kk(i) = 0 Then kk(i) = iCell.RowIndex
                End If
            Next iCell
          End If
        Next j
        If i > 0 Then
            For j = 1 To i
                If kk(j) < docReceive.Tables(t(j)).Rows.Count Then l = docReceive.Tables(t(j)).Cell(kk(j) + 1, 1).Range.Start - 1 Else l = docReceive.Tables(t(j)).Range.End
                docReceive.Range(Start:=docReceive.Tables(t(j)).Cell(k(j), 1).Range.Start, End:=l).Select
                Selection.Copy
                Set Rng = docSend.Content
                Rng.Collapse Direction:=wdCollapseEnd
                Rng.Paste
            Next j
        End If
    End If
End Sub

PS поправил определение конца копируемого участка, теперь работает с объединенными ячейками

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 09:53 16-05-2018 | Исправлено: DenSyo, 16:10 16-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
DenSyo
Протестировал, не копирует, если ячейки в строке "неровные". Если объединяю "неровную" ячейку, то все нормально. Пробовал ставить Optional keySet As Byte от 0 до 7, ничего не менялось. Играл с ключевыми словами (пытался делать вида "текст текст" и "тексттекст").

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 15:15 16-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
поправил проверку на ключевые слова, теперь все что после ключевого слова не учитывается

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 16:11 16-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
DenSyo
Заработало. Добавляет новую колонку корректно, правда уходит за пределы листа.
 
И можно ли сделать чтобы он keywordEnd цеплял последний увиденный в таблице, а не первый? Или как вариант чтобы keywordStart был равен keywordEnd, но копировались все строки с данным ключевым словом? Или может чтобы keywordEnd искал начиная с конца таблицы?

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 17:07 16-05-2018 | Исправлено: Steile_Ei, 20:54 16-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Выровнял ячейки, теперь не уходит за пределы листа.
 
Поменял это:

Код:
If keySet And 1 Then    'добавление столбца справа  
               docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width - addedColWidth
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Select
                Selection.InsertColumnsRight
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = addedColWidth
            End If

на это:

Код:
If keySet And 1 Then    'добавление столбца справа
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width - addedColWidth
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Select
                Selection.InsertColumnsRight
                docReceive.Tables(j).Columns(docReceive.Tables(j).Columns.Count).Width = addedColWidth
                 
                docReceive.Tables(j).Columns(1).Width = 90
                docReceive.Tables(j).Columns(4).Width = 90
                docReceive.Tables(j).Columns(5).Width = 140
            End If

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 23:17 16-05-2018 | Исправлено: Steile_Ei, 23:19 16-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору

Цитата:
И можно ли сделать чтобы он keywordEnd цеплял последний увиденный в таблице, а не первый? Или как вариант чтобы keywordStart был равен keywordEnd, но копировались все строки с данным ключевым словом?

если при вызове процедуры указать одно и то же слово в качестве KeywordStart и KeywordEnd, то так и произойдет

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 02:08 17-05-2018
Steile_Ei

Junior Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
DenSyo, спасибо огромное, очень сильно Вы мне помогли. Все работает.
 
Для изменения ширины пошел немного другим путем. Так более корректно работает.

Код:
    docSend.Tables(1).Columns(1).Width = 50
    docSend.Tables(1).Columns(4).Width = 50
    docSend.Tables(1).Columns(5).Width = 50

 
По Вашим ссылкам научился из оутлук открывать ворд. Осталось из оутлука запустить макрос в ворде. И добавить данные в новую колонку исходя из ключевиков в первой колонке. И затем научиться отправлять созданный файл

Всего записей: 107 | Зарегистр. 30-05-2005 | Отправлено: 11:15 17-05-2018
DenSyo

Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
если все вордовские типы объектов заменить на Object, то можно функцию использовать прямо в аутлуке.  
пример по отправке письма
https://www.slipstick.com/developer/create-a-new-message-using-vba/

Всего записей: 218 | Зарегистр. 19-01-2008 | Отправлено: 08:48 21-05-2018 | Исправлено: DenSyo, 08:52 21-05-2018
Открыть новую тему     Написать ответ в эту тему

Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Подскажите, как реализовать при помощи VBA или ...


Реклама на форуме Ru.Board.

Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
Modified by Ru.B0ard
© Ru.B0ard 2000-2024

BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

Рейтинг.ru