» Word VBA

Ребят, подскажите как пакетно вставить "Водяные знаки" или Подложку на документы Word (*.doc, *.rtf), которых порядка 70, а кажый документ имеет объем от 3 до 45 страниц... Я понимаю что с помощью макроса, понимаю, но не более

У меня следующая проблема. В одном документе пометил закладками часть нумерованного списка, копирую его программно и вставляю в другой документ. При этом во 2-м документе нумерация списка уже начинается не с 1, а с другой цифры, т.к. в этом документе до этого где-то в начале имеется другой нумерованный список. Попробовал через Recoder посмотреть как изменить нумерацию, но всё как-то сложно и не универсально. Хотелось бы знать из-за чего нумерация меняется, и как это обойти. Спасибо.

Добавлено:
Всё, слава Богу! разобрался. Для того чтобы нумерация началась опять с "1", нужно следующее. Сначала встаю курсором на первый пункт, затем:

Код: Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdOutlineNumberGallery).ListTemplates(1), _
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList

Ребята есть такая задача нумерую столбец в таблице циклом передвигаюсь вниз по столбцу, с формы операции задается количество повторений из этого же берутся число счетчика.
Дак вот мне нужно остановить цикл в тот момент когда одна из ячеек окажется не пустой.
К примеру цикл обрабатывает 20 ячеек, 15 ячейка не пустая на ней нужно выйти из цикла.

Как определить пустая следующая ячейка или нет?

Здравствуйте. Я не знаток в программировании, по этому не пинайте сильно. Есть word2003 документ со статистикой звонков, содержимое следующее

Тлф: 1001     Имя:Фамилия 1. (11-11-01)
     Городских:171
    Общая длительность:4:14:25    Всего звонков:171    Длительность:4:14:25
    Общая стоимость:91,53     Стоимость:91,53

Тлф: 1002     Имя:Фамилия 2 (11-11-02)
    Всего звонков:305     Городских:305
    Общая длительность:7:44:15    Стоимость:166,59    Длительность:7:44:15
    Общая стоимость:166,59

Тлф: 1003     Имя:Фамилия 3 (11-11-03)
    Всего звонков:103      Городских:103
    Общая длительность:2:03:16     Длительность:2:03:16
    Общая стоимость:48,6     Стоимость:48,6


необходимо перенести в excel2003 в следующую таблицу значения с номером, фамилией и общей стоимостью в столбцы A, B и D соответственно

Номер     Наименование     Общая длительность     Общая стоимость
Тлф: 1001     Имя:Фамилия 1 (11-11-01)    5:39     91,53
Тлф: 1002     Имя:Фамилия 2 (11-11-02) 10:17     166,59
Тлф: 1003     Имя:Фамилия 3 (11-11-03) 3:0     48,6


при этом Общая длительность высчитывается по формуле =(ОКРУГЛВНИЗ(D2/0,27/60;0)) & ":" & ОКРУГЛ(ОСТАТ(D2/0,27;60);1) из общей стоимости.
Сейчас делаю вручную, то есть копирую номер телефона, фамилию и общую стоимость. А это очень долго, тем более там позиций более 80. Как правильно написать макрос для переноса значений из word excel? Если есть аналогичные примеры дайте ссылку. Извиняюсь если это обсуждалось ранее.

fireart
проблема с excel или извлечением данных?
у первого номера "Всего звонков:" не там где у остальных это верно?

Цитата:

Как определить пустая следующая ячейка или нет?

А в полных ячейках у тебя стоят цифры или буквы?
Пустая ячейка или нет, можно определить сравнением.

smirnvlad
С excel проблем нет. Знать бы как в него извлечь данные из word и вставить в соответствующие столбцы.

Цитата:

у первого номера "Всего звонков:" не там где у остальных это верно?

да, тут уж как wintariff себя поведет.

-> Тлф: 1002 -> Имя:Фамилия2 (11-11-02)п
-> Всего звонков:305     -> Городских:305п
->    Общая длительность:7:44:15 ->    Стоимость:166,59 -> Длительность:7:44:15п
->    Общая стоимость:166,59п
->Тлф: 1003 -> Имя:Фамилия3 (11-11-03)
-> Всего звонков:103      -> Городских:103п
-> Общая длительность:2:03:16 ->    Длительность:2:03:16п
-> Общая стоимость:48,6     -> Стоимость:48,6п

Здесь "->" табуляция, "п" переход строки

