Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 12.05.2018, 23:44   #11
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

А если сам номер исходящего поместить в некое поле, с которого макрос сможет считать инфо и подставить к названию файла?
Тут не важно в начале или в конце, главное подсказать макросу от куда именно взять информацию
Mix100 вне форума Ответить с цитированием
Старый 14.05.2018, 20:16   #12
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

Кто то может макрос подправить. На этапе перезаписывания файла, когда спрашивают и вводишь новое имя, то ошибка возникает (стоит офис 2010)
В макросе стоит мой путь сохранения D:\YandexDisk\1C Счета и договора\
Код:
Sub Word_ExportPDF()
'https://www.thespreadsheetguru.com/the-code-vault/microsoft-word-vba-to-save-document-as-a-pdf-in-same-folder
'PURPOSE: Generate A PDF Document From Current Word Document
'NOTES: PDF Will Be Saved To Same Folder As Word Document File
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean

UniqueName = False

'Store Information About Word File
'Сохранить информацию о файле Word
  myPath = ActiveDocument.FullName
  'CurrentFolder = ActiveDocument.Path & "\"  'Сохранить файл pdf там же где и doc
  CurrentFolder = "D:\YandexDisk\1C Счета и договора\"  'Сохранить файл pdf по пути..
  FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

'Does File Already Exist?
'Уже существует ли файл?
  Do While UniqueName = False
    DirFile = CurrentFolder & FileName & ".pdf"
    If Len(Dir(DirFile)) <> 0 Then
      UserAnswer = MsgBox("Файл уже существует. Нажмите " & _
       "[Yes] что бы перезаписать. Нажмите [No] что бы переименовать.", vbYesNoCancel)
      
      If UserAnswer = vbYes Then
        UniqueName = True
      ElseIf UserAnswer = vbNo Then
        Do
          'Retrieve New File Name
          'Получить новое имя файла
            FileName = InputBox("Укажите новое имя файла " & _
             "(спросит снова, если вы указали недопустимое имя файла)", _
             "Введите имя файла", FileName)
          
          'Exit if User Wants To
          'Выход, если пользователь хочет
            If FileName = "False" Or FileName = "" Then Exit Sub
        Loop While ValidFileName(FileName) = False
      Else
        Exit Sub 'Cancel
      End If
    Else
      UniqueName = True
    End If
  Loop
  
'Save As PDF Document
'Сохранить как документ в формате PDF
  On Error GoTo ProblemSaving
    ActiveDocument.ExportAsFixedFormat _
     OutputFileName:=CurrentFolder & FileName & ".pdf", _
     ExportFormat:=wdExportFormatPDF
  On Error GoTo 0

'Confirm Save To User
'Подтвердить Сохранить пользователю
  With ActiveDocument
    FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
  End With
  
  'MsgBox "PDF Saved in the Folder: " & FolderName
  MsgBox "Файл pdf создан в указанную папку"

Exit Sub

'Error Handlers
ProblemSaving:
  'MsgBox "There was a problem saving your PDF. This is most commonly caused" & _
   " by the original PDF file already being open."
  MsgBox "Не удалось скопировать"
  Exit Sub


End Sub
Function ValidFileName(FileName As String) As Boolean
'PURPOSE: Determine If A Given Word Document File Name Is Valid
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim TempPath As String
Dim doc As Document

'Determine Folder Where Temporary Files Are Stored
  TempPath = Environ("TEMP")

'Create a Temporary XLS file (XLS in case there are macros)
  On Error GoTo InvalidFileName
    Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
     "\" & FileName & ".doc", wdFormatDocument)
  On Error Resume Next

'Delete Temp File
  Kill doc.FullName

'File Name is Valid
  ValidFileName = True

Exit Function

'ERROR HANDLERS
InvalidFileName:
'File Name is Invalid
  ValidFileName = False

End Function
Mix100 вне форума Ответить с цитированием
Старый 18.05.2018, 15:48   #13
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

судя по всему Вы код брали тут - https://www.thespreadsheetguru.com/t...cel-worksheets

простите, а откуда взялась "2" (двойка) вот здесь?

