За комментировал обработку ошибок, не могу придумать как реализовать выше написанное.
<html id="appHTML">
<head>
<meta charset="windows-1251">
<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">
<meta http-equiv="Content-Language" content="ru">
<title>Конвертер файлов</title>
<hta:Application
Icon = "%ProgramFiles%\Microsoft Office\OFFICE11\WINWORD.EXE"
Id="oHTA"
ApplicationName="Конвертер файлов"
Border="normal"
BorderStyle="normal"
Caption="yes"
ContextMenu="no"
InnerBorder="yes"
MaximizeButton="no"
MinimizeButton="yes"
Navigable="no"
Scroll="auto"
ScrollFlat="no"
Selection="no"
ShowInTaskbar="yes"
SingleInstance="yes"
SysMenu="yes"
Version="1.0 RC2"
WindowState="normal"
/>
<object classid="clsid:0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC" id="MSScriptControl">
<param name="Timeout" value="10000">
<param name="AllowUI" value="-1">
<param name="UseSafeSubset" value="0">
</object>
</head>
<style type="text/css">
BODY {
font: x-small Verdana, Arial, sans-serif;
color: WindowText;
background-color: ButtonFace;
}
.Row{
clear:both;
}
.Left{
float:Left;
clear:none;
}
.Right{
float:Right;
clear:none;
}
.NonValid { color:FireBrick; }
#Status { font: xx-small; }
</style>
<script language="vbscript">
Option Explicit
'On Error Resume Next
'===================================================================================================
Function SelectFolder()
Const BIF_RETURNONLYFSDIRS = &H0001
Const BIF_EDITBOX = &H0010
Const BIF_VALIDATE = &H0020
Const BIF_NEWDIALOGSTYLE = &H0040
Dim objShell
Dim objFSO
Dim lngHWND
Dim intOptions
Dim strRootFolder
Dim objFolder
Dim strTemp
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
lngHWND = oHTA.Document.GetElementByID("MSScriptControl").SitehWnd
intOptions = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE Or BIF_EDITBOX Or BIF_VALIDATE
strRootFolder = 0
Set objFolder = objShell.BrowseForFolder(lngHWND, "Укажите папку", intOptions, strRootFolder)
If Not objFolder Is Nothing Then
If objFSO.FolderExists(objFolder.Self.Path) Then
SelectFolder = objFolder.Self.Path
End If
End If
Set objFolder = Nothing
Set objShell = Nothing
Set objFSO = Nothing
End Function
'===================================================================================================
'===================================================================================================
Sub SelectSourceFolder_OnClick
Dim strSelectedFolder
strSelectedFolder = Trim(SelectFolder())
If Len(strSelectedFolder) <> 0 Then
SourceFolder.value = strSelectedFolder
End If
End Sub
'===================================================================================================
'===================================================================================================
Sub SelectDestFolder_OnClick
Dim strSelectedFolder
strSelectedFolder = Trim(SelectFolder())
If Len(strSelectedFolder) <> 0 Then
DestFolder.value = strSelectedFolder
End If
End Sub
'===================================================================================================
'===================================================================================================
Sub Convert_OnClick
If ValidateFields() Then
With document
.getElementByID("Status").innerText = "Идёт обработка…"
.getElementByID("SourceFolder").disabled = True
.getElementByID("SelectSourceFolder").disabled = True
'.getElementByID("SourceFolderAfter").disabled = True
.getElementByID("DestFolder").disabled = True
.getElementByID("SelectDestFolder").disabled = True
.getElementByID("SourceFormat").disabled = True
.getElementByID("DeleteAfterProcessing").disabled = True
.getElementByID("Convert").disabled = True
.getElementByID("DestFormat").disabled = True
.getElementByID("tagBody").style.cursor = "wait"
End With
setTimeout "Convert", 0
End If
End Sub
'===================================================================================================
'===================================================================================================
Sub Convert_OnBlur()
With document
.getElementByID("Status").innerText = ""
.getElementByID("lblSourceFolder").className = ""
.getElementByID("SourceFolder").className = ""
.getElementByID("lblDestFolder").className = ""
.getElementByID("DestFolder").className = ""
.getElementByID("lblSourceFormat").className = ""
.getElementByID("SourceFormat").className = ""
.getElementByID("lblDestFormat").className = ""
.getElementByID("DestFormat").className = ""
End With
End Sub
'===================================================================================================
'===================================================================================================
'Sub lblSourceFolderAfter_OnClick()
' With document.getElementByID("SourceFolderAfter")
' .focus
' .checked = Not .checked
' End With
'End Sub
'===================================================================================================
'===================================================================================================
Sub lblDeleteAfterProcessing_OnClick()
With document.getElementByID("DeleteAfterProcessing")
.focus
.checked = Not .checked
End With
End Sub
'===================================================================================================
Function ValidateFields()
Dim objFSO
Dim strValidateResult
Dim strSourceFolder
Dim strDestFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
ValidateFields = True
strValidateResult = ""
With document
strSourceFolder = .getElementByID("SourceFolder").value
strDestFolder = .getElementByID("DestFolder").value
'If .getElementByID("SourceFolderAfter").disabled = False Then
' strDestFolder = .getElementByID("SourceFolder").value
'end if
If Not objFSO.FolderExists(strSourceFolder) Then
strValidateResult = strValidateResult & "Исходная папка не найдена. "
' .getElementByID("SourceFolderAfter").disabled = True
.getElementByID("lblSourceFolder").className = "NonValid"
.getElementByID("SourceFolder").className = "NonValid"
ValidateFields = False
End If
If Not objFSO.FolderExists(strDestFolder) Then
strValidateResult = strValidateResult & "Целевая папка не найдена."
strDestFolder = .getElementByID("SourceFolder").value
.getElementByID("lblDestFolder").className = "NonValid"
.getElementByID("DestFolder").className = "NonValid"
ValidateFields = False
End If
.getElementByID("Status").innerText = strValidateResult
End With
Set objFSO = Nothing
End Function
'===================================================================================================
'===================================================================================================
Sub Convert()
'On Error Resume Next
'Выражение, которое может вызвать ошибку
'If Err <> 0 Then
'Msgbox "Произошла ошибка. " & Err.Description
'window.alert(Err.Description)
'Err.Clear
'End if
Const wdFormatRTF = 6 'RTF 2003
Const wdFormatDocument = 0 'DOC 2003 для формата office 97 = "102" без wdFormatDocument
Const wdFormatText = 2 'TXT обычный текст
Const wdFormatHTML = 8 'HTM, HTML на всякий случай.
Const wdFormatWebArchive =9 'MHT, MHTML случай всякий бывает.
Dim objFSO
Dim objFolder
Dim objFile
Dim objWord
Dim strSourceFolder
Dim strDestFolder
Dim strSourceFormat
Dim strDestFormat
Dim wdstrDestFormat
Dim boolDeleteAfterProcessing
'Dim boolSourceFolderAfter
'Dim ConvertSub
Dim StartTime
'ConvertSub = False
StartTime = Timer
strSourceFolder = document.getElementByID("SourceFolder").value
strDestFolder = document.getElementByID("DestFolder").value
strSourceFormat = document.getElementByID("SourceFormat").value
strDestFormat = document.getElementByID("DestFormat").value
boolDeleteAfterProcessing = document.getElementByID("DeleteAfterProcessing").checked
'boolSourceFolderAfter = document.getElementByID("SourceFolderAfter").checked
'If .getElementByID("SourceFolderAfter").disabled = False Then
' strDestFolder = .getElementByID("SourceFolder").value
'end if
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strSourceFolder)
Set objWord = CreateObject("Word.Application")
Select Case strDestFormat
Case "rtf"
wdstrDestFormat = 6
Case "doc"
wdstrDestFormat = 0
Case "txt"
wdstrDestFormat = 2
Case "htm"
wdstrDestFormat = 8
Case "html"
wdstrDestFormat = 8
End Select
For Each objFile In objFolder.Files
If UCase(objFSO.GetExtensionName(objFile)) = UCase(strSourceFormat) Then
With objWord.Documents.Open(objFile.Path)
.SaveAs objFSO.BuildPath(strDestFolder, objFSO.GetBaseName(objFile.Name) & "." & strDestFormat), wdstrDestFormat
.Close
End With
If boolDeleteAfterProcessing Then
objFile.Delete
End If
End If
Next
objWord.Quit
'ConvertSub = True
'========================================================================================================
'========================================================================================================
Set objWord = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set objFolder = Nothing
With document
.getElementByID("Status").innerText = "На обработку затрачено: " & _
TimeSerial(0, 0, Timer - StartTime) & "."
.getElementByID("SourceFolder").disabled = False
.getElementByID("SelectSourceFolder").disabled = False
'.getElementByID("SourceFolderAfter").disabled = False
.getElementByID("DestFolder").disabled = False
.getElementByID("SelectDestFolder").disabled = False
.getElementByID("SourceFormat").disabled = False
.getElementByID("DestFormat").disabled = False
.getElementByID("DeleteAfterProcessing").disabled= False
.getElementByID("Convert").disabled = False
.getElementByID("tagBody").style.cursor = "auto"
End With
End Sub
'===================================================================================================
'===================================================================================================
Sub ConvertError()
'Процедура оброботки ошибок
'1. Удаление процесса Winword.exe при ошибке
'2. Удаление временного файла objFile.Path & "~$" & objFile.Name ???
'3. Создание папки "Bad_File" и перемещение несконвертированого файла в эту папку.
'===================================================================================================
'1. Удаление процесса Winword.exe при ошибке
'===================================================================================================
Dim strFolderName
Dim strFullFolderName
Dim objFSO
Dim objFolder
Dim SourceFolder
Dim strSourceFolder
Dim objFile
Dim objService
Dim objProc
Select Case Err.Number
Case 0 ' нет ошибок;
msgbox "Конвертирование завершено"
Case Else ' есть ошибки;
msgbox "Неизвестная ошибка: " & Err.Number
End Select
With document
.getElementByID("Status").innerText = "Обработка ошибок..."
.getElementByID("SourceFolder").disabled = True
strSourceFolder = document.getElementByID("SourceFolder").value
.getElementByID("tagBody").style.cursor = "auto"
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strSourceFolder)
Set objService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
If Err.Number <> 0 Then
msgbox Err.Number & ": " & Err.Description
End If
For Each objProc In objService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'winword.exe'")
objProc.Terminate
'objFile.MoveFile(strSourceFolder)
Next
'====================================================================================================
'2. Удаление временного файла objFile.Path & "~$" & objFile.Name ??? не чего в голову не приходит
'====================================================================================================
'====================================================================================================
'3.
'====================================================================================================
strFolderName = "Bad_File"
strFullFolderName = objFSO.BuildPath(strSourceFolder, strFolderName)
If objFSO.FolderExists(strFullFolderName) Then
'msgbox "Folder [" & strFullFolderName & "] already exists."
Else
objFSO.CreateFolder strFullFolderName
'msgbox "Folder [" & strFullFolderName & "] created."
End If
For Each objFile In objFolder.Files
objFile.Copy strSourceFolder, strFullFolderName
Next
Set objFile = Nothing
Set objFSO = Nothing
Set objFolder = Nothing
end Sub
'===================================================================================================
</script>
<body id="tagBody" scroll="auto">
<span class="Row">
<span class="left">
<span id="lblSourceFolder">1. Укажите исходную папку</span>
</span>
<span class="right">
<input type="text" name="SourceFolder" size="64">
<input type="Button" name="SelectSourceFolder" value="…">
</span>
</span>
<span class="Row">
<span class="left">
<span id="lblDestFolder">2. Укажите целевую папку</span>
</span>
<span class="right">
<input type="text" name="DestFolder" size="64">
<input type="Button" name="SelectDestFolder" value="…">
</span>
</span>
<span class="Row">
<span class="left">
<span id="lblSourceFormat">3. Выберете формат исходных файлов</span>
</span>
<span class="right">
<select size="1" name="SourceFormat">
<option value="txt">.txt</option>
<option value="htm">.htm</option>
<option value="html">.html</option>
<option value="doc">.doc</option>
<option value="rtf">.rtf</option>
<option value="mht">.mht</option>
</select>
</span>
</span>
<span class="Row">
<span class="left">
<span id="lblDestFormat">4. Выберете формат целевых файлов</span>
</span>
<span class="right">
<select size="1" name="DestFormat">
<option value="rtf">.rtf</option>
<option value="doc">.doc</option>
<option value="txt">.txt</option>
<option value="htm">.htm</option>
<option value="html">.html</option>
</select>
</span>
</span>
<!--
<span class="Row">
<span class="left">
<span>5. Установите флажок использовать исходную папку как и целевую. (На будующее)</span>
</span>
<span class="right">
<input type="CheckBox" name="SourceFolderAfter">
<span id="lblSourceFolderAfter">Использовать исходную папку</span>
</span>
</span>
-->
<span class="Row">
<span class="left">
<span>5. Установите флажок для удаления файлов из исходной папки после обработки</span>
</span>
<span class="right">
<input type="CheckBox" name="DeleteAfterProcessing">
<span id="lblDeleteAfterProcessing">Удалять исходные файлы</span>
</span>
</span>
<span class="Row">
<span class="left">
<span id="lblConvert">6. Нажмите кнопку "Конвертировать"</span>
</span>
<span class="right">
<input type="Button" name="Convert" value="Конвертировать">
</span>
</span>
<hr class="Row" />
<span class="Row">
<span id="Status"> </span>
</span>
</body>
<script language="VBScript">
With window
.resizeTo tagBody.scrollWidth + 50, tagBody.scrollHeight + 32
.moveTo (.screen.availWidth - tagBody.offsetWidth) \ 2, (.screen.availHeight - tagBody.offsetHeight) \ 2
End With
</script>
</html>
.