4,009
社区成员




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