Цитата:
Сообщение от Mix100 Посмотреть сообщение
Код:
Set doc = ActiveDocument.SaveAs2(ActiveDocument.TempPath & _
     "\" & FileName & ".doc", wdFormatDocument)
Serge_Bliznykov вне форума Ответить с цитированием
Старый 18.05.2018, 16:07   #14
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

как вариант предлагаю такой код:
Код:
Option Explicit

Sub Word_ExportPDF()
'https://www.thespreadsheetguru.com/the-code-vault/microsoft-word-vba-to-save-document-as-a-pdf-in-same-folder
'PURPOSE: Generate A PDF Document From Current Word Document
'NOTES: PDF Will Be Saved To Same Folder As Word Document File
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim CurrentFolder As String, DirFile As String, FolderName As String
Dim FileName As String
Dim myPath As String
Dim UniqueName As Boolean
Dim UserAnswer As Integer

UniqueName = False

'Store Information About Word File
'Сохранить информацию о файле Word
  myPath = ActiveDocument.FullName
  'CurrentFolder = ActiveDocument.Path & "\"  'Сохранить файл pdf там же где и doc
  CurrentFolder = "D:\YandexDisk\1C Счета и договора\"  'Сохранить файл pdf по пути..
  FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

'Does File Already Exist?
'Уже существует ли файл?
  Do While UniqueName = False
    DirFile = CurrentFolder & FileName & ".pdf"
    If Len(Dir(DirFile)) <> 0 Then
      UserAnswer = MsgBox("Файл уже существует. Нажмите " & _
       "[Yes] что бы перезаписать. Нажмите [No] что бы переименовать.", vbYesNoCancel)
      
      If UserAnswer = vbYes Then
        UniqueName = True
      ElseIf UserAnswer = vbNo Then
        Do
          'Retrieve New File Name
          'Получить новое имя файла
            FileName = InputBox("Укажите новое имя файла " & _
             "(спросит снова, если вы указали недопустимое имя файла)", _
             "Введите имя файла", FileName)
          
          'Exit if User Wants To
          'Выход, если пользователь хочет
            If FileName = "False" Or FileName = "" Then Exit Sub
        Loop While IsValidFileName(FileName) = False
      Else
        Exit Sub 'Cancel
      End If
    Else
      UniqueName = True
    End If
  Loop
  
'Save As PDF Document
'Сохранить как документ в формате PDF
  On Error GoTo ProblemSaving
    ActiveDocument.ExportAsFixedFormat _
     OutputFileName:=CurrentFolder & FileName & ".pdf", _
     ExportFormat:=wdExportFormatPDF
  On Error GoTo 0

'Confirm Save To User
'Подтвердить Сохранить пользователю
  With ActiveDocument
    FolderName = Mid(.Path, InStrRev(.Path, "\") + 1, Len(.Path) - InStrRev(.Path, "\"))
  End With
  
  'MsgBox "PDF Saved in the Folder: " & FolderName
  MsgBox "Файл " & FileName & ".pdf создан в указанную папку"

Exit Sub

'Error Handlers
ProblemSaving:
  'MsgBox "There was a problem saving your PDF. This is most commonly caused" & _
   " by the original PDF file already being open."
  MsgBox "Не удалось скопировать"
  Exit Sub


End Sub

Function IsValidFileName(sFileName As String) As Boolean
    Dim lstIllegal As Variant
    Dim i As Long
    Dim result As Boolean
    
    lstIllegal = Array("/", "\", ":", "*", "?", "<", ">", "|", """")
    result = True
    
    For i = LBound(lstIllegal) To UBound(lstIllegal)
        If InStr(1, sFileName, lstIllegal(i)) > 0 Then
            result = False
            Exit Function
        End If
    Next i
    IsValidFileName = result
End Function
Serge_Bliznykov вне форума Ответить с цитированием
Старый 18.05.2018, 18:04   #15
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

Serge_Bliznykov, огромное спасибо все работает
Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
как вариант предлагаю такой код:
Mix100 вне форума Ответить с цитированием
Старый 18.05.2018, 18:18   #16
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

Иду вабанк )
1. Как к самому названию файла
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

прицепить дату "DDMMYYYY"

2. Как заставить макросом не спрашивать о перезаписи http://prntscr.com/jjl12f, а сразу выдать окно с вводом нового названия. Хочу убрать лишнее действие

3. И открыть папку с сохраненным файлом (нужно что бы отправить его по почте)
Ве енд.

Последний раз редактировалось Mix100; 18.05.2018 в 18:26.
Mix100 вне форума Ответить с цитированием
Старый 19.05.2018, 01:32   #17
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

Цитата:
Сообщение от Mix100 Посмотреть сообщение
1. Как к самому названию файла
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)

прицепить дату "DDMMYYYY"
попробуйте так:
Код:
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1) &  Format(Now(), "DDMMYYYY")
внимание. код не проверял!



Цитата:
Сообщение от Mix100 Посмотреть сообщение
2. Как заставить макросом не спрашивать о перезаписи http://prntscr.com/jjl12f, а сразу выдать окно с вводом нового названия. Хочу убрать лишнее действие
очевидно, нужно убрать

Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
UserAnswer = MsgBox("Файл уже существует. Нажмите " & _
"[Yes] что бы перезаписать. Нажмите [No] что бы переименовать.", vbYesNoCancel)
чтобы не переписывать логику, можете это заменить на
Код:
UserAnswer = vbNo

Цитата:
Сообщение от Mix100 Посмотреть сообщение
3. И открыть папку с сохраненным файлом (нужно что бы отправить его по почте)
попробуйте что-то вроде:
Код:
Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus
внимание. код не проверял!
Serge_Bliznykov вне форума Ответить с цитированием
Старый 21.05.2018, 13:21   #18
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

Открытие папки
Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus
Код добавил в конце фукции, открывает просто проводник, а нужно именно папку с сохраненным файлом (путь в макросе есть).

Последний раз редактировалось Mix100; 21.05.2018 в 15:47.
Mix100 вне форума Ответить с цитированием
Старый 21.05.2018, 15:45   #19
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,238
По умолчанию

Цитата:
Сообщение от Mix100 Посмотреть сообщение
Работает, но получается слитно название и дата, типа КП от Фирмы21052018.pdf
- Тут необходимо добавить пробел перед датой
- Сразу же как урок для меня, как добавить текст в конце даты (например префикс буду ставить, что бы КП не повторялись и не перезаписывались в один день. Можно конечно добавить время, но префикс симпатичней и иерархия логична
так. понятно.
Вам нужно просто пояснить, как формируются строчки на VBA, тогда таких вопросов не будет.
знак & - означает конкатенацию (слияние) строк.

Код:
mypath = "aa"
ss = mypath & "bb"
в переменной ss будет "aabb"
если мы хотим в середину переменной вставить дату, тогда

Код:
ss = mypath & Format(Now(), "DDMMYYYY") & "bb"
в переменной ss будет "aa21052018bb"

если нужно добавить пробел перед датой, то так и запишем
Код:
ss = mypath & " " & Format(Now(), "DDMMYYYY") & "bb"
в переменной ss будет "aa 21052018bb"


в коде пробел вставим так:
Код:
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
   InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1) & " " & Format(Now(), "DDMMYYYY") 'к названию подставлена дата
Так понятней?


а строчку с Shell "EXPLORER.EXE" .... Вы вставили не туда!

попробуйте вставить сюда:
Код:
  'MsgBox "PDF Saved in the Folder: " & FolderName
  MsgBox "Файл " & FileName & ".pdf создан в указанную папку"

  Shell "EXPLORER.EXE" & " " & Chr(34) & CurrentFolder & Chr(34), vbNormalFocus
Serge_Bliznykov вне форума Ответить с цитированием
Старый 21.05.2018, 16:17   #20
Mix100
Пользователь
 
Регистрация: 28.03.2016
Сообщений: 12
По умолчанию

Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
ss = mypath & " " & Format(Now(), "DDMMYYYY") & "bb"
Спасибо, теперь понятно.
Я пошел своим кривым путем и сделал так ) "_DD.MM.YYYY_1"


Цитата:
Сообщение от Serge_Bliznykov Посмотреть сообщение
а строчку с Shell "EXPLORER.EXE" .... Вы вставили не туда!
попробуйте вставить сюда:
Тоже, решил другим кривым путем, в конце функции добавил код:
'Dim Path
'Path = "D:\YandexDisk\1C Счета и договора\"
'Shell "cmd /c start """" explorer.exe " & Path, vbHide

Понятно, что все это эксперимент, Ваше подсказки проще и логичнее. С кодом пока все. Вам Serge_Bliznykov огромное спасибо. Надеюсь всем пригодиться этот код, кто отсылает большое количество КП.
Mix100 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
C, печать матрицы в файл с прочитанным названием Bombiman Помощь студентам 6 08.01.2016 14:22
как сохранить байтовый массив в pdf файл? dima1257 C# (си шарп) 5 14.01.2014 14:25
Программно сохранить всю книгу в один файл PDF uralshans Microsoft Office Excel 16 22.09.2013 15:16
Сохранить с нужным именем maikoms Microsoft Office Excel 4 20.03.2009 11:44
Выгрузка в файл с динамическим названием. Квэнди БД в Delphi 0 24.06.2007 15:39