Алгоритм я думаю должен быть такой - сначала задать счетчик n=1, далее поиск текстового значения "Тлф", если найден копировать строку после -> начиная с "Тлф: 1xxx -> Имя:ФамилияX (11-11-0X)" до перехода строки "п" в excel An, (так как есть -> то Значение с именем вставится в соответствующую ячейку Bn ) , далее искать "стоимость" (без учета регистра букв) если найден копировать числовое значение которое идет после "Стоимость:" до перехода строки "п" и вставлять в Dn. После в поле Cn вставить функцию =
(ОКРУГЛВНИЗ(Dn/0,27/60;0)) & " ч " & ОКРУГЛ(ОСТАТ(Dn/0,27;60);1) & " мин" и увеличить счетчик n+1

Закончить поиск при нахождении двух символов перехода строки. (так заканчивается word документ)

Только как это правильно описать на VBA?

Цитата:

А в полных ячейках у тебя стоят цифры или буквы?
Пустая ячейка или нет, можно определить сравнением.

Как правило цифры и точки, бываает и буквы.
я просто не могу подобрать правильный оператор из selection.

fireart
макрос для Word создаст новый Excel
если так не сработает нужен будет кусок от реального файла
[more]
Код: [no]
Function MultiIndex(str As String, substrs, StartAt As Integer)
ind = 0
For Each sstr In substrs
i = InStr(StartAt, str, sstr)
If (i > 0) And ((i < ind) Or (ind < 1)) Then ind = i
Next
MultiIndex = ind
End Function
Function ParseParams(str As String, params)
Dim d As New Collection
Dim start As Integer

start = 1
For Each par In params
s = InStr(start, str, par)
e = MultiIndex(str, params, s + 1)
If e <= 0 Then
st = Mid(str, s + Len(par))
Else
st = Mid(str, s + Len(par), e - (s + Len(par)))
End If
For i = 9 To 13
st = Replace(st, Chr$(i), "")
Next
st = Replace(st, Chr(160), "")
st = Replace(st, vbLf, "")
st = Replace(st, vbCr, "")
st = Replace(st, vbLf, "")
st = Trim(st)
d.Add Item:=st, Key:=par
Next
Set ParseParams = d
End Function

Sub SendToExcel(ParamsList)

Dim xlApp As Object
Dim xlWB As Object
Dim i As Integer
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
' or
'Set xlWB = xlApp.Workbooks.Open("C:\Foldername\Filename.xls")
' open an existing workbook
' example excel operations
With xlWB.Worksheets(1)
i = 1
.Cells(i, 1).Value = "Номер"
.Cells(i, 2).Value = "Наименование"
.Cells(i, 3).Value = "Общая длительность"
.Cells(i, 4).Value = "Общая стоимость"

i = 2
For Each bill In ParamsList
.Cells(i, 1).Value = bill("Тлф:")
.Cells(i, 2).Value = bill("Имя:")
.Cells(i, 4).Value = bill("Общая стоимость:")
.Cells(i, 3).Formula = "=CONCATENATE(ROUNDDOWN(RC[1]/0.27/60,0),"":"",ROUND(MOD(RC[1]/0.27,60),1))"
i = i + 1
Next
End With
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
Sub ВыгрузитьВExcel()
Dim a As New Collection
Set doc = ActiveDocument
Set r = doc.Content
r.Find.ClearFormatting
With r.Find
.Text = "Тлф:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

params = Array("Тлф:", "Имя:", "Всего звонков:", "Городских:", "Общая длительность:", "Стоимость:", "Длительность:", "Общая стоимость:")

If r.Find.Execute Then
ps = r.start
While r.Find.Execute
Set t = doc.Content
t.SetRange start:=ps, End:=r.start
a.Add ParseParams(t.Text, params)
ps = r.start
Wend
Set t = doc.Content
t.SetRange start:=ps, End:=doc.Content.End
a.Add ParseParams(t.Text, params)
End If

SendToExcel a
End Sub
[/no]

smirnvlad
Спасибо огромное, все работает отлично, без ошибок. Единственное что я изменил "=CONCATENATE(ROUNDDOWN(RC[1]/0.27/60,0),"" "",""ч"","" "",ROUND(MOD(RC[1]/0.27,60),1),"" "",""мин"")"
Как изменить размер шрифта, курсив? Для шапки в excel
Номер Наименование Общая длительность Общая стоимость
и колонны D (с общей стоимостью ) выделить жирным шрифтом, колонны А и В (без шапки)сделать 8 размером шрифта, а для В еще и курсив?

fireart
[more]
заменить Sub SendToExcel(ParamsList) на этот

