Серый форум — VBScript: вывод текста поверх обоев Рабочего стола

Re: VBScript: вывод текста поверх обоев Рабочего стола

2008-12-08T16:33:04Z

Развитие предыдущего примера.
* более не используется компонент DynamicWrapperX, вместо него использован вызов функции UpdatePerUserSystemParameters из user32.dll посредством утилиты RUNDLL32.EXE;
* высота строки вычисляется только один раз (одинакова для всех символов, зависит только от шрифта и его размера);
* в примере размытие изображения не производится (при вызове функции SetWallpaper параметр boolBlur установлен == False);
* урезана длина выводимого в примере текста.

Option Explicit

Const OUTLINE              = &H0002    ' Ореол

Dim strText

strText         = _
    "И выше любого хотенья," & vbCrLf & _
    "Сильнее любого знанья, —" & vbCrLf & _
    "Вечное жизни цветение" & vbCrLf & _
    "И вечное умиранье…"


SetWallpaper _
    "C:\Temp\background.bmp", _
    30, _
    20, _
    strText, _
    RGB(255, 255, 64), _
    "Arial", _
    "16", _
    False, _
    False, _
    OUTLINE, _
    RGB(32, 32, 32), _
    False

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 WINDOWS              = &H0000
    
    Const NONE                 = &H0000    ' Нет тени
    Const SHADOW               = &H0001    ' Тень
    Const OUTLINE              = &H0002    ' Ореол
    
    
    Dim objGflAx
    Dim objFSO
    Dim objWshShell
    
    Dim strPath2DestWallpaper
    
    Dim intStringWidth
    Dim intStringMaxWidth
    Dim intStringMaxHeight
    
    Dim arrText
    Dim i
    Dim x
    Dim y
    
    
    Set objGflAx           = WScript.CreateObject("GflAx.GflAx")
    Set objFSO             = WScript.CreateObject("Scripting.FileSystemObject")
    Set objWshShell        = WScript.CreateObject("WScript.Shell")
    
    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)
        
        intStringMaxHeight = .GetTextHeight(arrText(LBound(arrText)))
        ' Вычисляем длину самой длинной строки текста
        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
            x = .width  - (intStringMaxWidth                              + intMarginRight )
            y = .height - (intStringMaxHeight * (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
        
        ' Устанавливаем в качестве обоев сохранённый графический файл
        objWshShell.RegWrite "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper", strPath2DestWallpaper, "REG_SZ"
        objWshShell.Run """%SystemRoot%\System32\RUNDLL32.EXE"" user32.dll,UpdatePerUserSystemParameters", 0, True
    End With
    
    Set objWshShell        = Nothing
    Set objFSO             = Nothing
    Set objGflAx           = Nothing
End Sub
'=============================================================================

Автор примера - alexii.

VBScript: вывод текста поверх обоев Рабочего стола

2008-11-28T15:28:46Z

Требования: установленные компоненты 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.