Declare PtrSafe Function MessageBoxTimeOut Lib "User32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As VbMsgBoxStyle, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long
Declare PtrSafe Function GetSystemMenu Lib "User32" (ByVal hwnd As LongPtr, ByVal bRevert As Long) As LongPtr
Declare PtrSafe Function RemoveMenu Lib "User32" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Sub SaveTXT_UTF8()
Dim fp$, txt$, aa As Range, ll&, ADOSt As Object, a%
On Error Resume Next
' создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & Range("L2")
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & Range("L2")
' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename(Format([L1], "№000 ") & Format(Now, "DD.MM.YYYY DDD., вр.hh-mm-ss") & " Простые письма.txt", "Текстовые файлы (*.txt), ", , "Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub
fp = Filename 'копирует в папку
ll = 2: txt = ""
Set ADOSt = CreateObject("ADODB.Stream")
ADOSt.Open: ADOSt.Charset = "utf-8"
ADOSt.WriteText Replace$(Mid$(fp, Len(fp) - InStr(StrReverse(fp), "\") + 2), ".txt", "") & vbCrLf
For Each aa In [C2:J35]
If Len(Range("C" & ll)) > 0 Then
If aa.EntireRow.Row = ll Then
txt = txt & Replace$(CStr(aa), Chr(10), " ") & vbTab
Else
txt = ll - 1 & vbTab & Left$(txt, Len(txt) - 1) & vbCrLf: ADOSt.WriteText txt
ll = ll + 1: txt = Replace$(CStr(aa), Chr(10), " ") & vbTab
End If
End If
Next
ADOSt.SaveToFile fp, 2
ADOSt.Close
Set ADOSt = Nothing
Const lSeconds As Long = 3
MessageBoxTimeOut 0, "Файл сформирован. Папка откроется через 3 секунды", "Goldenito", vbInformation + vbOKOnly, 0&, lSeconds * 1000
Shell "explorer.exe " & ThisWorkbook.Path & "\" & Range("L2"), vbMaximizedFocus 'vbNormalFocus в нормальном режиме или vbMaximizedFocus в полном раскрытом окне
End Sub
|