Выгрузка макросом данных из EXCEL в TXT-файл в кодировке CP866 (DOS)

[albatros]

Уважаемые форумчане, знатоки EXCEL, добрый день.
Подсобите, пожалуйста, дилетанту.
Есть макрос (приводится ниже) для выгрузки данных из EXCEL в TXT-файл в кодировке CP866 (DOS). Последовательность такая: с помощью другого макроса из таблицы на новый лист формируется запись типа: "Гвозди","123","склад","..." и т.д. в формате "общий" или "текст". Это очень важно! В кавычках стоят значения или текст из ячеек таблицы, запятыми эти самые данные разделяются - т.о. запись представляет собой набор данных, "сцепленых" в одной ячейке. Получается таблица в один столбец. Количество сток в ней варьируется. И тут я столкнулся с неприятной ситуацией: из нескольких свиду одинаковых по составу файлов, часть txt-файлов записывается, а часть нет. Стал разбираться и оказалось, что в тех файлах, которые не обрабатываются макросом (не формируются txt-файлы), строчные записи не читаются (макрос их не видит) и выглядят набором решеток (при просмотре их через формат ячейки). Вот так "################". Хотя у меня EXCEL2007 и количество символов в ячейке явно меньше 32 тысяч с копейками. О-о-о-очень нужно, чтобы файл выгружался в txt, причем именно в кодировке 866 (но не в CRV!!!). Огромная просьба, не отсылайте меня ко всяким мудрым источникам - не пойму. Если есть выход, просто скажите что и куда дописать.
Вот макрос (Скачал его в сети. Если кто узнает свое творение - огромное ему спасибо):
Public Const WC_COMPOSITECHECK = &H200
Public Const WC_DEFAULTCHAR = &H40
Public Const WC_DISCARDNS = &H10
Public Const WC_SEPCHARS = &H20

Public Const CP_ACP = 0
Public Const CP_OEMCP = 1
Public Const CP_MACCP = 2
Public Const CP_THREAD_ACP = 3
Public Const CP_SYMBOL = 42
Public Const CP_UTF7 = 65000
Public Const CP_UTF8 = 65001

Public Const MB_PRECOMPOSED = &H1
Public Const MB_COMPOSITE = &H2
Public Const MB_USEGLYPHCHARS = &H4
Public Const MB_ERR_INVALID_CHARS = &H8

Public Declare Function WideCharToMultiByte Lib "kernel32" _
    (ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As String, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As String, _
    ByVal cchMultiByte As Long, _
    ByVal lpDefaultChar As String, ByVal _
    lpUsedDefaultChar As Long) As Long

Public Declare Function MultiByteToWideChar Lib "kernel32" _
    (ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As String, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As String, _
    ByVal cchWideChar As Long) As Long

' Функция ConvertString преобразует строку strStc из кодовой страницы nFromCP,
' в кодовую страницу nToCP, и возвращает преобразованную строку.
Public Function ConvertString(ByVal strSrc As String, ByVal nFromCP As Long, ByVal nToCP As Long) As String
    Dim nLen As Long
    Dim strDst As String
    Dim strRet As String
    Dim nRet As Long
   
    nLen = Len(strSrc)
    strDst = String(nLen * 2, Chr(0))
    strRet = String(nLen * 2, Chr(0))
    nRet = MultiByteToWideChar(nFromCP, MB_PRECOMPOSED, strSrc, nLen, strDst, nLen)
    nRet = WideCharToMultiByte(nToCP, 0, strDst, nRet, strRet, nLen * 2, ByVal 0, 0)
    ConvertString = Left(strRet, nRet)
End Function

Sub main()
    On Error Resume Next
    имяфайла = Split(ThisWorkbook.Name, ".")(0) ' имя файла без расширения
    arr = Split(имяфайла, "_") ' разбиваем на 3 части: 1-я номер формы, 2-я номер раздела, 3-я любая
   
    ПапкаДляТекстовыхФайлов = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Для KLIKO\")    ' папка будет называться "Name"
    MkDir ПапкаДляТекстовыхФайлов    ' создаём папку

    ' формируем текстовый файл
    СохранитьТекстовыйФайл 1, ПапкаДляТекстовыхФайлов & arr(0) & arr(1) & ".txt"
       
    MsgBox "Файл f711-21.txt сформирован и сохранен в папке" & vbNewLine & ПапкаДляТекстовыхФайлов, vbInformation, "Готово"
