Страницы: 1 2 След.
RSS
Как создать PDF файл с именем по условию
 
Здравствуйте уважаемые форумчане,  
 
Подскажите пожалуйста, как дополнить макрос?  
 
На листе создал кнопку „Создать PDF“ при нажатии на которую создается pdf файл области печати, с названием файла  „INVOICE_дата_сегодня“ и сохраняется в C:\  
 
Sub INVOICE_PDF()  
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _  
   Filename:="C:\" & "INVOICE_" & Worksheets("INVOICE").Range("D3") & "_" & Date & ".pdf", _  
   Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _  
   OpenAfterPublish:=True  
End Sub  
 
В итоге получается такой файл: INVOICE__16.04.2011.pdf  
 
Как добавить в макрос, чтоб в название файла добавлялась фамилия и имя клиента из ячейки B7 (например IVANOV VASILI) ?  
которое написано с пробелом или только фамилия например?  
 
Т.е. необходимо создать файл с названием:  2011.04.16_INVOICE__IVANOV_VASILI.pdf  
 
И еще небольшое но…!    
Если в имени или фамилии встречаются буквы üõöä, то они заменяются на соответственно:  
 
Ü – Y  
Õ – O  
Ö – O  
Ä - A  
 
Помогите пожалуйста!
 
Буквы для замены:
 
Вот строка, где формируется имя файла:  
Filename:="C:\" & "INVOICE_" & Worksheets("INVOICE").Range("D3") & "_" & Date & ".pdf", _  
Попробуйте в таком варианте:  
Filename:="C:\" & format(date,"yyyy.mm.dd") & "_INVOICE_" & Worksheets("INVOICE").Range("B7") & ".pdf", _
 
Что касается замены букв. Я поэкспериментировал на своей системе (Win2k rus + Office2k rus) и вот что выяснил (сохранять в PDF Office2k не умеет, поэтому я просто сохранял книгу):  
1. использовать такие буквы при сохранении вообще не получается - "Недопустимое имя".  
2. если сохранить книгу под временным именем, а потом переименовать командой VBA  
Name <OldName> As <NewName>  
, ошибка не возникает, но буквы с умляутами заменяются на обычные.  
3. Если переименовать файл с помощью FileSystemObject, умляуты сохраняются.  
 
Попробуйте так:  
 
Sub INVOICE_PDF_1()  
Dim sTempName$, sActualName$  
sActualName = Format(Date, "yyyy.mm.dd") & "_INVOICE_" & Worksheets("INVOICE").Range("B7") & ".pdf"  
sTempName = "c:\" & Format(Date, "yyyy.mm.dd_hhmmss") & ".pdf"  
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _  
Filename:=sTempName, _  
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _  
OpenAfterPublish:=False  
With CreateObject("Scripting.FileSystemObject").GetFile(sTempName)  
   .Name = sActualName  
End With  
End Sub  
 
Проверить по указанной выше причине не могу.
 
Леш, мой 2003 не понимает:  
ExportAsFixedFormat
Я сам - дурнее всякого примера! ...
 
Спасибо! буду пробывать!
 
Вот, когда-то писал специально для чтения зябликов с этого сайта:  
Public Function TransNumberASC(S$) As String  
   Dim a, i%  
   a = Split(S, ";")  
   For i = 0 To UBound(a) - 1  
       a(i) = Chr(CInt(Right(a(i), 3)))  
   Next  
   TransNumberASC = Join(a, "")  
End Function  
 
92211
Я сам - дурнее всякого примера! ...
 
{quote}{login=Казанский}{date=17.04.2011 02:49}{thema=}{post}Что касается замены букв. Я поэкспериментировал на своей системе (Win2k rus + Office2k rus) и вот что выяснил (сохранять в PDF Office2k не умеет, поэтому я просто сохранял книгу):  
1. использовать такие буквы при сохранении вообще не получается - "Недопустимое имя".  
2. если сохранить книгу под временным именем, а потом переименовать командой VBA  
Name <OldName> As <NewName>  
, ошибка не возникает, но буквы с умляутами заменяются на обычные.  
3. Если переименовать файл с помощью FileSystemObject, умляуты сохраняются.  
 
Попробуйте так:  
 
