STRIGANOV SERGEY: Software development.

Разработка программного обеспечения на: C++, T-SQL, VBS, JavaScript, PHP

HTA, Excel to CSV

Программа для выгрузки данных листов Excel-файла XLS или XLSX в формат CSV ( Comma Separated Text ). Работает, даже если на компьютере вообще не установлен Microsoft Office Excel. Есть редактор SQL запроса.  Гибкая настройка спец. символов для CSV.

Программа предназначена для выгрузки данных листов Excel файлов (xls и xlsx) в CSV  ( Comma Separated Text )
 Программа работает, даже если на компьютере вообще не установлен Microsoft Office Excel.

При этом можно задать любые:
+ ограничитель полей,
+ спец. символ, экранирующий ограничитель полей (если он встречается в тексте)
+ разделитель полей,
+ разделитель целой и дробной части (независимо от настроек локализации).
+ Можно, при необходимости, перекодировать весь текст (AnsiToOEM).
+ Есть предпросмотр структуры Excel-документа: количество страниц и их имена, количество строк и полей на странице.


Добавлено в версии 2.0
+ Теперь работает с xls и xlsx файлами (Если у Вас не работает с xlsx, то установите AccessDatabaseE ngine.exe).
+ Добавлен редактор SQL запроса и HTML-предпросмотр результатов запроса.

  MyCSV.vbs

Dim XLSX_info
XLSX_info = "<BR><BR>Возможно, у Вас не установлена программа <a href=http://www.microsoft.com/en-us/download/details.aspx?id=23734>AccessDatabaseEngine.exe</a>"
'-------------------------------------------------------------------------
sub XLS2CSV()
on error resume next

Const adOpen = 3 
    Dim row_num
    Dim cnn
    Dim rst
    Dim line_str
    Dim tmp_str  
    Dim fso, TextStream

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    div1.innerhtml ="<hr>"&Date & " - "& Time() & " Получение данных из XLS файла - старт. <BR>"
    cnn.Open GetConnectionString

     if err.number then
   div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Подключение к файлу - завершено с ошибкой: <h2>" & err.description & " (" & err.number & ")</h2>"
   if (GetFileExt(XLSFile.value)=".XLSX") then
           div1.innerhtml =div1.innerhtml & XLSX_info
   end if
            exit sub   
        end if
   
    rst.Open SQLEd.value, cnn, adOpen
      
    if err.number then
    div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Получение данных из XLS файла - завершено с ошибкой: <h2>" & err.description & _
            " (" & err.number & ")</h2>"
        exit sub   
    end if
    div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Получение данных из XLS файла - завершено.<BR>"&Date & " - "& Time() &" Cохранение в файл CSV - старт. <BR>"

   set  TextStream=fso.CreateTextFile(XLSFile.value&"_"&PAGE.value&".csv",1,0)

    row_num=1
  Do Until rst.EOF 
     line_str=""
  for i = 0 to rst.fields.count - 1 
 
      if (isnull(rst.Fields(i).Value)) then
      tmp_str=""
      else
      tmp_str=rst.Fields(i).Value
      end if 
     
      if (isnumeric(tmp_str))then     
        tmp_str=Replace(tmp_str,",", DECIMAL_DELIMITER.value)
        tmp_str=Replace(tmp_str,".", DECIMAL_DELIMITER.value)         
      else
        tmp_str= Replace(tmp_str, QUOTED.value, ECRAN.value)
        if (ENCODING.value="ANSItoOEM")then
         tmp_str= ANSItoOEM(tmp_str)
        end if
        if (ENCODING.value="OEMtoANSI")then
         tmp_str= OEMtoANSI(tmp_str)
        end if    
      end if

      if (i<>rst.fields.count - 1)then     
      line_str=line_str & QUOTED.value & tmp_str & QUOTED.value& DELIMITED.value
      end if     
           
    next
      TextStream.Write(line_str & QUOTED.value & tmp_str & QUOTED.value &vbcrlf)       
      row_num=row_num+1       
      rst.MoveNext
    Loop
   


TextStream.Close()
div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Cохранение в файл CSV - завершено.<HR>CSV файл:<br> <a href='file://"& _
GetFileDir(XLSFile.value) & "'>" & XLSFile.value&"_"& Encode_TEXT2HTML(PAGE.value)&".csv</a><br>Полей: "& CStr(rst.fields.count) & ", Строк: " & CStr(row_num-1)
'MsgBox XLSFile.value&"_"&PAGE.value&".csv"