End Sub

Sub СохранитьТекстовыйФайл(ByVal col As Long, ByVal filename As String)
    Dim cell As Range, ra As Range
    Set ra = Range(Cells(Rows.Count, col).End(xlUp), Cells(Rows.Count, col).End(xlUp).End(xlUp))
    ' если надо точные значения из ячеек
    txt = Join(Application.WorksheetFunction.Transpose(ra.Value), vbNewLine)
       
    ' Конвертация из Win1251 в DOS
    txt = ConvertString(txt, 1251, 866)
   
    On Error Resume Next: Err.Clear
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True) ' создаём текстовый файл
    ts.Write txt: ts.Close
    Set ts = Nothing: Set fso = Nothing
End Sub


а вот строка из сформированной записи, которя не читается:
"МОЛОТОК","BIN3","7744003399","ОВ","0000598","","17.01.2011","По предъявлении, но не ранее 18.01.2012","5000000","643","16.03.2011","Договор купли-продажи № 1250/О-1603 от 16.03.2011г.","ХК РИТМ САМАРА","7709303960","4687565","134430.49","51405","хранилище","7718104217","",""

Помогите разобраться! Буду очень благодарен.

[albatros]

Здравствуйте, _Boroda_, спасибо за отклик.
Файлы в прикреплении. 132-й рабочий, 21-й - нет.

[_Boroda_]

Терзают смутные сомнения, что нужно 255 символов в ячейке
Попробуйте
Поставить формат не "Общий", а "Текстовый"
Сам проверить не могу, у меня 64 битная система, там подкулючаемые макросом библиотеки нужно обрабатывать иначе

[albatros]

В текстовом формате тоже самое - решетки идут... Как только ставишь числовой формат, процентный, дату - все видно, но макрос по прежнему не видит строку...
Я пробовал уполовинить строку. Тогда все видно... Очевидно, что проблема именно в длине строки, поэтому и обратился за помощью. Может кто уже сталкивался с этой проблемой и решил ее...

[Prist]

Косяк в этой строке:
txt = Join(Application.WorksheetFunction.Transpose(ra.Value), vbNewLine)

Transpose при строках, длиной более 255 символов обрезает до 255, а у Join есть ограничение на длину выходного массива. Замените одноименную процедуру на такую:

Код Выделить Развернуть

Sub СохранитьТекстовыйФайл(ByVal col As Long, ByVal filename As String)
    Dim cell As Range, ra As Range, avArr, li As Long
    Set ra = Range(Cells(Rows.Count, col).End(xlUp), Cells(Rows.Count, col).End(xlUp).End(xlUp))
    ' если надо точные значения из ячеек
    avArr = ra.Value
    For li = 1 To UBound(avArr, 1)
        If txt = "" Then
            txt = avArr(li, 1)
        Else
            txt = txt & vbNewLine & avArr(li, 1)
        End If
    Next li

    ' Конвертация из Win1251 в DOS
    txt = ConvertString(txt, 1251, 866)

    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)    ' создаём текстовый файл
    ts.Write txt: ts.Close
    Set ts = Nothing: Set fso = Nothing
End Sub
Так же чуть подправил процедуру Main

Код Выделить Развернуть

Sub main()
    имяфайла = Split(ThisWorkbook.Name, ".")(0) ' имя файла без расширения
    arr = Split(имяфайла, "_") ' разбиваем на 3 части: 1-я номер формы, 2-я номер раздела, 3-я любая
   
    ПапкаДляТекстовыхФайлов = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Для KLIKO\")    ' папка будет называться "Name"
    ' создаём папку
    If Dir(ПапкаДляТекстовыхФайлов, vbDirectory) = "" Then MkDir ПапкаДляТекстовыхФайлов
    ' формируем текстовый файл
    СохранитьТекстовыйФайл 1, ПапкаДляТекстовыхФайлов & arr(0) & arr(1) & ".txt"
       
    MsgBox "Файл f711-21.txt сформирован и сохранен в папке" & vbNewLine & ПапкаДляТекстовыхФайлов, vbInformation, "Готово"