Sub INVOICE_PDF_1()  
Dim sTempName$, sActualName$  
sActualName = Format(Date, "yyyy.mm.dd") & "_INVOICE_" & Worksheets("INVOICE").Range("B7") & ".pdf"  
sTempName = "c:\" & Format(Date, "yyyy.mm.dd_hhmmss") & ".pdf"  
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _  
Filename:=sTempName, _  
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _  
OpenAfterPublish:=False  
With CreateObject("Scripting.FileSystemObject").GetFile(sTempName)  
   .Name = sActualName  
End With  
End Sub  
 
Проверить по указанной выше причине не могу.{/post}{/quote}  
 
вот такой файл получился - (см JPG), проблема в том, что у нас в Эстонии у каждого 2-го фамилия или имя включает такие буквы, и если файл сохранить с таким именем, то у некоторых этот файл нехочет открываться (необходимо клиенту просто переименовать, но многие сразу паникуют...типа не работает...)
 
{quote}{login=KukLP}{date=17.04.2011 03:25}{thema=}{post}Вот, когда-то писал специально для чтения зябликов с этого сайта:  
Public Function TransNumberASC(S$) As String  
   Dim a, i%  
   a = Split(S, ";")  
   For i = 0 To UBound(a) - 1  
       a(i) = Chr(CInt(Right(a(i), 3)))  
   Next  
   TransNumberASC = Join(a, "")  
End Function  
 
92211{/post}{/quote}  
 
Поясните пожалуйста на понятном языке, что делает этот макрос?
 
Куда то пропал пост с зябликами. Ну ладно. В файле пример
Я сам - дурнее всякого примера! ...
 
{quote}{login=KukLP}{date=17.04.2011 07:03}{thema=}{post}Куда то пропал пост с зябликами.{/post}{/quote}  
А если напрячься и поднять голову к 15:25? :-)
 
А чо, Серёга, прикольно. Работает. Только в выложенном тобой примере ссылки на UDF, размещённую в ТВОЁМ PERSONAL.XLS :) Но после коррекции всё работает.  
 
А ты случаем также "ракозябры" при копировании из Висты кириллицы также макросом раскракозябривать не научился?  
Ну, типа, расшифровать фразу: Ýòà äîëáàíàÿ Vista êðàêîçÿáðèò êèðèëëèöó ?
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Во, блин, те кракозябры, которые выводятся на экран в окне ввода ответа, сервером форума конвертируются в посте в то, что Серёга умеет декодировать...  
Попытка № 2:  
'Ýòà äîëáàíàÿ Vista êðàêîçÿáðèò êèðèëëèöó
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
"Victa" конвертируется в "Vista"?  
круто.  
AI und fuzzy logic, не иначе :)
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
Да ладно... Очепятался сначала, а потом поправил...    
Но Серёгин макрос нужно будет покрутить. Может, что-нибудь и получится пригодное для того чтобы мочь прочесть закракозябренный текст в постах.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
LV112  
> вот такой файл получился - (см JPG)  
Так получилось как надо, или нет?  
 
KukLP  
> Леш, мой 2003 не понимает: ExportAsFixedFormat  
Мой 2000 тоже, для экспериментов я использовал  
activeworkbook.saveas ...  
activeworkbook.close  
потом переименование тем или другим способом.  
Макрос, разумеется, находился в другой книге.
 
Чуть покрутил ЮДФ-ку Сергея.  
Получил такую работающую:  
Function TransNumberASC(S$) As String  
   Dim Arr, i%  
   S = Replace(S, "&#", ";&#")  
   S = Replace(S, ";;", ";")  
   Arr = Split(S, ";")  
   On Error Resume Next  
   For i = 0 To UBound(Arr) - 1  
       If Left(Arr(i), 2) = "&#" And Len(Arr(i)) = 5 And IsNumeric(Right(Arr(i), 3)) Then  
           Arr(i) = Chr(CInt(Right(Arr(i), 3)))  
       End If  
   Next  
   TransNumberASC = Join(Arr, "")  
End Function  
 
Уверенно переводит искалеченный Вистой кириллический текст в постах. Но что-то мне не нравится... Наверное, можно было бы и как-то сократить.
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Чуть короче:  
Function TransNumberASC(S$) As String  
   Dim Arr, i%  
   Arr = Split(Replace(Replace(S, "&#", ";&#"), ";;", ";"), ";")  
   On Error Resume Next  
   For i = 0 To UBound(Arr) - 1  
       If Left(Arr(i), 2) = "&#" And Len(Arr(i)) = 5 And IsNumeric(Right(Arr(i), 3)) Then  
           Arr(i) = Chr(CInt(Right(Arr(i), 3)))  
       End If  
   Next  
   TransNumberASC = Join(Arr, "")  
