Тема: VBScript: вывод текста поверх обоев Рабочего стола
Требования: установленные компоненты GFLAx и DynamicWrapperX.
Option Explicit
Const OUTLINE = &H0002 ' Ореол
Dim strText
strText = _
"Нас мотает от края до края —" & vbCrLf & _
"По краям расположены двери:" & vbCrLf & _
"На последней написано «Знаю»," & vbCrLf & _
"А на первой написано «Верю»." & vbCrLf & _
"" & vbCrLf & _
"И одной головой обладая," & vbCrLf & _
"Никогда не войдёшь в обе двери:" & vbCrLf & _
"Если веришь — то вершь, не зная," & vbCrLf & _
"Если знаешь — то знаешь, не веря." & vbCrLf & _
"" & vbCrLf & _
"И своё формируя сознанье," & vbCrLf & _
"С каждым днём от момента рожденья" & vbCrLf & _
"Мы бредём по дороге познанья," & vbCrLf & _
"А с познаньем приходит сомненье." & vbCrLf & _
"" & vbCrLf & _
"И загадка останется вечной," & vbCrLf & _
"Не помогут учёные лбы:" & vbCrLf & _
"Если знаем — ничтожно слабы," & vbCrLf & _
"Если верим — сильны бесконечно." & vbCrLf & _
"" & vbCrLf & _
" * * *" & vbCrLf & _
"" & vbCrLf & _
"И выше любого хотенья," & vbCrLf & _
"Сильнее любого знанья, —" & vbCrLf & _
"Вечное жизни цветение" & vbCrLf & _
"И вечное умиранье…"
SetWallpaper _
"C:\Temp\background.bmp", _
30, _
20, _
strText, _
RGB(255, 255, 64), _
"Times New Roman", _
"20", _
True, _
True, _
OUTLINE, _
RGB(32, 32, 32), _
True
WScript.Quit 0
'=============================================================================
'=============================================================================
' Процедура SetWallpaper
'
' strPath2SourceWallpaper : Полный путь к исходному графическому файлу
' intMarginRight : Поле от правого края изображения до текста
' intMarginBottom : Поле от нижнего края изображения до текста
' strText : Текст
' lngTextColor : Цвет текста
' strFontName : Шрифт
' intFontSize : Размер шрифта
' boolFontBold : Жирный (True/False)
' boolFontItalic : Курсив (True/False)
' intShadow : Тень текста (0 — без тени, 1 — обычная тень, 2 — ореол)
' lngShadowColor : Цвет тени текста
' boolBlur : Размытие изображения (True/False)
'=============================================================================
Sub SetWallpaper( _
strPath2SourceWallpaper, _
intMarginRight, intMarginBottom, _
strText, lngTextColor, _
strFontName, intFontSize, boolFontBold, boolFontItalic, _
intShadow, lngShadowColor, _
boolBlur _
)
Const SPIF_UPDATEINIFILE = &H0001
Const SPIF_SENDCHANGE = &H0002
Const SPI_SETDESKWALLPAPER = &H0014
Const WINDOWS = &H0000
Const NONE = &H0000 ' Нет тени
Const SHADOW = &H0001 ' Тень
Const OUTLINE = &H0002 ' Ореол
Dim objGflAx
Dim objFSO
Dim objDynamicWrapperX
Dim strPath2DestWallpaper
Dim intStringWidth
Dim intStringHeight
Dim intStringMaxWidth
Dim arrText
Dim i
Dim x
Dim y
Set objGflAx = WScript.CreateObject("GflAx.GflAx")
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set objDynamicWrapperX = WScript.CreateObject("DynamicWrapperX")
objDynamicWrapperX.Register "user32.dll", "SystemParametersInfoW", "i=uuwu", "r=l"
strPath2DestWallpaper = objFSO.BuildPath(objFSO.GetSpecialFolder(WINDOWS), "MyBackground.bmp")
With objGflAx
.LoadBitmap strPath2SourceWallpaper
If boolBlur Then
.GaussianBlur 10
End If
.FontName = strFontName
.FontSize = intFontSize
.FontBold = boolFontBold
.FontItalic = boolFontItalic
.FontAntialias = True
arrText = Split(strText, vbCrLf)
' Вычисляем длину самой длинной строки текста
intStringMaxWidth = .GetTextWidth(arrText(LBound(arrText)))
For i = LBound(arrText) + 1 To UBound(arrText)
intStringWidth = .GetTextWidth(arrText(i))
If intStringWidth > intStringMaxWidth Then
intStringMaxWidth = intStringWidth
End If
Next
For i = UBound(arrText) To LBound(arrText) Step -1
intStringHeight = .GetTextHeight(arrText(i))
x = .width - (intStringMaxWidth + intMarginRight )
y = .height - (intStringHeight * (UBound(arrText) - i + 1) + intMarginBottom)
Select Case intShadow
Case NONE
Case SHADOW
.TextOut arrText(i), x + 1, y + 1, lngShadowColor
Case OUTLINE
.TextOut arrText(i), x + 1, y + 1, lngShadowColor
.TextOut arrText(i), x + 1, y - 1, lngShadowColor
.TextOut arrText(i), x - 1, y + 1, lngShadowColor
.TextOut arrText(i), x - 1, y - 1, lngShadowColor
Case Else
End Select
.TextOut arrText(i), x, y, lngTextColor
Next
.SaveBitmap strPath2DestWallpaper
' Устанавливаем в качестве обоев сохранённый графический файл
objDynamicWrapperX.SystemParametersInfoW SPI_SETDESKWALLPAPER, 0, strPath2DestWallpaper, SPIF_UPDATEINIFILE Or SPIF_SENDCHANGE
End With
Set objDynamicWrapperX = Nothing
Set objFSO = Nothing
Set objGflAx = Nothing
End Sub
'=============================================================================
Пример берёт файл "C:\Temp\background.bmp", вставляет в него текст, размещает результат как "C:\WINDOWS\MyBackground.bmp" и делает его обоями Рабочего стола. Пример делает картинку немного размытой, чтобы текст был контрастнее. Это можно легко отключить единственным параметрм (см. комментарии в коде). Если картинка по размеру не совсем подходит под разрешение экрана, часть текста может оказаться невидимой.
Автор примера - alexii.
В названии ветки всегда должен быть указан язык программирования или среда исполнения скрипта, если это возможно.