Код: [no]
Sub SendToExcel(ParamsList)

Dim xlApp As Object
Dim xlWB As Object
Dim i As Integer
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
' or
'Set xlWB = xlApp.Workbooks.Open("C:\Foldername\Filename.xls")
' open an existing workbook
' example excel operations
With xlWB.Worksheets(1)
i = 1
.Cells(i, 1).Value = "Номер"
.Cells(i, 2).Value = "Наименование"
.Cells(i, 3).Value = "Общая длительность"
.Cells(i, 4).Value = "Общая стоимость"

i = 2
For Each bill In ParamsList
.Cells(i, 1).Value = bill("Тлф:")
.Cells(i, 2).Value = bill("Имя:")
.Cells(i, 4).Value = Val(bill("Общая стоимость:"))
.Cells(i, 3).Formula = "=CONCATENATE(ROUNDDOWN(RC[1]/0.27/60,0), "" ч "", ROUND(MOD(RC[1]/0.27,60),1), "" мин"")"
i = i + 1
Next

xlLeft = -4131
xlCenter = -4108
xlRight = -4152
xlUnderlineStyleSingle = 2
xlUnderlineStyleNone = -4142
' Столбцы
With .Columns("A:B").Font
.Size = 8
End With
.Columns("B:B").Font.Italic = True ' Курсив
With .Columns("D:D")
.Font.Bold = True ' Жирный
.NumberFormat = "0.00" 'Два знака после запятой
End With
' шапка .область(первая ячейка области, последняя)
With .Range(.Cells(1, 1), .Cells(1, 4))
With .Font
'.Name = "Arial"
.Size = 10
'.StrikeThrough = False
'.Superscript = False
'.Subscript = False
'.OutlineFont = False
'.Shadow = False
.Bold = True 'Жирный
.Italic = True ' Курсив
'.Underline = xlUnderlineStyleSingle ' Подчеркнутый
'.Underline = xlUnderlineStyleNone ' Не подчеркнутый
End With
End With
.Columns("A:D").EntireColumn.AutoFit
End With
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
[/no]

Здравствуйте! не могу запустить пример, приводимый на сайте MS:
Ссылка почему-то не подключается Scripting Runtime, строчки типа "Dim fsoSysObj As FileSystemObject" не воспринимаются как нужно, т.е. "FileSystemObject" не подсвечивается

vaulin
если офис не 2000, как по ссылке, то про работу с файлами надо почитать про более новый VB, например Ссылка

да, офис 2007, спасибо за ответ, попробую. Программирую на VBA for Word, а система WinXP

smirnvlad
Спасибо! Теперь все как надо, пару косметических поправок и вот [more=конечный результат...]
Sub SendToExcel(ParamsList)

Dim xlApp As Object
Dim xlWB As Object
Dim i As Integer
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
With xlWB.Worksheets(1)
i = 1
.Cells(i, 1).Value = "Номер"
.Cells(i, 2).Value = "Наименование"
.Cells(i, 3).Value = "Общая длительность"
.Cells(i, 4).Value = "Общая стоимость"

i = 2
For Each bill In ParamsList
.Cells(i, 1).Value = bill("Тлф:")
.Cells(i, 2).Value = bill("Имя:")
.Cells(i, 4).Value = bill("Общая стоимость:")
.Cells(i, 3).Formula = "=CONCATENATE(ROUNDDOWN(RC[1]/0.27/60,0), "" ч "", ROUND(MOD(RC[1]/0.27,60),1), "" мин"")"
i = i + 1
Next

xlLeft = -4131
xlCenter = -4108
xlRight = -4152
xlUnderlineStyleSingle = 2
xlUnderlineStyleNone = -4142
' Столбцы
With .Columns("A:B").Font
.Size = 8
End With
.Columns("A:A").Font.Bold = True
.Columns("B:B").Font.Bold = True
.Columns("B:B").Font.Italic = True ' Курсив
With .Columns("D:D")
.Font.Bold = True ' Жирный
.NumberFormat = "0.00" 'Два знака после запятой
End With
' шапка .область(первая ячейка области, последняя)
With .Range(.Cells(1, 1), .Cells(1, 4))
With .Font
.Size = 10
.Bold = True 'Жирный
.Italic = False ' Курсив
End With
End With
.Columns("A:A").EntireColumn.HorizontalAlignment = xlCenter
.Columns("B:C").EntireColumn.HorizontalAlignment = xlLeft
.Columns("D:D").EntireColumn.HorizontalAlignment = xlRight
.Columns("A:D").EntireColumn.AutoFit
End With
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
[/more]

