Application.FileSearch

[phx447]

День добрый. Возникла проблема с макросом при переходе с Office 2003 на 2007. Ошибка выходит на Application.FileSearch и как я понял, из поиска в интернете, Application.FileSearch в Office 2007 и выше отключен.
Я не программист и прошу помощи в решении проблемы.
Ошибка выходит на этом месте:

CheckExist:
With Application.FileSearch
.FileName = LastTxtName & ".txt"
.LookIn = ActiveDocument.Path
.Execute

While .Execute > 0

Incrementor = Incrementor + 1
If Incrementor < 10 Then
MatchLetters = 8
Else
MatchLetters = 7
End If

LastTxtName = Left (LastTxtName, MatchLetters - 1) & Incrementor

GoTo CheckExist

Wend
End With

FullLastTxtName = ActiveDocument.Path & "\" & LastTxtName & ".txt"

End Sub

[Iska]

phx447, что должен делать приведённый Вами кусок кода?

[DJ Mogarych]

Четвёртая ссылка вот здесь: https://www.google.ru/search?q=Application.FileSearch

Там есть решение: https://answers.microsoft.com/en-us/office/forum/office_2010-customize/i-have-a-spreadsheet-which-uses/669118de-e3a5-4815-bb95-0a83eb6bf984

[phx447]

Iska, вот что делает
` А такой LLLLLL[][i].txt - файл имеется?
CheckExist:
`Если такой же (или следующий, или схожий по первым буквам) *.txt файл уже есть в этой папке`
With Application.FileSearch
.FileName = LastTxtName & ".txt"
.LookIn = ActiveDocument.Path
.Execute

While .Execute > 0

Incrementor = Incrementor + 1
`Поддерживается до 100 файлов`
If Incrementor < 10 Then
MatchLetters = 8 `(7 букв + 1 цифра)
Else
MatchLetters = 7 ` (6 букв + 2 цифра)
End If

LastTxtName = Left (LastTxtName, MatchLetters - 1) & Incrementor

` А такой LLLLLL[][i].txt - файл имеется?
GoTo CheckExist

Wend
End With