fso=noting
cnn =noting
rst=noting 
end sub
'-------------------------------------------------------------------------
sub ShowHTML
on error resume next

Const adOpen = 3 
    Dim row_num
    Dim cnn
    Dim rst
    Dim line_str
    Dim tmp_str  
    Dim fso, HTMLTable

    HTMLTable= ""
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    div1.innerhtml ="<hr>"&Date & " - "& Time() & " SQL - Получение данных из XLS файла - старт. <BR>"
    cnn.Open GetConnectionString

     if err.number then
   div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " SQL - Подключение к файлу - завершено с ошибкой: <h2>" & err.description & " (" & err.number & ")</h2>"
   if (GetFileExt(XLSFile.value)=".XLSX") then
           div1.innerhtml =div1.innerhtml & XLSX_info
   end if
            exit sub   
        end if
   
    rst.Open SQLEd.value, cnn, adOpen
      
    if err.number then
    div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " SQL - Получение данных из XLS файла - завершено с ошибкой: <h2>" & err.description & _
            " (" & err.number & ")</h2>"
        exit sub   
    end if
   
    row_num=1
  Do Until rst.EOF 
     line_str=""
  for i = 0 to rst.fields.count - 1 
 
      if (isnull(rst.Fields(i).Value)) then
      tmp_str=""
      else
      tmp_str=rst.Fields(i).Value
      end if 

      if (isnumeric(tmp_str)) then     
        tmp_str = Replace(tmp_str,",", DECIMAL_DELIMITER.value)
        tmp_str = Replace(tmp_str,".", DECIMAL_DELIMITER.value)         
      else
        tmp_str = Replace(tmp_str, QUOTED.value, ECRAN.value)       
      end if

      if (i<>rst.fields.count - 1) then     
      line_str = line_str & "<td onDblClick='alert(""строка " & CStr(row_num) & ", поле F" & CStr(i+1) & " "")'>" & Encode_TEXT2HTML(tmp_str) & "</td>"
      end if     
           
    next
      HTMLTable=HTMLTable & "<tr>" & line_str & "<td onDblClick='alert(""строка " & CStr(row_num) & ", поле F" & CStr(i) & " "")'>" & Encode_TEXT2HTML(tmp_str) & "</td></tr>"       
      row_num = row_num+1       
      rst.MoveNext
    Loop
   

div1.innerhtml = div1.innerhtml & Date & " - " & Time() & " Полей: " & CStr(rst.fields.count) & ", Строк: " & CStr(row_num-1) & "<br><br><table cellpadding='5' BGCOLOR=#F0F0F0 style=' FONT: 8pt Arial; color: black; border-collapse: collapse; ' frame='box' align=left border=1 bordercolor=black>" & HTMLTable & "</table>"

fso=noting
cnn =noting
rst=noting 
End sub
'-------------------------------------------------------------------------
function GetConnectionString ()
Dim ret
ret =""

if (GetFileExt(XLSFile.value)=".XLS") then
  ret = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & XLSFile.value & "; Extended Properties=""Excel 8.0;HDR=No;IMEX=1""" 
else
  ret = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & XLSFile.value & "; Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"""
end if

