1 Тема от jhgffd

  • jhgffd
  • рядовой
  • Неактивен
  • Зарегистрирован: 28.08.2016
  • Сообщений: 3

Тема: Макрос, добавляющий в название 1-ю строку текста при сохранении

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

Sub Макрос1()
'
' Макрос1 Макрос
'
'
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        "C:\Users\roman\Desktop\11111111 - копия.pdf", ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
End Sub

2 Ответ от Fck_This

  • Макрос, добавляющий в название 1-ю строку текста при сохранении
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97

Re: Макрос, добавляющий в название 1-ю строку текста при сохранении

Если вы создаёте новый файл, т.е. просто открываете приложение МС ворд и вставляете туда текст, то у вас и так именем файла при "сохранить как" будет первые несколько слов документа.

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

3 Ответ от Fck_This

  • Макрос, добавляющий в название 1-ю строку текста при сохранении
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97

Re: Макрос, добавляющий в название 1-ю строку текста при сохранении

Fck_This пишет:

Если вы создаёте новый файл, т.е. просто открываете приложение МС ворд и вставляете туда текст, то у вас и так именем файла при "сохранить как" будет первые несколько слов документа.

Вам может помочь:

Sub ПримерИспользования()
    txt = ClipboardText
    MsgBox txt, vbInformation, "Содержимое буфера обмена Windows"
End Sub
 
Function ClipboardText() ' чтение из буфера обмена
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        ClipboardText = .GetText
    End With
End Function
 
Sub SetClipboardText(ByVal txt$) ' запись в буфер обмена
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText txt$
        .PutInClipboard
    End With
End Sub

И вот эта темка "внешняя ссылка"

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

4 Ответ от jhgffd

  • jhgffd
  • рядовой
  • Неактивен
  • Зарегистрирован: 28.08.2016
  • Сообщений: 3

Re: Макрос, добавляющий в название 1-ю строку текста при сохранении

Fck_This пишет:

Если вы создаёте новый файл, т.е. просто открываете приложение МС ворд и вставляете туда текст, то у вас и так именем файла при "сохранить как" будет первые несколько слов документа.

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

5 Ответ от Fck_This

  • Макрос, добавляющий в название 1-ю строку текста при сохранении
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97
  • За сообщение: 1

Re: Макрос, добавляющий в название 1-ю строку текста при сохранении

jhgffd пишет:
Fck_This пишет:

Если вы создаёте новый файл, т.е. просто открываете приложение МС ворд и вставляете туда текст, то у вас и так именем файла при "сохранить как" будет первые несколько слов документа.

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

Короч, держите. Обработал на примере 3-ёх знаков недопустимых в имени файла - вы добавьте ещё аналогичные процедуры ещё хотя бы для следующих 6 символов: \  /  "  *  <  >. Также указывайте необходимое вам расширение - у меня это ".docx", директорию я уже указал вашу и ещё свои параметры сохранения добавляйте.  big_smile 

Sub ИмяФайла()
'При ошибке - делать дальше
On Error Resume Next
'Задаём область: (начало первого предложения - конец первого предложения)
myDocname = ActiveDocument.Range(Start:=ActiveDocument.Sentences(1).Start, End:=ActiveDocument.Sentences(1).End)
'Задаём константы
Const simba = "."
Const pumba = ":"
Const timon = "|"
'Сравниваем раз
    pos = InStr(1, myDocname, simba)
    If pos > 0 Then 'Если точка обнаружена
    myDocname = Left(myDocname, pos - 1) 'Область до точки освобождается от точки
    myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
    ActiveDocument.SaveAs2 FileName:=myDocname
    Else: MsgBox "фига лысого simba"
    End If
'Сравниваем два
        pod = InStr(1, myDocname, pumba)
        If pod > 0 Then 'Если двоеточие обнаружено
        myDocname = Left(myDocname, pod - 1) 'Область до двоеточия освобождается от двоеточия
        myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
        ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
        ActiveDocument.SaveAs2 FileName:=myDocname
        Else: MsgBox "фига лысого pumba"
        End If
