Тема: HTA: COM-сервер для HTA
Уважаемые формучане. По мотивам общения на форуме появилась идея написать библиотеку по теме: "Все, что я хотел от HTA, но боялся спросить" 
.
На текуший момент с помощью библиотеки можно:
- создавать, изменять, удалять иконку приложения в трее и всплывающую подсказку к ней
- изменять размер и отображение окна, делать окно приложения поверх всех
- получать дескриптор окна (как же без него)
Работа с иконкой: щелчок правой кнопкой мыши скрывает окно приложения, левой - открывает, двойной щелчок левой кнопкой мыши делает окно приложения поверх всех, двойной щелчок правой - отменяет поверх всех.
Что получилось на текущий момент - на скриншоте. Скачать можно здесь. В архиве: библиотека, HTA и пара иконок для теста.
Исходный код HTA - наглядная демонстрация методов COM-объекта, а также приемов работы с библиотекой:
<html>
<head>
<title>DAHTACOM</title>
<HTA:APPLICATION
ID = "DAHTACOM"
APPLICATIONNAME="DAHTACOM"
SINGLEINSTANCE="yes"
MAXIMIZEBUTTON = "no"
SCROLL="no"
ShowInTaskbar ="no"
BORDER="none"
SELECTION="no"
Version = "1.0">
</HTA:APPLICATION>
</head>
<style type="text/css">
html, body{
margin:0;
padding:0;
width:100%;
height:100%;
background-color:66ff99;
}
#txt{
color:#fff;
background-color:009999;
text-align: center;
font:bold 28 sans-serif;
width:350px;
height:310px;
position:absolute;
top:50%;
left:50%;
margin:-155px 0 0 -175px;
}
</style>
<script language="VBScript">
On Error Resume Next
Const LibName = "DAHTACOM.dll"
Const IconName = "daffodil-16x16-256.ico"
Const TipText = "Всплывающая подсказка"
Const NewTipText = "Новая подсказка"
Dim x0, y0
Set wshShell = CreateObject("WScript.Shell")
'копируем библиотеку в католог Windows
'если копирование не удастся - библиотека зарегистрируется из текущего каталога
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(wshShell.CurrentDirectory & "\" & LibName) Then
fso.CopyFile wshShell.CurrentDirectory & "\" & LibName, _
fso.GetSpecialFolder(0) & "\" & LibName, True
Else
MsgBox "Не найден файл " & strDll,vbExclamation,"Ошибка"
window.close
End If
'пытаемся зарегистрировать библиотеку
intRet = RegLib(True)
If intRet Then
Set objDAHTA = CreateObject("DAHTACOM.DAHTAClass")
'в случае регистрации библиотеки из текущего каталога - работы portable
'иногда вылетает ошибка - экземпляр класса создается не с первого раза
If Err.Number <> 0 Then window.close
'создаем иконку
objDAHTA.AddIcon document.title, IconName, TipText, True
Else
MsgBox "Не удалось зарегистрировать библиотеку " & strDll,vbExclamation,"Ошибка"
window.close
End If
Sub Window_OnLoad()
SetUpEventHandler()
End Sub
Sub Window_OnUnload()
objDAHTA.DelIcon 'удаляем иконку
Set objDAHTA = Nothing
intRet = RegLib(False)
Set fso = Nothing
Set wshShell = Nothing
window.close
End Sub
'регистрация библиотеки, True - регистрируем, False - разрегистрируем
Function RegLib(bReg)
Dim strReg
If bReg Then
strReg = "regsvr32.exe /i /s "
Else
strReg = "regsvr32.exe u/ /i /s "
End If
intRet = wshShell.Run(strReg & LibName)
If intRet = 0 Then 'если удалось зарегистрировать - True
RegLib = True
Else
RegLib = False
End If
End Function
Sub SetUpEventHandler()
Set EHMouseDown = GetRef("MouseDownEvent")
Set EHMouseMove = GetRef("MouseMoveEvent")
document.attachEvent "onmousedown", EHMouseDown
document.attachEvent "onmousemove", EHMouseMove
Set MouseOverClose = GetRef("MouseOverCloseSub")
closetxt.attachEvent "onmouseover", MouseOverClose
Set CloseOnclick = GetRef("OnClickCloseSub")
closetxt.attachEvent "onclick", CloseOnclick
Set MaxOnclick = GetRef("OnClickMaxSub")
maxtxt.attachEvent "onclick", MaxOnclick
Set MouseOverMax = GetRef("MouseOverMaxSub")
maxtxt.attachEvent "onmouseover", MouseOverMax
Set MouseOverRestore = GetRef("MouseOverRestoreSub")
restoretxt.attachEvent "onmouseover", MouseOverRestore
Set RestoreOnclick = GetRef("OnClickRestoreSub")
restoretxt.attachEvent "onclick", RestoreOnclick
Set MouseOverHide = GetRef("MouseOverHideSub")
hidetxt.attachEvent "onmouseover", MouseOverHide
Set HideOnclick = GetRef("OnClickHideSub")
hidetxt.attachEvent "onclick", HideOnclick
Set MouseOverMin = GetRef("MouseOverMinSub")
mintxt.attachEvent "onmouseover", MouseOverMin
Set MinOnclick = GetRef("OnClickMinSub")
mintxt.attachEvent "onclick", MinOnclick
Set MouseOverSetTop = GetRef("MouseOverSetTopSub")
settoptxt.attachEvent "onmouseover", MouseOverSetTop
Set SetTopOnclick = GetRef("OnClickSetTopSub")
settoptxt.attachEvent "onclick", SetTopOnclick
Set MouseOverUnSetTop = GetRef("MouseOverUnSetTopSub")
unsettoptxt.attachEvent "onmouseover", MouseOverUnSetTop
Set UnSetTopOnclick = GetRef("OnClickUnSetTopSub")
unsettoptxt.attachEvent "onclick", UnSetTopOnclick
Set MouseOverHandle = GetRef("MouseOverHandleSub")
handletxt.attachEvent "onmouseover", MouseOverHandle
Set HandleOnclick = GetRef("OnClickHandleSub")
handletxt.attachEvent "onclick", HandleOnclick
Set MouseOverModIcon = GetRef("MouseOverModIconSub")
modicontxt.attachEvent "onmouseover", MouseOverModIcon
Set ModIconOnclick = GetRef("OnClickModIconSub")
modicontxt.attachEvent "onclick", ModIconOnclick
End Sub
Function MouseDownEvent()
'1 - левая кнопка, 4 - средняя, 2 - правая
If window.event.button = 2 Then
x0=window.event.x
y0=window.event.y
End If
End Function
Function MouseMoveEvent()
If window.event.button = 2 Then 'если нажата правая кнопка
window.moveBy window.event.x-x0, window.event.y-y0
End If
End Function
Sub MouseOverCloseSub()
closetxt.Style.Cursor = "hand"
End Sub
Sub MouseOverMaxSub()
maxtxt.Style.Cursor = "hand"
End Sub
Sub OnClickCloseSub()
Window_OnUnload
End Sub
Sub OnClickMaxSub()
objDAHTA.MaxWnd document.title
End Sub
Sub OnClickRestoreSub()
objDAHTA.RestoreWnd document.title
End Sub
Sub MouseOverRestoreSub()
restoretxt.Style.Cursor = "hand"
End Sub
Sub MouseOverHideSub()
hidetxt.Style.Cursor = "hand"
End Sub
Sub OnClickHideSub()
objDAHTA.HideWnd document.title
End Sub
Sub MouseOverMinSub()
mintxt.Style.Cursor = "hand"
End Sub
Sub OnClickMinSub()
objDAHTA.MinWnd document.title
End Sub
Sub MouseOverSetTopSub()
settoptxt.Style.Cursor = "hand"
End Sub
Sub OnClickSetTopSub()
objDAHTA.SetTop document.title
End Sub
Sub MouseOverUnSetTopSub()
unsettoptxt.Style.Cursor = "hand"
End Sub
Sub OnClickUnSetTopSub()
objDAHTA.UnSetTop document.title
End Sub
Sub MouseOverHandleSub()
handletxt.Style.Cursor = "hand"
End Sub
Sub OnClickHandleSub()
MsgBox objDAHTA.GetHandle(document.title)
End Sub
Sub MouseOverModIconSub()
modicontxt.Style.Cursor = "hand"
End Sub
Sub OnClickModIconSub()
mesaga = InputBox("Введите имя файла новой иконки",,"warn-16x16-256.ico")
If fso.FileExists(wshShell.CurrentDirectory & "\" & mesaga) Then
objDAHTA.AddIcon document.title, mesaga, NewTipText, False
End If
End Sub
</script>
<body>
<div id="txt">
<div id="modicontxt">Изменить иконку</div>
<div id="handletxt">Дескриптор окна</div>
<div id="maxtxt">Во весь экран</div>
<div id="restoretxt">Нормальный размер</div>
<div id="settoptxt">Поверх всех окон</div>
<div id="unsettoptxt">Отменить поверх всех</div>
<div id="mintxt">Свернуть</div>
<div id="hidetxt">Скрыть</div>
<div id="closetxt">Закрыть</div>
</div>
</body>
</html>Приглашаю всех, кого заинтересовала тема, тестировать библиотеку, вносить предложения по расширению функционала и просто высказывать свое мнение.
А что Вы хотите от HTA, но не можете получить?
