Никому не понравился мой вариант трансформации цвета? Если лениво копипастить - можно скачать.
В архиве 2 варианта: с синего и зеленого на красный. Интересно же получилось 
.
В продолжение темы с подачи и, надеюсь, позволения уважаемого автора нарисовал HTML-приложение для мониторинга ресурсов системы: физической и виртуальной памяти, файла подкачки и загрузки процессора. С "игрой цветом", "поверх всех окон" и пр.
Чисто для себя сделал. Поясню почему процессор добавил (все же с памяти началось).
У меня на рабочем ноуте 2 Гига оперативы и проц Селерон 1.8. Когда начал писать в Visual Studio 2010 проекты приложений баз данных на - ADO - Entity Framework - ASP - Silverlight и прочей мелкомягкой технологии, обратил внимание, что в процессе отладки ноуту становится плохо. Сначала думал на оперативу, файл подкачки увеличил, а потом просек, что оперативы используется чуть больше гига, а грузится процессор. Может у кого подобная проблема будет, этой приладой можно просечь .
Что касается кода, хочу указать на принципиальные отличия от кода автора:
- в большинстве отказался от функции Round, т.к. по-моему Int работает быстрее
- полностью отказался от метода Instances_, т.к. в коде ни к чему все свойства вызываемых объектов, кроме того в WQL можно использовать полусинхронные запросы, что также увеличивает производительность
Для вывода окна поверх всех написал, как обычно, простенькую библиотеку, содержащую всего две API-функции:
Option Explicit
'API-функция получения дескриптора окна
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpszClassName As String, ByVal lpszWindow As String) As Long
'API-функция установки позиции окна
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'получаем дескриптор
Public Function GetHandle(ByVal strCaption As String) As Long
GetHandle = FindWindow(vbNullString, strCaption)
End Function
'устанавливаем окно поверх всех
Public Sub SetTop(ByVal strCaption As String)
SetWindowPos FindWindow(vbNullString, strCaption), -1, 0, 0, 0, 0, 3
End Sub
Кстати, на счет библиотеки. В этот раз я кажется решил проблему возможных косяков при повторной регистрации. По-моему лучше разрегистрировать библиотеку при выгрузке приложения. Возразите, может ошибаюсь.
А вот исходник HTA:
<html>
<head>
<title>ResMon</title>
<HTA:APPLICATION
ID = "ResMon"
APPLICATIONNAME="ResMon"
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:1px;
text-align: center;
font:bold 12 sans-serif;
border-style: outset;
color: #ffffff;
}
#header{
background-color: #800000;
}
</style>
<script language="VBScript">
Option Explicit
Const strHash = "#"
Const strHeader = "Объем свободных ресурсов"
Const strDll = "WinPos.dll"
'--- запросы
Const strOSQ = "Select FreePhysicalMemory, FreeVirtualMemory, TotalVirtualMemorySize From Win32_OperatingSystem"
Const strPMQ = "Select Capacity From Win32_PhysicalMemory"
Const strPFUQ = "Select AllocatedBaseSize, CurrentUsage From Win32_PageFileUsage"
Const strPQ = "Select LoadPercentage From Win32_Processor"
Const intPSF = 48 'флаг полусинхронности
'-------
Dim objItem
Dim intTotal, intFreePart, intFreePartV, intFreePartP, intProcRate, intFreePartProc
Dim intOSInfoArr(2), intOSInfo
Dim intPFUInfoArr(1), intPFUInfo
Dim i, intRet
Dim objWMI, wshShell
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set wshShell = CreateObject("WScript.Shell")
Sub Window_OnLoad()
Dim objSetTop
window.resizeTo 245,80
window.moveTo screen.availWidth-255, screen.availHeight-90
'пытаемся зарегистрировать библиотеку
intRet = RegLib(True)
If intRet Then
'создаем экземпляр класса из либы = strDll
Set objSetTop = CreateObject("WinPos.WPClass")
'делаем окно поверх всех окон
objSetTop.SetTop document.title
'удаляем ссылку
Set objSetTop = Nothing
Else
wshShell.PopUp "Не удалось зарегистрировать библиотеку " & strDll,1,"Ошибка регистрации",48
End If
header.Innertext = strHeader
window.setTimeout "UpdateInfo", 1, "vbscript"
End Sub
Sub Window_OnUnload()
RegLib(False)
Set wshShell = Nothing
Set objWMI = Nothing
End Sub
Sub UpdateInfo()
'информация из Win32_OperatingSystem: свободная физическая память,
'свободная виртуальная память, полный объем виртуальной памяти
intOSInfo = GetOSInfo()
intTotal = GetTotalMemorySize() 'полный объем физической памяти
intPFUInfo = GetPFUInfo() 'информация о файле подкачки
intProcRate = GetProcRate() 'процент свободного времени процессоров
'процент свободной памяти в масштабе изменения RGB
intFreePart = Round(intOSInfo(0)/intTotal*255) 'физической
intFreePartV = Round(intOSInfo(1)/intOSInfo(2)*255) 'виртуальной
intFreePartP = intPFUInfo(0)/intPFUInfo(1)*255 'подкачки
intFreePartProc = intProcRate*2.55 'процессоры
'выводим количество памяти
fpRAM.Innertext = intOSInfo(0)
tpRAM.Innertext = intTotal
fvRAM.Innertext = intOSInfo(1)
tvRAM.Innertext = intOSInfo(2)
fswap.Innertext = intPFUInfo(0)
tswap.Innertext = intPFUInfo(1)
procrate.Innertext = intProcRate
'выставляем цвет окна: "#" + R + G + B, вариант от синего к красному
window.document.getElementById("pRAM").style.backgroundColor = strHash & _
GetStrHex(255-intFreePart) & GetStrHex(0) & GetStrHex(intFreePart)
'вариант от зеленого к красному, прочие варианты - по аналогии
window.document.getElementById("vRAM").style.backgroundColor = strHash & _
GetStrHex(255-intFreePartV) & GetStrHex(intFreePartV) & GetStrHex(0)
'снова от синего - подкачка
window.document.getElementById("swap").style.backgroundColor = strHash & _
GetStrHex(255-intFreePartP) & GetStrHex(0) & GetStrHex(intFreePartP)
'снова от зеленого - процессор
'MsgBox intProcRate & vbCrLf & strHash & _
' GetStrHex(255-intFreePartProc) & GetStrHex(intFreePartProc) & GetStrHex(0)
window.document.getElementById("proc").style.backgroundColor = strHash & _
GetStrHex(255-intFreePartProc) & GetStrHex(intFreePartProc) & GetStrHex(0)
window.SetTimeout "UpdateInfo()", 1000, "vbscript"
End Sub
Function GetOSInfo()
Dim colOS
Set colOS = objWMI.ExecQuery(strOSQ,,intPSF)
For Each objItem In colOS
With objItem
intOSInfoArr(0) = Int(.FreePhysicalMemory/1024)
intOSInfoArr(1) = Int(.FreeVirtualMemory/1024)
intOSInfoArr(2) = Round(.TotalVirtualMemorySize/1024)
End With
Next
Set colOS = Nothing
GetOSInfo = intOSInfoArr
End Function
'получаем объем физической памяти
Function GetTotalMemorySize()
Dim colPM
Set colPM = objWMI.ExecQuery(strPMQ,,intPSF)
For Each objItem In colPM
GetTotalMemorySize = GetTotalMemorySize + Int(objItem.Capacity/1024/1024)
Next
Set colPM = Nothing
End Function
'получаем объем файла подкачки
Function GetPFUInfo()
Dim colPFL
Set colPFL = objWMI.ExecQuery(strPFUQ,,intPSF)
For Each objItem In colPFL
With objItem
'свободно = объем - использовано
intPFUInfoArr(0) = .AllocatedBaseSize - .CurrentUsage
intPFUInfoArr(1) = .AllocatedBaseSize 'объем
End With
Next
Set colPFL = Nothing
GetPFUInfo = intPFUInfoArr
End Function
'получаем процент загрузки процессоров
Function GetProcRate()
Dim colP
Set colP = objWMI.ExecQuery(strPQ,,intPSF)
i = 0
For Each objItem In colP
i = i + 1
GetProcRate = GetProcRate + objItem.LoadPercentage
Next
'вычисляем среднее арифметическое на случай, если процессоров несколько
GetProcRate = 100-(GetProcRate/i)
Set colP = Nothing
End Function
'переводим число из RGB в Hex для HTML
Function GetStrHex(i)
If i < 16 Then
GetStrHex = "0" & Hex(i)
Else
GetStrHex = Hex(i)
End If
End Function
'регистрация библиотеки, True - регистрируем, False - разрегистрируем
Function RegLib(bWha)
Dim strWha
If bWha Then
strWha = "regsvr32.exe /i /s "
Else
strWha = "regsvr32.exe u/ /i /s "
End If
intRet = wshShell.Run(strWha & strDll )
If intRet = 0 Then 'если удалось зарегистрировать - True
RegLib = True
Else
RegLib = False
End If
End Function
</script>
<body>
<div id="header"></div>
<div id="pRAM">
Физическая память:  <span id="fpRAM"></span>  из  <span id="tpRAM"></span>  MB
</div>
<div id="vRAM">
Виртуальная память:  <span id="fvRAM"></span>  из  <span id="tvRAM"></span>  MB
</div>
<div id="swap">
Файл подкачки:  <span id="fswap"></span>  из  <span id="tswap"></span>  MB
</div>
<div id="proc">
Процессоры:  <span id="procrate"></span>  из 100%
</div>
</body>
</html>
Ваши комменты .
.