'Сравниваем три
    por = InStr(1, myDocname, timon)
    If por > 0 Then 'Если вертикальная черта обнаружена
    myDocname = Left(myDocname, por - 1) 'Область до вертикальной черты освобождается от вертикальной черты
    myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
    ActiveDocument.SaveAs2 FileName:=myDocname
    Else: MsgBox "фига лысого timon"
    End If
End Sub
Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

6 Ответ от jhgffd

  • jhgffd
  • рядовой
  • Неактивен
  • Зарегистрирован: 28.08.2016
  • Сообщений: 3

Re: Макрос, добавляющий в название 1-ю строку текста при сохранении

Fck_This пишет:

Короч, держите. Обработал на примере 3-ёх знаков недопустимых в имени файла - вы добавьте ещё аналогичные процедуры ещё хотя бы для следующих 6 символов: \  /  "  *  <  >. Также указывайте необходимое вам расширение - у меня это ".docx", директорию я уже указал вашу и ещё свои параметры сохранения добавляйте.  big_smile 

Sub ИмяФайла()
'При ошибке - делать дальше
On Error Resume Next
'Задаём область: (начало первого предложения - конец первого предложения)
myDocname = ActiveDocument.Range(Start:=ActiveDocument.Sentences(1).Start, End:=ActiveDocument.Sentences(1).End)
'Задаём константы
Const simba = "."
Const pumba = ":"
Const timon = "|"
'Сравниваем раз
    pos = InStr(1, myDocname, simba)
    If pos > 0 Then 'Если точка обнаружена
    myDocname = Left(myDocname, pos - 1) 'Область до точки освобождается от точки
    myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
    ActiveDocument.SaveAs2 FileName:=myDocname
    Else: MsgBox "фига лысого simba"
    End If
'Сравниваем два
        pod = InStr(1, myDocname, pumba)
        If pod > 0 Then 'Если двоеточие обнаружено
        myDocname = Left(myDocname, pod - 1) 'Область до двоеточия освобождается от двоеточия
        myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
        ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
        ActiveDocument.SaveAs2 FileName:=myDocname
        Else: MsgBox "фига лысого pumba"
        End If
'Сравниваем три
    por = InStr(1, myDocname, timon)
    If por > 0 Then 'Если вертикальная черта обнаружена
    myDocname = Left(myDocname, por - 1) 'Область до вертикальной черты освобождается от вертикальной черты
    myDocname = myDocname & ".docx" 'Добавляем расширение без поддержки макроса
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
    ActiveDocument.SaveAs2 FileName:=myDocname
    Else: MsgBox "фига лысого timon"
    End If
End Sub

Отлично, даже лучше, чем я мог представить!
Вот немного ваш макрос переделал под pdf:

Sub ИмяФайла()
Selection.PasteAndFormat (wdFormatOriginalFormatting)
'При ошибке - делать дальше
On Error Resume Next
'Задаём область: (начало первого предложения - конец первого предложения)
myDocname = ActiveDocument.Range(Start:=ActiveDocument.Sentences(1).Start, End:=ActiveDocument.Sentences(1).End)
'Задаём константы
 Const simba = "."
'Сравниваем раз
    pos = InStr(1, myDocname, simba)
    If pos > 0 Then 'Если точка обнаружена
    myDocname = Left(myDocname, pos - 1) 'Область до точки освобождается от точки
    myDocname = myDocname & ".pdf" 'Добавляем расширение без поддержки макроса
    ChangeFileOpenDirectory "C:\Users\roman\Desktop\"
    ActiveDocument.ExportAsFixedFormat OutputFileName:=myDocname, ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    Else: MsgBox "фига лысого simba"
    End If
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
End Sub

Осталось остальные символы добавить  big_smile
Большое спасибо!