smirnvlad

Цитата:

Bluk
наверное это подойдет
Подробнее...

Спасибо то что нужно, правда не много переделал.
Расширил немного сваи знания спасибо тебе.

Цитата:

если офис не 2000, как по ссылке, то про работу с файлами надо почитать про более новый VB, например Ссылка

что-то не нашел никаких замечаний по подключению этой библиотеки. Вроде всё правильно сделал: в Reference указал данную библиотеку. А когда начинаю ее использовать, ее как-будто бы и нет. Может Microsoft Scripting Runtime под VBA не работает, а только под VB? Или для 2007 офиса эта библиотека не совместима с XP?

vaulin
Dim fsoSysObj As Scripting.FileSystemObject

smirnvlad,

Цитата:

Dim fsoSysObj As Scripting.FileSystemObject

а как объявить объект "Folder"? Dim fdrFolder as Scripting.Folder что-то не работает. Пишу следующий код:

Код: Dim dctDict As Variant 'Dictionary
Dim strPath As Variant
Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder 'Dim fdrFolder: Set fdrFolder = CreateObject("Scripting.Folder") ' As Folder
Set dctDict = CreateObject("Scripting.FileSystemObject") 'New Dictionary
Set fsoSysObj = CreateObject("Scripting.FileSystemObject")
Set fdrFolder = fsoSysObj.GetFolder(strPath)

vaulin
может неправильный argument

пример
[more]
Код: [no]
Function GetFiles(strPath As String, _
dctDict As Scripting.Dictionary, _
Optional blnRecursive As Boolean) As Boolean

' This procedure returns all the files in a directory into
' a Dictionary object. If called recursively, it also returns
' all files in subfolders.

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

' Return new FileSystemObject.
Set fsoSysObj = New FileSystemObject

On Error Resume Next
' Get folder.
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' Incorrect path.
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0

' Loop through Files collection, adding to dictionary.
For Each filFile In fdrFolder.Files
dctDict.Add filFile.Path, filFile.Path
Next filFile

' If Recursive flag is true, call recursively.
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If

' Return True if no error occurred.
GetFiles = True

GetFiles_End:
Exit Function
End Function

Sub TestGetFiles()
' Call to test GetFiles function.

Dim dctDict As New Scripting.Dictionary
Dim varItem As Variant

' Call non recursively, return files into Dictionary object.
If GetFiles("C:\", dctDict, False) Then
' Print items in dictionary.
For Each varItem In dctDict
Debug.Print varItem
Next
End If
End Sub
[/no]

smirnvlad, спасибо. Я уже пробовал этот пример. Код, кот. я приводил, сделан из этого примера . Что-то, похоже, с системой не так. Потому что файл scrrun.dll -- есть, в Reference на него указано. Видимо, нужно обновить этот файл что ли.

vaulin
так а пример работает?

Set fdrFolder = fsoSysObj.GetFolder(strPath)
5: Invalid procedure call or argument у меня выскакивает если strPath Empty

Всё, smirnvlad, заработало! Пример не работал изначально. Дело, как я понял, было в том, что я перенес вначале файл scrrun.dll из system32 в system (купился на MS help) и попытался оттуда подключить эту библиотеку. Сейчас всё вернул на место, отключил эту библиотеку и подключил заново. Всё, пример заработал. Я туда еще добавил строчку "MsgBox dctDict.Count" и он выдает кол-во файлов на диске "С". Спасибо, smirnvlad, за поддержку!

салют!
у меня постоянный гемор с мсвордом - сквозной вложенной нумерацией. начиная с версии 95.

то есть я не могу добиться стабильной работы ворда в отношении форматирования глав и пунктов:

1.Заголовок первого уровня
1.1.Пункт одын-одын
1.2.Заголовок второго уровня
1.2.1.Пункт одын-два-одын
хочется, чтобы запуском макроса я стандартизовал стили заголовков и списков как в новых документах, так и в присланных мне.

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

основная проблема, как я понял в том, чтобы:

а)заставить заголовки и пункты опираться на одну нумерацию "1/1.1/1.1.1", причём на ту же самую среди всех, которые называются "1/1.1/1.1.1". это фаза луны на всех моих инсталляциях.

б)ListGalleries(wdOutlineNumberGallery).ListTemplates(N).ListLevels(8) - вот эта N сильно плавает от документа к документу, от редакции документа к редакции. а может даже от запуска ворда к другому запуску.