End Sub

[albatros]

Спасибо!

[albatros]

Уважаемый Prist!
Спасибо огромное! Заработало-о-о-о-о!!!!!!!!!!!!!!

[Albatros]

Уважаемый Prist, добрый день. Очень надеюсь, что Вы не покинули этот замечательный форум.
2 года назад Вы очень помогли мне с разрешением вопроса по теме "Выгрузка макросом данных из EXCEL в TXT--файл в кодировке CP866 (DOS) от 25.01.2012.
Сейчас снова хочу обратиться к Вам. Мне установили OFFICE 2013 x64 и Ваш макрос перестал работать. Какая то ерунда с Public Declare Function WideCharToMultiByte Lib "kernel32". Все выделено красным цветом... Может быть Вы согласитесь еще раз помочь дилетанту? Можно ли сделать так, чтобы выгрузка работала и в х32 и в х64 EXCEL, так как приходится работать в разных версиях OFFICE? С уважением, Albatros

[Prist]

Попробуйте объявить API-функции так:

Код Выделить Развернуть

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" _
                                            (ByVal CodePage As LongLong, _
                                             ByVal dwFlags As LongLong, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As LongLong, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As LongLong, _
                                             ByVal lpDefaultChar As String, ByVal _
                                                                            lpUsedDefaultChar As Long) As LongLong

        Public Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" _
                                            (ByVal CodePage As LongLong, _
                                             ByVal dwFlags As LongLong, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As LongLong, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As LongLong) As LongLong
    #Else
        Public Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" _
                                            (ByVal CodePage As Long, _
                                             ByVal dwFlags As Long, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As Long, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As Long, _
                                             ByVal lpDefaultChar As String, ByVal _
                                                                            lpUsedDefaultChar As Long) As Long

        Public Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" _
                                            (ByVal CodePage As Long, _
                                             ByVal dwFlags As Long, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As Long, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As Long) As Long
    #End If
#Else
    Public Declare Function WideCharToMultiByte Lib "kernel32" _
                                            (ByVal CodePage As Long, _
                                             ByVal dwFlags As Long, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As Long, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As Long, _
                                             ByVal lpDefaultChar As String, ByVal _
                                                                            lpUsedDefaultChar As Long) As Long

    Public Declare Function MultiByteToWideChar Lib "kernel32" _
                                            (ByVal CodePage As Long, _
                                             ByVal dwFlags As Long, _
                                             ByVal lpMultiByteStr As String, _
                                             ByVal cchMultiByte As Long, _
                                             ByVal lpWideCharStr As String, _
                                             ByVal cchWideChar As Long) As Long
#End If

[Albatros]

Добрый день, Prist!
Спасибо, что откликнулись. Я выслал Вам код в личном сообщении, но, смотрю, Вы уже нашли тему.
Повторю здесь еще раз, а потом поробую использовать Ваш совет. Вот полный макрос. Красным выделена ошибка, которую определяет EXCEL
_______________________________________________________________________________________________________________________________
Public Const WC_COMPOSITECHECK = &H200
Public Const WC_DEFAULTCHAR = &H40
Public Const WC_DISCARDNS = &H10
Public Const WC_SEPCHARS = &H20

Public Const CP_ACP = 0
Public Const CP_OEMCP = 1
Public Const CP_MACCP = 2
Public Const CP_THREAD_ACP = 3
Public Const CP_SYMBOL = 42
Public Const CP_UTF7 = 65000
Public Const CP_UTF8 = 65001

Public Const MB_PRECOMPOSED = &H1
Public Const MB_COMPOSITE = &H2
Public Const MB_USEGLYPHCHARS = &H4
Public Const MB_ERR_INVALID_CHARS = &H8

