Реализация HTA-диалога взята, разумеется, на этом форуме.
Весь код:
Option Explicit
'глобальные переменные
Dim ExitDo, oHTA, Document, strHTML, appName
appName = "autoClipboard"
Sub HTA_OnUnload
ExitDo = True
End Sub
'получаем окно
Set oHTA = GetOHTA (260, 260, appName, "#E0E0E0")
Set Document = oHTA.document
Function ClosingWindow
End Function
'==================================================================================================
'MAIN
'==================================================================================================
' формируем строку HTML-кода
strHTML = "<style type='text/css'>"
strHTML = "P{ font-family: Geneva, Arial, Helvetica, sans-serif; }"
strHTML = "</style>"
strHTML = strHTML & "<P>Обработчик события копирования текста с автовставкой в word-документ</P>"
'strHTML = strHTML & "<BR>"
strHTML = strHTML & "<BUTTON id=start>START</BUTTON> "
strHTML = strHTML & "<BUTTON id=stop>PAUSE</BUTTON> "
strHTML = strHTML & "<BR>"
strHTML = strHTML & "<P id=appStatus>Status: not running</P>"
strHTML = strHTML & "<P></P>"
strHTML = strHTML & "<BUTTON id=exit>EXIT</BUTTON> "
strHTML = strHTML & "<BR>"
strHTML = strHTML & "<INPUT TYPE=CHECKBOX id=closeWord>close word document"
' записываем HTML-код в тело документа
Document.getElementsByTagName("body")(0).innerHTML = strHTML
'==================================================================================================
Dim HTMLFile, MSWord, NewDoc, ProcessStatus, ProcessActive, CurrentClipboardText, CloseWordStatus
Set HTMLFile = WScript.CreateObject("HTMLFile")
Set MSWord = CreateObject("Word.Application")
Set NewDoc = MSWord.Documents.Add()
NewDoc.Activate()
MSWord.Selection.TypeText("Do not close the document while the " & appName & " is work!")
MSWord.Selection.TypeParagraph()
MSWord.Selection.TypeText("Не закрывайте этот документ во время работы " & appName & "!")
MSWord.Selection.TypeParagraph()
MSWord.Selection.TypeParagraph()
MSWord.Visible = True 'показываем документ
ProcessStatus = True
ProcessActive = False
CurrentClipboardText = ""
CloseWordStatus = ""
Function PastClipboard
Do While ProcessStatus
If ProcessActive Then
On Error Resume Next 'если обработчик попадает в момент копирования в буфер - происходит ошибка данных (null), пропускаем ее
If Not (HTMLFile.parentWindow.clipboardData.getData("text") = CurrentClipboardText) Then
If CurrentClipboardText = "" Then 'в первый заход из буфера ничего не вставляем
CurrentClipboardText = HTMLFile.parentWindow.clipboardData.getData("text")
Else
CurrentClipboardText = HTMLFile.parentWindow.clipboardData.getData("text")
NewDoc.Activate()
MSWord.Selection.Paste()
MSWord.Selection.TypeParagraph()
End If
End If
' If Err.Number<>0 Then
'<обработка ошибки>
'MsgBox Err.Description
' End If
' On Error GoTo 0 'обнуление объекта Err
End If
WScript.Sleep 100
Loop
MsgBox appName & ": handler stopped"
End Function
' назначение событий кнопкам
Sub StartProcess
If ProcessStatus Then
If Not ProcessActive Then
CurrentClipboardText = ""
ProcessActive = True
Document.parentWindow.appStatus.innerHTML = "Status: running"
End If
End If
End Sub
Document.parentWindow.start.onclick = GetRef("StartProcess")
Sub StopProcess
If ProcessActive Then
ProcessActive = False
Document.parentWindow.appStatus.innerHTML = "Status: pause"
End If
End Sub
Document.parentWindow.stop.onclick = GetRef("StopProcess")
Sub ClossApp
ProcessStatus = False
Document.parentWindow.close
End Sub
Document.parentWindow.exit.onclick = GetRef("ClossApp")
Sub CloseWord
CloseWordStatus = Document.parentWindow.closeWord.value
End Sub
Document.parentWindow.closeWord.onclick = GetRef("CloseWord")
Function ClosingWindow 'переопределяем ф-цию ClosingWindow
ProcessStatus = False
If Not CloseWordStatus = "" Then
NewDoc.Close 0 ' Word.WdSaveOptions.wdDoNotSaveChanges
MSWord.Quit(False)
End If
End Function
PastClipboard 'запускаем обработчик
'==================================================================================================
'END MAIN
'==================================================================================================
Do ' ожидание закрытия окна HTA
WScript.Sleep 100
If ExitDo Then 'обрабатываем событие закрытия окна программы
ClosingWindow
End If
Loop Until ExitDo
'==================================================================================================
'==================================================================================================
'APP WINDOW
Function GetOHTA( Width, Height, Title, BgColor )
Dim oDict, oHTA
Set oDict = CreateObject("Scripting.Dictionary")
oDict.Add "CONTEXTMENU", "no"
oDict.Add "INNERBORDER", "no"
oDict.Add "SCROLL", "no"
oDict.Add "BORDER", "dialog"
oDict.Add "BORDERSTYLE", "raised"
oDict.Add "MAXIMIZEBUTTON", "no"
oDict.Add "MINIMIZEBUTTON", "no"
Set oHTA = GetHTADialog(oDict)
If oHTA Is Nothing Then
WScript.Echo "Не удалось получить связь с окном HTA."
WScript.Quit
End If
' назначаем обработчик события выгрузки (закрытия) формы
oHTA.document.body.onunload = GetRef("HTA_OnUnload")
' задаём размеры формы
oHTA.document.parentWindow.resizeTo Width, Height
'oHTA.document.parentWindow.resizeTo 350, 320
' задаём заголовок окна
oHTA.document.title = Title
' задаём цвет фона
oHTA.document.getElementsByTagName("body")(0).bgcolor = BgColor
'возвращаем
Set GetOHTA = oHTA
End Function
'==================================================================================================
Function GetHTADialog(ByRef Params)
Dim oFSO, oWshShell, oWindows, oTextStream, oWnd, oWindow
Dim sHTAFileName, ID, N
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oWshShell = CreateObject("WScript.Shell")
Set oWindows = CreateObject("Shell.Application").Windows
' формирование имени будущего файла HTA
sHTAFileName = oWshShell.ExpandEnvironmentStrings("%TEMP%") & "\" & oFSO.GetTempName() & ".hta"
' создание файла HTA
Set oTextStream = oFSO.CreateTextFile(sHTAFileName, True)
' заполнение файла HTA
With oTextStream
.WriteLine "<HTML><HEAD>"
.WriteLine "<OBJECT classid=""clsid:8856F961-340A-11D0-A96B-00C04FD705A2"""
.WriteLine " id=""WebBrowserTemplate"" width=""0"" height=""0""></OBJECT>"
.WriteLine "<OBJECT id=""MSScriptControl"" style=""display:none"" classid=""clsid:0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC"">"
.WriteLine " <PARAM name=""AllowUI"" value=1><PARAM name=""UseSafeSubSet"" value=1></OBJECT>"
.WriteLine "<TITLE></TITLE>"
.WriteLine "<SCRIPT language=vbscript>"
.WriteLine "If IsObject(window) Then"
.WriteLine " window.attachevent ""onload"", GetRef(""Main"")"
.WriteLine " document.attachevent ""onkeydown"", GetRef(""Document_onkeydown_event"")"
.WriteLine "End If"
.WriteLine "Sub Main"
.WriteLine " CommandLine = Document.all.tags(""APPLICATION"")(0).CommandLine"
.WriteLine " Pos = InstrRev(CommandLine, "" "")"
.WriteLine " CommandLine = Mid(CommandLine, Pos + 1, Len(CommandLine) - Pos)"
.WriteLine " If CommandLine = """" Then Exit Sub"
.WriteLine " Set WebBrowser = Document.GetElementById(""WebBrowserTemplate"")"
.WriteLine " WebBrowser.RegisterAsBrowser = True"
.WriteLine " WebBrowser.style.display = ""none"""
.WriteLine " WebBrowser.RegisterAsDropTarget = False"
.WriteLine " WebBrowser.Visible = False"
.WriteLine " WebBrowser.PutProperty ""ID"", Clng(CommandLine)"
.WriteLine " WebBrowser.PutProperty ""HWND"", MSScriptControl.SiteHwnd"
.WriteLine "End Sub"
.WriteLine "Function Document_onkeydown_event"
.WriteLine " If window.event.keycode = 27 Then window.close()" ' закрытие по Esc
.WriteLine " If window.event.keycode = 116 Then Document_onkeydown_event = false" ' блокировка F5 (refresh)
.WriteLine "End Function"
.WriteLine "</SCRIPT>"
.WriteLine "<HTA:APPLICATION"
.WriteLine "APPLICATIONNAME=""" & Params.Item("APPLICATIONNAME") & """"
If Params.Exists("BORDER") Then
.WriteLine "BORDER=""" & Params.Item("BORDER") & """"
Else
.WriteLine "BORDER=""thick"""
End If
If Params.Exists("BORDERSTYLE") Then
.WriteLine "BORDERSTYLE=""" & Params.Item("BORDERSTYLE") & """"
Else
.WriteLine "BORDERSTYLE=""normal"""
End If
If Params.Exists("CAPTION") Then
.WriteLine "CAPTION=""" & Params.Item("CAPTION") & """"
Else
.WriteLine "CAPTION=""yes"""
End If
If Params.Exists("CONTEXTMENU") Then
.WriteLine "CONTEXTMENU=""" & Params.Item("CONTEXTMENU") & """"
Else
.WriteLine "CONTEXTMENU=""yes"""
End If
If Params.Exists("ICON") Then
.WriteLine "ICON=""" & Params.Item("ICON") & """"
Else
.WriteLine "ICON=""System Application Icon"""
End If
If Params.Exists("INNERBORDER") Then
.WriteLine "INNERBORDER=""" & Params.Item("INNERBORDER") & """"
Else
.WriteLine "INNERBORDER=""yes"""
End If
If Params.Exists("MAXIMIZEBUTTON") Then
.WriteLine "MAXIMIZEBUTTON=""" & Params.Item("MAXIMIZEBUTTON") & """"
Else
.WriteLine "MAXIMIZEBUTTON=""yes"""
End If
If Params.Exists("MINIMIZEBUTTON") Then
.WriteLine "MINIMIZEBUTTON=""" & Params.Item("MINIMIZEBUTTON") & """"
Else
.WriteLine "MINIMIZEBUTTON=""yes"""
End If
If Params.Exists("NAVIGABLE") Then
.WriteLine "NAVIGABLE=""" & Params.Item("NAVIGABLE") & """"
Else
.WriteLine "NAVIGABLE=""no"""
End If
If Params.Exists("SCROLL") Then
.WriteLine "SCROLL=""" & Params.Item("SCROLL") & """"
Else
.WriteLine "SCROLL=""yes"""
End If
If Params.Exists("SCROLLFLAT") Then
.WriteLine "SCROLLFLAT=""" & Params.Item("SCROLLFLAT") & """"
Else
.WriteLine "SCROLLFLAT=""no"""
End If
If Params.Exists("SELECTION") Then
.WriteLine "SELECTION=""" & Params.Item("SELECTION") & """"
Else
.WriteLine "SELECTION=""yes"""
End If
If Params.Exists("SHOWINTASKBAR") Then
.WriteLine "SHOWINTASKBAR=""" & Params.Item("SHOWINTASKBAR") & """"
Else
.WriteLine "SHOWINTASKBAR=""yes"""
End If
If Params.Exists("SINGLEINSTANCE") Then
.WriteLine "SINGLEINSTANCE=""" & Params.Item("SINGLEINSTANCE") & """"
Else
.WriteLine "SINGLEINSTANCE=""no"""
End If
If Params.Exists("SYSMENU") Then
.WriteLine "SYSMENU=""" & Params.Item("SYSMENU") & """"
Else
.WriteLine "SYSMENU=""yes"""
End If
If Params.Exists("VERSION") Then
.WriteLine "VERSION=""" & Params.Item("VERSION") & """"
Else
.WriteLine "VERSION=""1.0"""
End If
If Params.Exists("WINDOWSTATE") Then
.WriteLine "WINDOWSTATE=""" & Params.Item("WINDOWSTATE") & """"
Else
.WriteLine "WINDOWSTATE=""normal"""
End If
If Params.Exists("ID") Then
.WriteLine "ID=""" & Params.Item("ID") & """"
Else
.WriteLine "ID=""oHTA"""
End If
.WriteLine "/>"
.WriteLine "</HEAD><BODY></BODY></HTML>"
.Close
End With
Randomize
ID = Clng(Rnd * 100000)
oWshShell.Run sHTAFileName & " " & ID
' поиск окна HTA
Set oWnd = Nothing
For N = 1 to 5000
For Each oWindow in oWindows
If oWindow.GetProperty("ID") = ID Then
Set oWnd = oWindow
Exit For
End If
Next
If Not oWnd Is Nothing Then Exit For
WScript.Sleep 100
Next
' удаление файла HTA
oFSO.DeleteFile sHTAFileName, True
' возвращаем ссылку на окно HTA
Set GetHTADialog = oWnd
End Function