GetConnectionString = ret
End function
'-------------------------------------------------------------------------
function GetFileDir (FName)
Dim ret, tmp
ret =""
tmp = StrReverse(FName)
ret = StrReverse(Mid(tmp, InStr(tmp, "\"),Len(tmp) ))
GetFileDir = ret
End function
'-------------------------------------------------------------------------
function GetFileExt (FName)
Dim ret, tmp
ret =""
tmp = StrReverse(FName)
ret = UCase(StrReverse(Mid(tmp,1, InStr(tmp, "."))))
GetFileExt = ret
End function
'-------------------------------------------------------------------------
Sub ReadStructure()
    on error resume next
    dim s, b
    Const adOpen = 3 
    Dim cnn

div1.innerhtml ="<hr>"
    div1.innerhtml =div1.innerhtml&"<h3>Структура файла XLS:</h3>"  

    Set cnn = CreateObject("ADODB.Connection")
 
    cnn.Open GetConnectionString

  if err.number then
   div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Подключение к файлу - завершено с ошибкой: <h2>" & err.description & " (" & err.number & ")</h2>"
   if (GetFileExt(XLSFile.value)=".XLSX") then
           div1.innerhtml =div1.innerhtml & XLSX_info
   end if
            exit sub   
        end if
       
    if err.number then
       div1.innerhtml = "<hr><br>Ошибка подключения к файлу: <h2>" & err.description & _
            " (" & err.number & ")</h2>"
        exit sub
    end if

    dim cat
    set cat = CreateObject("ADOX.Catalog")
    if err.number then
        div1.innerhtml = "<hr><br>Ошибка открытия каталога: <h2>" & err.description & _
            " (" & err.number & ")</h2>"
   exit sub
    end if
   
    Set cat.ActiveConnection =  cnn
    s=""
    b="<SELECT ID='PAGE'  SIZE=1  onChange=SetSQL>"&vbcrlf
  
    s="<table  style='FONT: 9pt Arial;' border='1' cellpadding='2'><tr><TD >Страница</TD><TD>Полей</TD><td>Строк</td></tr>"
  Dim tnam, rc, cc
    for each t in cat.tables   
     if t.type = "TABLE" then 
tnam =t.name
cc = t.columns.count
rc = GetRecordCount(tnam)
if (rc>0 and cc>0) then

s = s & "<tr><TD ondblclick=""SetActivePage('" & Replace(tnam,"'","''") &"')""><b>" & tnam &  "</b></td><td>" & cc & "</td><td>" & rc & "</td></tr>"
b = b & "<OPTION VALUE=""" & tnam & """>" & tnam & vbcrlf

end if
     end if         
    next
b=b& "</SELECT>"

PAGE_BOX.innerhtml =b
div1.innerhtml =div1.innerhtml& s& "</table>"
SetSQL
cnn=noting
end sub
'-------------------------------------------------------------------------
function GetRecordCount(table_name)
    on error resume next
    Const adOpen = 3 
    Dim cnn
    Dim rst
    Dim RetVal
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")
  
    cnn.Open GetConnectionString

  if err.number then
   div1.innerhtml =div1.innerhtml&Date & " - "& Time() & " Подключение к файлу - завершено с ошибкой: <h2>" & err.description & " (" & err.number & ")</h2>"
   if (GetFileExt(XLSFile.value)=".XLSX") then
           div1.innerhtml =div1.innerhtml & XLSX_info
   end if
            exit function  
        end if
   
    rst.Open "SELECT Count(*) as cnt FROM ["&table_name&"]", cnn, adOpen
        if err.number then
       RetVal = 0 '"Ошибка получения списка строк: <br>" & err.description & " (" & err.number & ")"            
            cnn =noting
            rst=noting
            GetRecordCount=RetVal
        exit function
    end if
   
   RetVal=rst.Fields(0).Value
   
cnn =noting
rst=noting 

GetRecordCount=CStr(RetVal)
end function
'-------------------------------------------------------------------------
sub SetActivePage(table_name)
PAGE.value=table_name
SetSQL
end sub
'-------------------------------------------------------------------------
sub SetSQL()
SQLEd.value="SELECT * FROM ["&PAGE.value&"]"
end sub
'------------------------------------------------------------------------------------
Function Encode_TEXT2HTML(StrTEXT2HTML) ' перекодируем некоторые спец. сиволы для корректного отображения
If (Len(StrTEXT2HTML)=0 or isnull(StrTEXT2HTML)) Then
Encode_TEXT2HTML=""
Exit Function
End If
StrTEXT2HTML=Replace(Replace(Replace(Replace(StrTEXT2HTML,"&","&amp;"),">","&gt;"),"<", "&lt;"),"""","&quot;")
Encode_TEXT2HTML = StrTEXT2HTML
End Function
'-------------------------------------------------------------------------
'/******************************************/
'/*   Перекодировка символа                */
'/******************************************/
Function CharOEMtoANSI(symbol)
Dim code
Dim res
      code=Asc(symbol)
      if ((code>=128) and (code<=175)) then
  res = Chr(code+64)
      elseif ((code>=224) and (code<=239)) then
           res= Chr(code+16)
      else
           res = symbol
      end if
CharOEMtoANSI=res
end Function
'/******************************************/
Function CharANSItoOEM(symbol)
Dim code
Dim res
      code=Asc(symbol)
      if ((code>=176) and (code<=239)) then
  if(code=185) then
            res= Chr(code+67)
  else
            res= Chr(code-64)
  end if
      elseif ((code>=240) and (code<=255)) then
           res= Chr(code-16)
      else
           res= symbol
      end if
      CharANSItoOEM=res
end Function
'/******************************************/
'/*   Перекодировка строки                 */
'/******************************************/
Function OEMtoANSI(st)
Dim i
Dim slen
Dim tmp
slen=Len(st)
i=0
tmp=""
      While(i<sLen)
           i=i+1
           tmp=tmp+CharOEMtoANSI(Mid(st,i,1))
      wend
      OEMtoANSI=tmp
end Function
'-------------------------------------------------------------------------
Function ANSItoOEM(st)
Dim i
Dim slen
Dim tmp
slen=Len(st)
i=0
tmp=""
      While(i<sLen)
           i=i+1
           tmp=tmp+CharANSItoOEM(Mid(st,i,1))
      wend
      ANSItoOEM=tmp
end Function
'/******************************************/


Начиная с 15 Января 2013 года в секции Attachments можно скачать и новую и старую версию программы. 

Основные функции новой версии (2.0) остались прежними:
Выгрузка данных со страниц Excel файлов (xls и xlsx) в CSV  - работает, даже если на компьютере вообще не установлен MS Office.

+ Добавлена возможность редактирвания SQL запроса, что открывает широкие возможности по обработке данных:
сотрировка, группировка, выгрузка данных в соотвествии с условиями: в том числе - одновременно с разных листов.
+ Для удобства отладки запроса - есть режим HTML предпросмотра, в котором данные отображаются с учетом выбранных настроек спец. символов.
+ По двойному клику на любой ячейке таблицы - появляется сообщение с номером строки и именем поля (эту информацию можно потом использовать в SQL запросе).
+ Исправлены некоторые названия элементов на форме.
+ Cсылка на CSV файл, которая появляется по окончании генерации файла - теперь открывает
не сам файл, а содержащую его папку.

Установка программы:
- Чтобы скачать программу - в блоке 
Attachments нажмите на ссылку на ZIP архив с нужной Вам версией программы.
- Создайте папку и распакуйте в нее архив - например C:\MyCSV.
- Запуск программы - двойной клик на файле 
MyCSV.hta ( для удобства запуска - можете сделать ярлык на рабочий стол).
- Если получаете ошибку "
Настройка безопасности данного компьютера запрещает доступ к источнику данных в другом домене."
  откройте свойства файла MyCSV.hta и нажмите на кнопку "Разблокировать".

Использование программы:
- Кнопкой "Обзор" выберите XLS или XLSX файл.
- Нажмите на кнопку "Структура XLS" - для чтения структуры файла.
- Выберите активный лист.
- Настройте спец. символы для CSV (разделитель полей, экранирующий символ, целая и дробная часть).
- При необходимости, отредактируйте SQL запрос и проконтролируйте правильность выполнения запроса, нажав на кнопку "Предпросмотр в HTML".
- При необходимости, установите режим преобразования текста в поле "Кодировка текста".
- Нажмите на кнопку "Сохранить в CSV". При этом рядом с файлом - источником будет создан новый файл с расширением CSV, имя файла состоит из имени файла - источника плюс имя активного листа. Cсылка на CSV файл, которая появится по окончании генерации файла открывает не сам файл, а содержащую его папку.

Что намечено на будущее (todo for version 3.0):
- сохранение и загрузка проекта (SQL-запрос, пути к файлам, спец. символы)
- работа из командной строки
- подстветка синтаксиса SQL в редакторе запроса.

Attachments:
FileDescriptionFile sizeLast modified
Download this file (MyCSV.zip)MyCSV.zipversion 1.0 - deprecated (первая версия)3 kB2013-01-17 00:59
Download this file (MyCSV_v2.zip)MyCSV_v2.zipcurrent version 2.0 (вторая версия)4 kB2013-01-17 00:59

Comments   

 
+1 #4 Striganov Sergey 2013-01-13 15:33
15.01.2013 опубликовал новую версию программы ( version 2.0 ),
которая работает с xlsx файлами.

Возможно, потребуется установить
AccessDatabaseE ngine.exe:
www.microsoft.com/en-us/download/details.aspx?id=23734
Quote
 
 
+1 #3 oleg 2013-01-11 15:23
xlsx не работает
Quote
 
 
+1 #2 Striganov Sergey 2012-09-20 10:56
Не нужно ничего присылать - программу можно скачать с сайта:
в секции Attachments нажмите на ссылку MyCSV.zip
Quote
 
 
-1 #1 andrei 2012-09-19 21:54
просто пришлите программу
Quote
 

Add comment