Public Declare Function WideCharToMultiByte Lib "kernel32"
    (ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As String, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As String, _
    ByVal cchMultiByte As Long, _
    ByVal lpDefaultChar As String, ByVal _
    lpUsedDefaultChar As Long) As Long

Public Declare Function MultiByteToWideChar Lib "kernel32" _
    (ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As String, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As String, _
    ByVal cchWideChar As Long) As Long
' Функция ConvertString преобразует строку strStc из кодовой страницы nFromCP,
' в кодовую страницу nToCP, и возвращает преобразованную строку.
Public Function ConvertString(ByVal strSrc As String, ByVal nFromCP As Long, ByVal nToCP As Long) As String
    Dim nLen As Long
    Dim strDst As String
    Dim strRet As String
    Dim nRet As Long
   
    nLen = Len(strSrc)
    strDst = String(nLen * 2, Chr(0))
    strRet = String(nLen * 2, Chr(0))
    nRet = MultiByteToWideChar(nFromCP, MB_PRECOMPOSED, strSrc, nLen, strDst, nLen)
    nRet = WideCharToMultiByte(nToCP, 0, strDst, nRet, strRet, nLen * 2, ByVal 0, 0)
    ConvertString = Left(strRet, nRet)
End Function

Sub main2()
    имяфайла = "normativ" & "." & "txt" ' имя файла без расширения
    'arr = Split(имяфайла, "_") ' разбиваем на 3 части: 1-я номер формы, 2-я номер раздела, 3-я любая
   
    ПапкаДляТекстовыхФайлов = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Для KLIKO\")    ' папка будет называться "Для KLIKO"
    ' создаём папку
    If Dir(ПапкаДляТекстовыхФайлов, vbDirectory) = "" Then MkDir ПапкаДляТекстовыхФайлов
    ' формируем текстовый файл
    СохранитьТекстовыйФайл 1, ПапкаДляТекстовыхФайлов & "normativ" & ".txt"
       
    MsgBox "Файл сформирован и сохранен в папке" & vbNewLine & ПапкаДляТекстовыхФайлов, vbInformation, "Готово"
End Sub

Sub СохранитьТекстовыйФайл(ByVal col As Long, ByVal filename As String)
    Dim cell As Range, ra As Range, avArr, li As Long
    Set ra = Range(Cells(Rows.Count, col).End(xlUp), Cells(Rows.Count, col).End(xlUp).End(xlUp))
    ' если надо точные значения из ячеек
    avArr = ra.Value
    For li = 1 To UBound(avArr, 1)
        If txt = "" Then
            txt = avArr(li, 1)
        Else
            txt = txt & vbNewLine & avArr(li, 1)
        End If
    Next li

    ' Конвертация из Win1251 в DOS
    txt = ConvertString(txt, 1251, 866)

    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)    ' создаём текстовый файл
    ts.Write txt: ts.Close
    Set ts = Nothing: Set fso = Nothing
End Sub

[Albatros]

Что то не получается...
Private Function ConvertString(ByVal strSrc As String, ByVal nFromCP As Long, ByVal nToCP As Long) As String выделена желтым
и ругается на nRet = MultiByteToWideChar(nFromCP, MB_PRECOMPOSED, strSrc, nLen, strDst, nLen)

[Albatros]

Виноват. Public Function

[Albatros]

Уважаемый Prist, прикрепил файл, в котором не работает выгрузка. Правда он в жутко усеченном виде, так как информация... сами понимаете.
В общей сложности не получается ни сформировать данные для выгрузки (вкладка кап), ни выгрузить какие-либо данные (вкладка Экспорт).
Файл пришлось заархивировать, так как правила форума запрещают отправлять файлы xlsm

[shanemac51a]

сохранить в формате MS DOS

Е2007-------Нормально работает

[RAN]

1. Нельзя в одном проекте в разных модулях размещать одно и то же.
2. Если копируете, делайте это правильно. (модуль 5 и модуль 7)
3. И самое главное - зачем вы просили исправить код, если код, отредактированный для работы в Win 64 вы оставили на форуме?