End Function
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
{quote}{login=Казанский}{date=17.04.2011 08:24}{thema=}{post}LV112  
> вот такой файл получился - (см JPG)  
Так получилось как надо, или нет?  
{/post}{/quote}  
 
если посмотреть на название файла (jpg  смотри выше) последняя буква и есть "кракозябля" которую надо заменить на "U"  
 
2011.04.17_INVOICE_IVANOV OÜ -сейчас,  
а надо на выходе  
2011.04.17_INVOICE_IVANOV_OU
 
Лёш,  
я тут тоже "покрутил" и создал VB скрипт, который берет текст из буфера обмена и выводит сообщение с исправленным текстом. Вот его содержимое:  
 
Dim s, s1, v, i, x  
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  
   'MSForms.dataobject, http://www.sql.ru/forum/actualthread.aspx?tid=501769&pg=1  
   .GetFromClipboard  
   s = .GetText  
End With  
With CreateObject("vbscript.regexp")  
   .Global = True  
   .Pattern = "(&#\d\d\d;)"  
   Set v = .Execute(s)  
End With  
For Each x In v  
  s1 = s1 & Mid(s, i + 1, x.FirstIndex - i) & Chr(CLng(Mid(x, 3, 3)))  
  i = x.FirstIndex + x.Length  
Next  
s1 = s1 & Mid(s, i + 1)  
MsgBox s1  
 
Можно поместить ярлык на этот скрипт на раб. стол или в Главное меню и назначить клавишу быстрого вызова (я попробовал Ctrl+Alt+D). Тогда его можно вызывать этим сочетанием клавиш в любое время после копирования текста с кракозябрами. См. скриншот с примером работы:  
 
PS С RegExp я перемудрил, теперь вижу, что можно без него.
 
{quote}{login=Юрий М}{date=17.04.2011 07:07}{thema=Re: }{post}{quote}{login=KukLP}{date=17.04.2011 07:03}{thema=}{post}Куда то пропал пост с зябликами.{/post}{/quote}  
А если напрячься и поднять голову к 15:25? :-){/post}{/quote}Юр, да я имел ввиду не свой пост, а типа Лешиного от 17.04.2011, 19:45. Ну ерунда, главное - меня поняли. Интернет падал, поэтому я с задержкой(не думайте, что я тупой - просто медленно думаю:-)).
Я сам - дурнее всякого примера! ...
 
Мне Prist делал подобную функцию, а сейчас не могу найти у себя...
 
{quote}{login=Alex_ST}{date=17.04.2011 08:19}{thema=}{post}Да ладно... Очепятался сначала, а потом поправил...    
Но Серёгин макрос нужно будет покрутить. Может, что-нибудь и получится пригодное для того чтобы мочь прочесть закракозябренный текст в постах.{/post}{/quote}Леш, на самом деле меня на эти потуги навел пост Юры(в какой-то теме). И началось все с моего поста в твоей теме "вопросы по работе форума", за что я был благополучно выруган Юрой. Справедливо, или нет - решать самому Юре(так и не удалил мои посты, о которых я просил). Ну откуда мне было знать, что зяблики вставляются и в Блокнот, например. У меня изначально все корректно работало. И пришлось попотеть над реестром, чтоб смоделировать ситуацию зябликов от меня на сайт. Ну ладно, это все лирика. А по физике я рад, что мои попытки пригодились.  
 
П.С. похоже у моего провайдера в привычку входит валить интернет. Появится связь - отправлю.
Я сам - дурнее всякого примера! ...
 
Здесь на Планете хорошо хоть скопированная из Висты фраза с кириллицей вставляется так, что можно потом её разделить по символам, ориентируясь на разделители ";&#"  
А вот на других форумах (например, в Миру у Сержа) это вставляется в пост так же, как здесь выглядит в окне ввода.  
Это здесь не отобразится, но посмотреть образец можно на: http://www.excelworld.ru/forum/2-419-1  
 
При этом никаких разделителей не видно, а все символы после вставки в Ёксель имеют одинаковый КОДСИМВ() = 63 ...
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
{quote}{login=Казанский}{date=17.04.2011 10:16}{thema=}{post}… я тут тоже "покрутил" и создал VB скрипт, который берет текст из буфера обмена и выводит сообщение с исправленным текстом …  
… PS С RegExp я перемудрил, теперь вижу, что можно без него.{/post}{/quote}  
 
