批量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>



...全文
193 回复 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
回复
切换为时间正序
请发表友善的回复…
发表回复

4,009

社区成员

发帖
与我相关
我的任务
社区描述
它是一种微软环境下的轻量级的解释型语言,它使用COM组件、WMI、WSH、ADSI访问系统中的元素,对系统进行管理。
社区管理员
  • vbScript社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