`Коннектим к файлу в транслите расширение *.txt
FullLastTxtName = ActiveDocument.Path & "\" & LastTxtName & ".txt"

End Sub

DJ Mogarych, я в гугле искал, но я не знаю или точнее не понимаю, как воспользоваться ответами, которые там даны.

[Iska]

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

[phx447]

Iska, данный код макросом в office 2003 проверяет текст на наличие лишних пробелов, заменяет некоторые символы на нужные, выравнивает текст по ширине и сохраняет измененный *.doc файл в *.txt. Предварительно проверив папку на наличие схожих по названию файлов при сохранении.

[Iska]

Предварительно проверив папку на наличие схожих по названию файлов при сохранении. »
Расшифруйте, пожалуйста, подробнее. Что значит «схожих по названию»? Для чего проверяет?

[phx447]

Предварительно проверив папку на наличие схожих по названию файлов при сохранении. »
Расшифруйте, пожалуйста, подробнее. Что значит «схожих по названию»? Для чего проверяет?
Схожих по названию, значит идентичных, одинаковых. Например повторно применяя этот макрос на файле text.doc, то на этапе сохранения он определит, что уже имеется файл text.txt и макрос этот файл сохранит как text 1.txt.

[Iska]

повторно применяя этот макрос на файле text.doc, то на этапе сохранения он определит, что уже имеется файл text.txt и макрос этот файл сохранит как text 1.txt. »
Я этого не вижу по приведённому Вами коду.

В общем, насколько я понимаю, Вам нужна функция, которая для каталога, где расположен активный документ, и указанного имени файла вернёт первое доступное имя файла, построенное по определённому принципу.
Option Explicit

Function GetFirstFreeName(strFileName As String)
Dim objFSO As Object

Dim strBaseFileName As String
Dim strFullFileName As String
Dim iCount As Integer

Set objFSO = CreateObject("Scripting.FileSystemObject")

strBaseFileName = objFSO.GetBaseName(strFileName)
strFullFileName = objFSO.BuildPath(ActiveDocument.Path, strBaseFileName & ".txt")

iCount = 1

Do While objFSO.FileExists(strFullFileName)
iCount = iCount + 1
strFullFileName = objFSO.BuildPath(ActiveDocument.Path, strBaseFileName & " " & CStr(iCount) & ".txt")
Loop

GetFirstFreeName = strFullFileName
End Function

т.е., например, для активного документа C:\Мои проекты\0274\Doc1.doc и переданного имени файла text.doc последовательно будут возвращаться имена:
C:\Мои проекты\0274\text.txt
C:\Мои проекты\0274\text 2.txt
C:\Мои проекты\0274\text 3.txt
C:\Мои проекты\0274\text 3.txt
и т.д. Так?

[megaloman]

Что должен делать код? Я не понимаю его предназначение. »Напрягу воображение:
ИМХО, это отрывок макроса в WORD, пробую (для себя!) описать его назначение:
Есть некие переменные, начальное значение определёно где-то выше:
LastTxtName - имя файла без расширения
Incrementor - счетчик для повторяющихся имен
В результате работы этого куска макроса длина имени LastTxtName+Пробел+Incrementor должно быть не более 8 символов, LastTxtName урезается.
Получившееся имя ActiveDocument.Path & "\" & LastTxtName & ".txt" не должно дублировать имеющееся имя файла.
Вот вариант для замены Вашего куска:LastTxtName = "ABCDEFGHIJKLMN"


Incrementor = 0
ActiveDocumentPath = ActiveDocument.Path + "\"
Do
If Incrementor = 0 Then
TxtName = Left(LastTxtName, 6)
Else
TxtName = Left(LastTxtName, 7 - Len(CStr(Incrementor))) + " " + CStr(Incrementor)
End If
FullLastTxtName = ActiveDocumentPath + TxtName + ".txt"
D = Dir(FullLastTxtName)
If D = "" Then Exit Do
Incrementor = Incrementor + 1
Loop


MsgBox """" + FullLastTxtName + """"
Зачеркнутые строки мне были нужны для отладки - Вы их удалте.
Incrementor = 0 - не знаю, нужно или нет, если эта переменная выше приведенного куска где-то определялась, то эту строку надо удалить.
Не очень понимаю, какое имя должно получиться при Incrementor = 0. Я сделал для отладочного имени ABCDEF.txt
В принципе, начальное значение Incrementor может быть не 0, а любое допустимое >0, например, 1 (первое имя при этом будет ABCDEF 1.txt).
Максимальная величина Incrementor в отладочном имени "A 999999.txt. Надеюсь, хватит.

[Iska]

Вот за это я и люблю коллективный разум!

[phx447]

megaloman, Iska возможно ваши варианты и подходят. Макрос на них не стопорится, теперь ошибка выходит на :

'Сохраняем в ОЕМ (DOS) кодировке
'Save file with new extension
ActiveDocument.SaveAs FileName:=FullLatTxtName, _
FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, Encoding:=866, InsertLineBreaks:=True, AllowSubstitutions:=True, _
LineEnding:=wdCRLF

[megaloman]

phx447, LastTxtName = "ABCDEFGHIJKLMN"

Incrementor = 0
ActiveDocumentPath = ActiveDocument.Path + "\"
Do
If Incrementor = 0 Then
TxtName = Left(LastTxtName, 6)
Else
TxtName = Left(LastTxtName, 7 - Len(CStr(Incrementor))) + " " + CStr(Incrementor)
End If
FullLastTxtName = ActiveDocumentPath + TxtName + ".txt"
D = Dir(FullLastTxtName)
If D = "" Then Exit Do
Incrementor = Incrementor + 1
Loop

MsgBox """" + FullLastTxtName + """"

ActiveDocument.SaveAs2 FileName:=FullLastTxtName, _
FileFormat:=wdFormatText, _
LockComments:=False, _
Password:="", _
AddToRecentFiles:=True, _
WritePassword:="", _
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, _
SaveFormsData:=False, _
SaveAsAOCELetter:=False, _
Encoding:=866, _
InsertLineBreaks:=False, _
AllowSubstitutions:=True, _
LineEnding:=wdCRLF, _
CompatibilityMode:=0

[phx447]

megaloman, на строке CompatibilityMode:=0 выходит Run-time error `13`: Type mismatch

[megaloman]

phx447, возможно, проблема в совместимости, у меня Word 2010
Во первых, если не убирать MsgBox """" + FullLastTxtName + """", там получается внятное имя файла? Если нормальное, то:
Сделайте как я: 'ActiveDocument.SaveAs2 FileName:=FullLastTxtName, _
' FileFormat:=wdFormatText, _
' LockComments:=False, _
' Password:="", _
' AddToRecentFiles:=True, _
' WritePassword:="", _
' ReadOnlyRecommended:=False, _
' EmbedTrueTypeFonts:=False, _
' SaveNativePictureFormat:=False, _
' SaveFormsData:=False, _
' SaveAsAOCELetter:=False, _
' Encoding:=866, _
' InsertLineBreaks:=False, _
' AllowSubstitutions:=True, _
' LineEnding:=wdCRLF, _
' CompatibilityMode:=0Закройте макрос. Сохраните файл.
Далее в ленте: Вид -> Макросы (треугольничек под надписью) -> Запись макроса -> Запомните имя макроса -> Птичка Макрос доступен для этого документа -> OK
Делаем: Файл -> Сохранить как -> Тип файла обычный текст -> имя файла можете сделать любым -> Сохранить документ в этом формате ->
http://forum.oszone.net/attachment.php?attachmentid=158786&stc=1&d=1567875088
-> Макросы (треугольничек под надписью) -> Остановить запись
Откройте записанный макрос.
(у меня имя файла было "qertyuio.txt") ActiveDocument.SaveAs2 FileName:="qertyuio.txt", FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, Encoding:=866, InsertLineBreaks:=False, AllowSubstitutions:=True, _
LineEnding:=wdCRLF, CompatibilityMode:=0
Скопируйте получившееся у Вас (по сравнению со мной может что - то отличаться), вставьте в текст основного макроса, замените выделенное мной на FullLastTxtName.
Сохраните файл как: тип файла *.docm можно с первоначальным, до изменения макроса, именем.
Тестируйте полученное.

[phx447]

megaloman, вроде макрос работает, но с несколькими проблемами.
Первая - это каждый документ после применения макроса сохраняется с именем "FullLastTxtName", если со строки FileName:= убрать все, то макрос не работает. А по задумке после применения документ должен сохраняться с именем первоначального документа, но в транслите.
Вторая - это после применения макроса, при следующем открытии Word нужно снова выносить макрос на панель, чтобы его применить

[megaloman]

если не убирать MsgBox """" + FullLastTxtName + """", там получается внятное имя файла?
ActiveDocument.SaveAs2 FileName:=FullLastTxtName, ..............
FullLastTxtName - без кавычек, это не имя файла, это переменная, где хранится полное имя файла, которое отображается в MsgBox