Алексей,  
отличная идея. Проверил. Скрипт здорово работает.  
Только вот 2 вопросика-просьбы:  
1. Я с RegExp вообще никак (надо учиться, конечно, но некогда). так ты уж дополируй, пожалуйста, как имел в виду в своём PS  
2. А нельзя ли то же самое, что выводится в MsgBox, ещё и в сам буфер обмена как-то засовывать чтобы "раскракозябренный" скриптом текст можно было куда-то вставить из него?
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
Пытаюсь сам разобраться. Не получается кроме вывода MsgBox ещё и копировать в буфер обмена:  
  Dim s, s1, v, i, x  
  With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  
     .GetFromClipboard: s = .GetText   ' получить значение из буфера обмена  
     With CreateObject("VBScript.RegExp")  
        .Global = True  
        .Pattern = "(&#\d\d\d;)"  
        Set v = .Execute(s)  
     End With  
     For Each x In v  
        s1 = s1 & Mid(s, i + 1, x.FirstIndex - i) & Chr(CLng(Mid(x, 3, 3)))  
        i = x.FirstIndex + x.Length  
     Next  
     s1 = s1 & Mid(s, i + 1)  
     '.SetText s1: .PutInClipboard ' добавить значение в буфер обмена  
  End With  
  MsgBox s1  
Если раскомментировать добавление в буфер, то вылетает по ошибке...
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
LV112  
Так Вам НАДО заменять умляуты на обычные буквы?! Я-то наоборот старался их сохранить.  
Добавьте в начало модуля следующий код:  
 
Const CODES_TO_REPLACE = "220 213 214 196 252 245 246 228" 'unicode-коды спец. букв  
Const LETTERS = "Y O O A y o o a" 'буквы для замены  
 
Function Est2Eng(ByVal s As String) As String  
Dim i&, cds$(), ltrs$()  
cds = Split(CODES_TO_REPLACE)  
ltrs = Split(LETTERS)  
For i = 0 To UBound(cds)  
   s = Replace$(s, ChrW$(CLng(cds(i))), ltrs(i))  
Next  
Est2Eng = s  
End Function  
 
Используйте функцию для подстановки букв в своем исходном макросе:  
 
Filename:="C:\" & format(date,"yyyy.mm.dd") & "_INVOICE_" & Est2Eng(Worksheets("INVOICE").Range("B7")) & ".pdf", _
 
Алексей,  
предлагаю борьбу с кракозябрами продолжать в твоей теме  
http://www.planetaexcel.ru/forum.php?thread_id=26894  
 
Здесь это оффтоп.
 
Согласен.  
Просто там никакой реакции, да и к тому же у меня сейчас не получается не сама борьба с кракозябрами, а работа с буфером обмена, пример которой ты показал здесь.  
Я, конечно, и туда могу перенести свой предыдущий пост. Мне не трудно. Но ведь и там мой вопрос будет оффтопом. А ради такой узко "заточенной" мелочи создавать отдельный пост...
С уважением, Алексей (ИМХО: Excel-2003 - THE BEST!!!)
 
{quote}{login=Казанский}{date=18.04.2011 03:45}{thema=}{post}LV112  
Так Вам НАДО заменять умляуты на обычные буквы?! Я-то наоборот старался их сохранить.  
Добавьте в начало модуля следующий код:  
 
Const CODES_TO_REPLACE = "220 213 214 196 252 245 246 228" 'unicode-коды спец. букв  
Const LETTERS = "Y O O A y o o a" 'буквы для замены  
 
Function Est2Eng(ByVal s As String) As String  
Dim i&, cds$(), ltrs$()  
cds = Split(CODES_TO_REPLACE)  
ltrs = Split(LETTERS)  
For i = 0 To UBound(cds)  
   s = Replace$(s, ChrW$(CLng(cds(i))), ltrs(i))  
Next  
Est2Eng = s  
End Function  
 
Используйте функцию для подстановки букв в своем исходном макросе:  
 
Filename:="C:\" & format(date,"yyyy.mm.dd") & "_INVOICE_" & Est2Eng(Worksheets("INVOICE").Range("B7")) & ".pdf", _{/post}{/quote}  
 
Спасибо, буду пробывать!
Страницы: 1 2 След.
Наверх