сейчас попытался задать
With ListGalleries(wdOutlineNumberGallery).ListTemplates(i).ListLevels(1)
.NumberFormat = "%1."
.TrailingCharacter = wdTrailingSpace
.NumberStyle = wdListNumberStyleArabic
.NumberPosition = CentimetersToPoints(0)
.Alignment = wdListLevelAlignLeft
.TextPosition = CentimetersToPoints(0)
.TabPosition = wdUndefined
.ResetOnHigher = 0
.StartAt = 1
With .Font
.Bold = wdUndefined
.Italic = False
.StrikeThrough = False
.Subscript = False
.Superscript = False
.Shadow = False
.Outline = False
.Emboss = False
.Engrave = False
.AllCaps = False
.Hidden = False
.Underline = False
.Color = False
.Size = False
.Animation = False
.DoubleStrikeThrough = False
.Name = ""
End With
.LinkedStyle = ""
End With
для всех N от 0 до 100

но к должному результату это не приводит - либо заголовки имеют тонкие цифры, либо пункты имеют жирные цифры. либо кнопочка "нумерация" на тулбаре превращает любое форматирование абзаца в стиль "Заголовок 1".

как схватить стиль за яйца?
или как по другому решить задачку?

в принципе, я уже и готов в течение 10 дней выдать победителю 50 баксов.
если есть желающие, могу сформулировать подробное ТЗ на макрос.

Здравствуйте!

Есть проблема, не получается написать макрос для форматирования полей документа
(верхнее, левое) так чтобы остальные параметры документа не изменялись, тоесть только необходимо изменять поля на величину указанную пользователем. Если кто то сталкивался с такой проблемой или просто знает как ее решить, то пожалуйста подскажите?

dummy84
А в чем проблема то?
Записываешь макрос, потом редактируешь его, убирая все лишнее и получается


Код:
Sub Макрос15()
'
' Макрос15 Макрос
'
'
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With

'То что вверху не знаю почему появилось ,
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = MillimetersToPoints(15)
.LeftMargin = MillimetersToPoints(10)
.BottomMargin = MillimetersToPoints(20)
.RightMargin = MillimetersToPoints(15)
.Gutter = MillimetersToPoints(0)
.HeaderDistance = MillimetersToPoints(12.7)
.FooterDistance = MillimetersToPoints(12.7)
.PageWidth = MillimetersToPoints(210)
.PageHeight = MillimetersToPoints(296.9)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = True
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub

Цитата:

[/q][q]салют!
у меня постоянный гемор с мсвордом - сквозной вложенной нумерацией. начиная с версии 95.

Может я чего-то не понял?!... Вероятно, у вас проблемы в работе со стилями.
В своих документах у меня не бывает проблем, т.к. в нормал.дот вшиты нужные стили, а из чужих документов на вба удаляю все стили и импортирую свои из нормал.дот. Если свои стили четко не применились, то можно и поабзацно пробежаться макросом через "если стиль" и принудительно назначать стиль. ВБА может все, а подключение библиотеки ВБС - это "смертельное оружие"...
И я не ленюсь вообще со всего текста снять форматирование и удалить стили, а потом все сделать по своему, многое - через ВБА. Почистить, назначить стили рисункам и таблицам, подписям к ним.
Я не автоматизирую редактирование на 100%, что было бы вредно, а пользуюсь раздельно порядка 3-х десятков макросов, заточенных под конкретные цели. В итоге, считаю скорость обработки приемлемо быстрой.
Если же в доке оставлять старые стили, то ... фиг знает, как будет все это... Не пробовал и не хочу...

vvvvv2 22:37 02-12-2010
Цитата:

а подключение библиотеки ВБС - это "смертельное оружие"...

А об этом можно побольше узнать. Я тоже в так работаю, но о "смертельном оружии" не в курсе.

Dear All,
VBA не знаю совсем. Да и API ворда. Есть такая проблема, может кто поможет скриптом.

Есть выделенная область. Нужно ее транслитирировать (таблица транслитерации есть, например, там - http://gsnti-norms.ru/norms/common/doc.asp?0&/norms/stands/7_79.htm). Некириллические символы оставить - т.е. не трогать и не менять. Office 97Pro.

Задача, к сожалению, постоянная (не разовая).

BagaBaga
А PuntoSwitcher не подойдет? И переключатель клавиатуры, и автосмена раскладки, и в том числе транслитерация туда и обратно. И на клавиатуру можно это настроить.
Хотя в принципе и макрос не сильно сложный должен быть.