批量xls转换成csv的HTA代码

ncqingchuan1976 2012-06-26 05:33:26



<html>

<html>

<HTA:APPLICATION

     scroll="no"

     MAXIMIZEBUTTON="NO"

     APPLICATIONNAME="Ncqingchuan"

     BORDER="dialog"

     CONTEXTMENU="Yes"

>

<title>XLSTOCSV工具</title>

<style>

BODY

{

   font-family:arial;

   font-size:10pt;

   background-color:ButtonFace;   

}

textarea

{

   font-family:arial;

   font-size:9pt;

   width:100%;

   height:250px;

}

button

{

   font-family: Helvetica;

   font-size: 10pt;

   width: 45px;

}

    #TxtDriver

    {

        width: 300px;

    }

    #Text1

    {

        width: 300px;

    }

    #RunButton

    {

        width: 115px;

    }

    #Button1

    {

        width: 115px;

    }

    #Button2

    {

        width: 428px;

    }

    #XLSPath

    {

        width: 300px;

    }

    #CSVPath

    {

        width: 300px;

    }

    #BtnCsv

    {

        width: 113px;

    }

    #BtnConvert

    {

        width: 426px;

    }

    #BtnXls

    {

        width: 114px;

    }

</style>

<script language=vbscript>



        sub window_onload()



               Window.resizeTo 470,170



               Self.moveto (window.screen.width-470)/2,(window.screen.height-270)/2



        End sub

        sub BtnXls_Click



            XLSPath.Value=Brower("请选择XLS文件夹")



        end sub

        

	    sub BtnConvert_Click()



	       if convertCsv(XLSPath.value,CSVPAth.value)=True then



	                msgbox "转换成功",VBOKonly,"成功"



	                XLSPath.Value=""



	                CSVpath.value=""



	       else

	                msgbox "请选择正确的文件夹路径",vbokOnly,"失败"

	       end if

	            

	    End sub

	    

	    sub BtnCsv_Click

	        CSVPAth.value=Brower("请选择CSV文件夹")

	    end sub

	    

	    Function Brower(Prom) 



            On Error Resume Next 



            Dim objShell, objFolder, intColonPos, objWshShell, returnerror 



            Dim strPrompt, BrowseInfo, root 



            strPrompt = Prom



            BrowseInfo = BIF_editbox + BIF_validate + BIF_browseincludefiles 



            root = BSF_desktop 



            

            Set objShell = CreateObject("Shell.Application") 



            Set objFolder = objShell.BrowseForFolder(&H0, strPrompt, BrowseInfo, root) 



            Brower = objFolder.ParentFolder.ParseName(objFolder.title).Path 

            

            set objFolder=nothing



            set objShell=nothing



        End Function

        

        Function ConvertCSV(XLSPath,CSVPath)



        On Error Resume Next



            Set Fso=CreateObject("Scripting.FileSystemObject")



            if fso.FolderExists(XlsPath)=False or fso.FolderExists(CSVPath)=False then



                Set Fso=Nothing



                ConvertCSV=False



                Exit Function



            End if



            dim xLCSV



	    xLCSV=6



            Set oApplication=CreateObject("Excel.Application")

            

            oApplication.DisplayAlerts = False

                       

            Set Folder=FSO.GetFolder(XLSPath)

            

            Set Files=Folder.Files

            

            Dim oWorkBook

            

            For Each File in Files

           

                If LCase(Mid(File, Len(File) - InStr(1, StrReverse(File), ".") + 2, 3)) = "xls" OR LCase(Mid(File, Len(File) 



- InStr(1, StrReverse(File), ".") + 2, 4)) = "xlsx" Then

                

                   Set oWorkBook = oApplication.WorkBooks.Open ( File )



                   dim Filename 



		   if  LCase(Mid(File, Len(File) - InStr(1, StrReverse(File), ".") + 2, 3)) = "xls" then



                       Filename=Replace( File.Name, ".xls", "" , 1 , -1 , 1 ) 

   

   		   End if



		   if LCase(Mid(File, Len(File) - InStr(1, StrReverse(File), ".") + 2, 4)) = "xlsx" then



		       Filename=Replace( File.Name, ".xlsx", "" , 1 , -1 , 1 ) 



		   end if



                   oWorkBook.SaveAs CSVPath & "\" & Filename & ".CSV" , xLCSV

                   

		   oWorkBook.Close           



                End if

            Next

		

            Set oWorkBook = Nothing



            oApplication.WorkBooks.Close

                        

            oApplication.Quit

            

            set oApplication=Nothing

            

            Set FSO=Nothing



            if err.number= 0 then



            	ConvertCSV=True



	    else



		ConvertCSV=False 



            end if



        End Function

</script>

<body>

<input type="text" id="XLSPath"/>  

<input type="button" id="BtnXls" value="XLS文件路径" onclick="BtnXls_Click" /><br />

    <br />

    <input id="CSVPath" type="text" />  

    <input type="button" id="BtnCsv" value="CSV文件路径" onclick="BtnCsv_Click" /><br />

<br />

<input type="button" id="BtnConvert" value="转换" onclick="BtnConvert_Click" />

</body>



</html>