1

Тема: Сохранение документа по имени из колонтитула

Здравствуйте уважаемые форумчане!
Часто приходится составлять документы с однотипным именем файла цифровой код которого совпадает с таким же кодом из колонтитула, но с некоторых пор приходится добавлять еще и дату сохранения. Хотелось бы автоматизировать эту процедуру. Помогите пожалуйста.

Итак нижний колонтитул документа содержит 4-х значное число (####) после определенного буквенного кода которое не меняется (ХХХ-), меняется только цифры кода, это выглядит как (ХХХ - ####), кроме этого колонтитул содержит еще кое какую информацию. Мне нужно сохранить документ чтобы Имя документа было следующим: из нижнего колонититула был взят код (ХХХ - ####), добавил к нему

2

Re: Сохранение документа по имени из колонтитула

почему-то концовка не попала:

MaDriver пишет:

Мне нужно сохранить документ чтобы Имя документа было следующим: из нижнего колонититула был взят код (ХХХ - ####), добавил к нему

"Типовое имя" и текущую дату. Имя должно получится примерно таким: ХХХ - ####_"Типовое Имя"_дд.мм.гг. Спасибо за помощь.

3

Re: Сохранение документа по имени из колонтитула

MaDriver пишет:

почему-то концовка не попала:

MaDriver пишет:

Мне нужно сохранить документ чтобы Имя документа было следующим: из нижнего колонититула был взят код (ХХХ - ####), добавил к нему

"Типовое имя" и текущую дату. Имя должно получится примерно таким: ХХХ - ####_"Типовое Имя"_дд.мм.гг. Спасибо за помощь.

Вот попробуйте (стартовый макрос - SaveDocWithFooterText).
Возможно, вам потребуется изменить константы.
Конечно, можно увеличить или уменьшить число проверок из колонтитула.
Я использовал в примере нижний колонтитул.
Для верхнего колонтитула замените код на

footer_full = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text 

'-----------------------------------------------------------------------------

Sub SaveDocWithFooterText()
Dim w_str As String
Dim w_str_num As String
Dim l_w_str As Long
Dim l_pref As Long
Dim footer_full As String
Dim save_filename As String
'Constants may be altered bu user
Const const_pref As String = "XXX"
Const const_num_suffix As Long = 4
Const typified_name As String = "Typified Name" 'to be specified bu user

save_filename = const_pref
l_pref = Len(const_pref)
'Full footer contents
footer_full = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
w_str = Trim$(footer_full)
'Check prefix
If InStr(footer_full, const_pref) <> 1 Then
    MsgBox "Prefix '" & const_pref & "' is not found at the beginning of the footer"
    GoTo e_SDWF
Else
    l_w_str = Len(w_str)
    If l_w_str <= l_pref Then
        MsgBox "Only the prefix '" & const_pref & "' is found at the beginning of the footer"
        GoTo e_SDWF
    Else
        w_str = Mid$(w_str, l_pref + 1) & " "
        w_str_num = GetStrOfDefChars(w_str, " -", False)
        w_str = w_str_num
        w_str_num = GetStrOfDefChars(w_str, "0123456789", True)
        If Len(w_str_num) <> const_num_suffix Then
            MsgBox "The numeric part of the footer '" & w_str_num & "' does not contain exactly " & _
                    CStr(const_num_suffix) & " digits after the prefix"
            GoTo e_SDWF
        Else
            'Now the footer is verified as correct text. Form the file name for saving.
            save_filename = const_pref & " - " & w_str_num & _
                            "_" & typified_name & "_" & _
                            Format(Now(), "DD.MM.YY")
            'Here you can save the document with the produced file name (save_filename), for example:
            'ActiveDocument.SaveAs FileName:="C:\Temp\" & save_filename & ".docx", AddToRecentFiles:=False
        End If
    End If
End If
e_SDWF:
End Sub
Function GetStrOfDefChars(input_line As String, defchars As String, filt_flag As Boolean) As String
'Функция возвращает подстроку из левой части строки input_line.
'Состав подстроки зависит от состава строки defchars и флажка filt_flag:
'- если filt_flag = true,  то в выходную строку добавляются символы входной строки до тех пор,
'                          пока не встретится символ, отсутствующий в строке defchars
'- если filt_flag = false, то символы входной строки пропускаются до тех пор,
'                          пока не встретится символ, присутствующий в строке defchars
'                          (возвращается остаток строки от этого символа до конца input_line)
'ПРИМЕРЫ
' s = GetStrOfDefChars("123ght", "0123456789.", True)  '= в s значение "123"
' s = GetStrOfDefChars("., abc123ght", ":;., ", False) '= в s значение "abc123ght"
Dim ic As Long
Dim s_out As String
Dim nextchar As String

s_out = ""
If (filt_flag = True) Then
    For ic = 1 To Len(input_line)
        nextchar = Mid$(input_line, ic, 1)
        If InStr(defchars, nextchar) > 0 Then
            s_out = s_out & nextchar
        Else
            Exit For
        End If
    Next ic
Else
    For ic = 1 To Len(input_line)
        nextchar = Mid$(input_line, ic, 1)
        If InStr(defchars, nextchar) = 0 Then
            s_out = Mid$(input_line, ic)
            Exit For
        End If
    Next ic
End If
GetStrOfDefChars = s_out
End Function

4

Re: Сохранение документа по имени из колонтитула

Фигасе. А у меня скромненько

Sub ПереименоватьДок()
Dim oDoc As Document
Dim sName, sFullName, sText As String
Set oDoc = ActiveDocument
sName = oDoc.Name
sFullName = oDoc.FullName
sText = Finder()
If sText = "" Then Exit Sub
sText = sText & "_ТиповоеИмя_" & Date
ActiveDocument.SaveAs2 FileName:=Replace(sFullName, sName, sText & ".doc")
End Sub
Private Function Finder()
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
sFindStroka = "СТБ-[0-9]{4}"
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
  Do While .Execute(FindText:=sFindStroka, Forward:=True) = True
    If Not Selection.Range.Text = "" Then
    sPerem = Selection.Range.Text: Finder = sPerem
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument: Exit Function
    End If
  Loop
End With
MsgBox "Код документа не обнаружен!": Finder = ""
End Function
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

5

Re: Сохранение документа по имени из колонтитула

Только замените то, что в кавычках ("_ТиповоеИмя_" и "СТБ-[0-9]{4}") на свои значения. Как вам надобно. Ну и пробелы тоже смотрите.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

6

Re: Сохранение документа по имени из колонтитула

Fck_This пишет:

Только замените то, что в кавычках ("_ТиповоеИмя_" и "СТБ-[0-9]{4}") на свои значения. Как вам надобно. Ну и пробелы тоже смотрите.

Спасибо что откликнулись, если я правильно понял, то в тексте "СТБ-[0-9]{4}", первые три буквы нужно заменить на мои (пусть они останутся СТБ -), а далее берутся 4 цифры кода? Уточните пожалуйста потому-что пока не работает...( Мне нужно взять из колонтитула "СТБ - ####" Пока пишет код документа не обнаружен (

7

Re: Сохранение документа по имени из колонтитула

MaDriver пишет:
Fck_This пишет:

Только замените то, что в кавычках ("_ТиповоеИмя_" и "СТБ-[0-9]{4}") на свои значения. Как вам надобно. Ну и пробелы тоже смотрите.

Спасибо что откликнулись, если я правильно понял, то в тексте "СТБ-[0-9]{4}", первые три буквы нужно заменить на мои (пусть они останутся СТБ -), а далее берутся 4 цифры кода? Уточните пожалуйста потому-что пока не работает...( Мне нужно взять из колонтитула "СТБ - ####" Пока пишет код документа не обнаружен (

Проверьте как пишется ваш код. Там могут быть пробелы или между "СТБ" и "хххх" может быть другой символ (этих тире-дефисов целая куча). Для уверенности скиньте документ с образцом колонтитула. Это может быть пустой документ. Я посмотрю, что там за символы и скажу точно. Если у вас другие буквы - то необходимо заменить в коде на ваши. Может они в полях. В общем, наверняка сказать можно только имея на руках пример колонтитула.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

8

Re: Сохранение документа по имени из колонтитула

Fck_This пишет:
MaDriver пишет:
Fck_This пишет:

Только замените то, что в кавычках ("_ТиповоеИмя_" и "СТБ-[0-9]{4}") на свои значения. Как вам надобно. Ну и пробелы тоже смотрите.

Спасибо что откликнулись, если я правильно понял, то в тексте "СТБ-[0-9]{4}", первые три буквы нужно заменить на мои (пусть они останутся СТБ -), а далее берутся 4 цифры кода? Уточните пожалуйста потому-что пока не работает...( Мне нужно взять из колонтитула "СТБ - ####" Пока пишет код документа не обнаружен (

Проверьте как пишется ваш код. Там могут быть пробелы или между "СТБ" и "хххх" может быть другой символ (этих тире-дефисов целая куча). Для уверенности скиньте документ с образцом колонтитула. Это может быть пустой документ. Я посмотрю, что там за символы и скажу точно. Если у вас другие буквы - то необходимо заменить в коде на ваши. Может они в полях. В общем, наверняка сказать можно только имея на руках пример колонтитула.

Приложил документ. Причем в имя файла код нужно вставить без пробелов. Спасибо за участие!

Post's attachments

СТБ-1234_Типовое_Имя_Дата.docx 27.72 Кб, 3 скачиваний с 2017-04-07 

You don't have the permssions to download the attachments of this post.

9

Re: Сохранение документа по имени из колонтитула

Не стал разбираться как создавался колонтитул. Вот этот код вам поможет. Пробелы убрал.

Sub ПереименоватьДок()
Dim oDoc As Document
Dim sName, sFullName, sText As String
Dim iInstr As Integer
Set oDoc = ActiveDocument
sName = oDoc.Name
sFullName = oDoc.FullName
For i = 1 To oDoc.Sections(1).Footers.Count
sText = oDoc.Sections(1).Footers(i).Range.Text
iInstr = InStr(sText, "СТБ " & Chr(150) & Chr(32))
If iInstr >= 1 Then
    sText = Mid(sText, iInstr, 10): GoTo RenameLine
End If
Next i
RenameLine:
If sText = "" Then MsgBox "Текст не обнаружен": Exit Sub
sText = Replace(sText, Chr(32), "") & "_ТиповоеИмя_" & Date
ActiveDocument.SaveAs2 FileName:=Replace(sFullName, sName, sText & ".doc")
End Sub
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

10

Re: Сохранение документа по имени из колонтитула

Вот мой вариант для функции Finder. Используется тот факт, что весь искомый текст в нижнем колонтитуле расположен между символами табуляции

Private Function Finder()
    Dim sPerem As String, mystr As String, arr$()
    sPerem = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
    arr = Split(sPerem, vbTab)
    mystr = Replace(arr(1) & "_" & Date, " ", "")
    If Len(mystr) > 0 Then
        Finder = mystr
    Else
        Finder = ""
        MsgBox "Код документа не обнаружен!"
    End If
End Function

11

Re: Сохранение документа по имени из колонтитула

Boris_R пишет:

Вот мой вариант для функции Finder. Используется тот факт, что весь искомый текст в нижнем колонтитуле расположен между символами табуляции

Private Function Finder()
    Dim sPerem As String, mystr As String, arr$()
    sPerem = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text
    arr = Split(sPerem, vbTab)
    mystr = Replace(arr(1) & "_" & Date, " ", "")
    If Len(mystr) > 0 Then
        Finder = mystr
    Else
        Finder = ""
        MsgBox "Код документа не обнаружен!"
    End If
End Function

Хороший вариант, попробую применить