设置Windows系统登录背景图片

'设置系统登录时背景图片。瘟十锁屏界面图片和登录图片不是一回事儿

'原理：
'瘟十通过组策略实现：
'1、计算机配置\管理模板\控制面板\个性化\强制显示特定默认锁屏界面图像和登录图像；
'2、计算机配置\管理模板\控制面板\个性化\阻止更改锁定界面图像和登录图像；
'3、使用本程序，不要再用手工对上述1、2组策略进行设置，如果设置过请改为“未设置”，否则在瘟十下无效果。
'瘟七通过修改注册表和图片文件实现。

'编译：
'   代码专门为32位exe运行设计，直接编译为32位exe；
'   编译为32位系统可执行文件，可在64位系统下运行；
'   编译为64位系统，需修改代码。修改位置1处，有说明；编译后只能在64位系统运行
'   不编译，VBS源代码运行，不存在系统位数问题。

'代码设计：张富贵儿 [email protected]
'源代码：VBS
'运行：直接运行，也可以编译成exe文件运行。
'移植：稍稍修改，就可以在VB6下运行
'
'--------------------↓↓↓↓-----代码开始-----↓↓↓↓---------------

Dim OSName,OSBit,OSVer   'OSName=操作系统全称,OSVer=操作系统版本号,OSBit操作系统位数
Dim SilentFlag  '静默参数
Dim SysDirName  'c:\windows\System32目录

SysDirName="C:\Windows\System32\" '系统目录
SilentFlag=0  '等于1静默执行

OsInfo  OSName,OSBit,OSVer  '获取操作系统信息

SetSystem32Dir         '■■■■■■编译32位exe，在64位系统下运行。如果要编译成64位可执行文件，注释掉本行即可■■■■■■■

MainProgram            '主程序
ReGpUpdate             '刷新组策略

Sub ReGpUpdate
    '刷新组策略
    Set LqxkjsjShell = CreateObject("Wscript.Shell")
    LqxkjsjShell.Run "gpupdate.exe /force",0,ture   '刷新组策略
    
    WScript.Sleep 8000    '等8秒，因为组策略刷新需要时间
    
    '再以管理员方式刷一遍组策略，万恶的瘟十，有时候往往需要刷n遍才有效果
    Set FkLSN=CreateObject("Shell.Application")
    FkLSN.ShellExecute SysDirName & "\gpupdate.exe", "/force",SysDirName , "runas", 0  '刷新组策略
    
End Sub

Sub MainProgram
    If OSVer<6 Or OSVer>10 Then
        MsgBox "本程序只适合在瘟七、瘟十系统上使用。",48,"不适用"
        WScript.Quit
    End If   
    ImageFilesCount=0
    If WScript.Arguments.count=0 Then  '运行时不带参数
        Lshnnk= "使用方法：" & Chr(10) & Chr(10) & _
        " 1、直接运行本文件，按【否】取消Windows登录背景图片" & Chr(10) & _
        " 2、将图片文件拖到本文件名上，实现登录背景图片更换"  & Chr(10) & _
        " 3、使用【/s 图片文件名】参数，静默设置登录背景图片" & Chr(10) & _
        " 4、使用【/s 】参数，静默取消登录背景图片"  & Chr(10) & Chr(10)& _
        "    按【是】退出，按【否】取消Windows登录背景图片"
        Set LshnnkShell = CreateObject("Wscript.Shell")
        wdjy=LshnnkShell.Popup (Lshnnk, 27, "设置Windows登录背景图片，27秒后关闭",32+4)
        If wdjy=7 Then
            EscapeLoginImage      '按【否】取消登录背景图片
            Exit Sub
         Else
           WScript.Quit           '退出    
        End If
        
    End If  
    For zxdwshj=0 To WScript.Arguments.count-1      '参数个数，从零开始处理。
        LoginImageFileName=WScript.Arguments(zxdwshj)
        
        If LCase(WScript.Arguments(zxdwshj))="/s"  Then
            SilentFlag=1             '等于1表示要静默
        Else
            If LCase(Right( LoginImageFileName    ,4))=".jpg"  Or LCase(Right( LoginImageFileName    ,4))=".png" Or  _
                LCase(Right( LoginImageFileName    ,4))=".bmp"  Or  LCase(Right( LoginImageFileName    ,4))=".gif" Then        '文件jpg等图片文件
                If CreateObject("Scripting.FileSystemObject").fileExists(LoginImageFileName)=True  Then       '文件存在  
                    Call   SetLoginBackImage  (LoginImageFileName)          '设置登录图片
                    ImageFilesCount=ImageFilesCount+1                        '统计处理图片文件个数
                Else
                    MsgBox "指定图片文件不存在",64,"参数错误"
                    WScript.Quit
                End If     
            Else
                MsgBox "这个文件不是图片文件",64,"文件错误"
                WScript.Quit
            End If 
        End If   
    Next
    If SilentFlag=1 Then 
        Exit Sub          '静默就直接退出
    End If 
    If OSVer=10  Then 
        FuckWin10="万恶的瘟十需要1-5分钟后再查看设置效果，如果没有效果，需要多试几次。"& Chr(10) & Chr(10)
    End If    
    Set WALSN= CreateObject("Wscript.Shell")
    zyqdwshj= "Windows登录背景图片修改工作，已胜利完成。" & Chr(10) & Chr(10) & FuckWin10 & "不忘初心，牢记使命，增强四个意识、坚定四个自信、做到两个维护，构建人类命运共同体。"
    WALSN.Popup zyqdwshj, 27, "27秒后该窗口自动关闭",48
End Sub

Sub EscapeLoginImage
    ' 取消瘟十登录背景图片设置
    If OSVer=10 Then  ' 取消瘟十登录背景图片设置
        '删除注册表
        RegKeyName="HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\Personalization"
        RegValueName=""
        DelParameter="K"
        Call DelRegValue(RegKeyName, RegValueName, DelParameter) '删除一个项和下面所有的内容，瘟十的背景图片
        Exit Sub
    End If 
    
    If OSVer=6 Then  ' 取消瘟七登录背景图片设置
        RegKeyName="HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Authentication\LogonUI\Background" 
        DelParameter="K"
        Call DelRegValue(RegKeyName, RegValueName, DelParameter) '删除一个项和下面所有的内容，瘟七的背景图片
    End If

End Sub

Sub SetLoginBackImage (LoginImageFileName)
    '设置瘟十登录背景图片。
    '若取消，注册表中删除HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\Personalization
    '考虑到编译exe时，32/64位的exe不同。
    '在VBS源代码下，无需考虑32位还是64位。
    ReImageSizePath  LoginImageFileName '设置图片大小和路径
    If OSVer=10 Then  ' 取消瘟十登录背景图片设置
        '设置注册表,相当于组策略：计算机配置\管理模板\控制面板\个性化\强制显示特定默认锁屏界面图像和登录图像:
        RegKeyName="HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\Personalization"
        RegValueName="LockScreenImage"
        RegValue=LoginImageFileName              '图片文件路径
        RegKeyType="REG_SZ"
        Call SetRegValue(RegKeyName, RegValueName,RegValue,RegKeyType)           
        RegValueName="LockScreenOverlaysDisabled"
        RegValue="1"
        RegKeyType="REG_DWORD"
        Call SetRegValue(RegKeyName, RegValueName,RegValue,RegKeyType)           
        '相当于组策略：计算机配置\管理模板\控制面板\个性化\阻止更改锁定界面图像和登录图像：
        RegValueName="NoChangingLockScreen"
        Call SetRegValue(RegKeyName, RegValueName,RegValue,RegKeyType)           
        Exit Sub
    End If
    
    If OSVer=6 Then  ' 瘟七登录背景图片设置
        '瘟七登录背景图片：
        RegKeyName="HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Authentication\LogonUI\Background" 
        RegValueName="OEMBackground"
        RegValue="1"
        RegKeyType="REG_DWORD"
        Call SetRegValue(RegKeyName, RegValueName,RegValue,RegKeyType)   
        
    End If

End Sub

Sub ReImageSizePath (LoginImageFileName)
    '设置图片大小和路径
    ImageFile1=LoginImageFileName
    Set fklsn=WScript.CreateObject("WScript.Shell")    
    If OSVer=6 Then   '瘟七
        '调用系统CMD命令创建目录和子目录
        DirName=SysDirName & "oobe\info\backgrounds"  '目录名称
        
        MakeSubDir="cmd /c md " & DirName 
        Fklsn.Run MakeSubDir,0  ,ture '创建目录
        
        PathName=SysDirName & "oobe"
        SetPathPermissions PathName   '设置权限
        
        PathName=SysDirName & "oobe\info"
        SetPathPermissions PathName   '设置权限
        
        
        PathName=SysDirName & "oobe\info\backgrounds"
        SetPathPermissions PathName   '设置权限
        
        PathName=SysDirName & "oobe\info\backgrounds\backgroundDefault.jpg"
        SetPathPermissions PathName   '设置权限
        
        DirName=SysDirName & "oobe\info\backgrounds"  '目录名称
        
        MakeSubDir="cmd /c md " & DirName 
        Fklsn.Run MakeSubDir,0 ,ture  '创建目录
        
        ImageFile2=SysDirName & "oobe\info\backgrounds\backgroundDefault.jpg"
    End If
    
    If OSVer=10 Then   '瘟十    
        DirName="C:\Windows\Web\Screen"
        SetPathPermissions DirName   '设置权限
        ImageFile2=DirName & "\backgroundDefault.jpg"
        
        SetPathPermissions ImageFile2   '设置权限
        
    End If    
    
    GetScreenResolution x,y   '获取屏幕分辨率
    ImgWidth=CStr(x) 
    ImgHeight=CStr(y)
    
    ImgRatio=False 
    SaveNewFile ImageFile1,ImageFile2,ImgWidth,ImgHeight,ImgRatio
    
    
    LoginImageFileName=ImageFile2
End Sub

Sub SaveNewFile(ImageFile1,ImageFile2,ImgWidth,ImgHeight,ImgRatio)
    '将ImageFile1另存为ImageFile2,宽度为ImgWidth,高度为ImgHeight,锁定纵横比为ImgRatio(取值True或False
    
    
    Set Img = CreateObject("WIA.ImageFile")
    Set Proc = CreateObject("WIA.ImageProcess")
    Img.LoadFile ImageFile1 '打开文件
    
    Proc.Filters.Add Proc.FilterInfos("Scale").FilterID '添加一个Scale的滤境，用来调整纵横比
    Proc.Filters(1).Properties("MaximumWidth")=ImgWidth        '定义新图片的 宽度
    Proc.Filters(1).Properties("MaximumHeight")=ImgHeight      '定义新图片的 高度
    'Proc.Filters(1).Properties("MaximumWidth")="1920"        '定义新图片的  宽度
    'Proc.Filters(1).Properties("MaximumHeight")="1080"        '定义新图片的 高度
    
    Proc.Filters(1).Properties("PreserveAspectRatio") =ImgRatio   '指定原图片纵横比
    'Proc.Filters(1).Properties("PreserveAspectRatio") =True         '保持原图片纵横比
    'Proc.Filters(1).Properties("PreserveAspectRatio") =False     '不保持原图片纵横比

    '如果要转换文件格式的话:
    Proc.Filters.Add Proc.FilterInfos("Convert").FilterID          '添加转换滤镜ID
    Proc.Filters(2).Properties("FormatID").Value = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"    '保存为JPG
    'Proc.Filters(2).Properties("FormatID").Value = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"    '保存为PNG
    'Proc.Filters(2).Properties("FormatID").Value = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"    '保存为BMP
    'Proc.Filters(2).Properties("FormatID").Value = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"    '保存为GIF
    'Proc.Filters(2).Properties("FormatID").Value = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"    '保存为TIF
    
   
    
    Set NewImg = Proc.Apply(Img) '保存新图片到 NewImg 对象里
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Fso.fileExists(ImageFile2)=True  Then       '文件存在  
      
        SetPathPermissions ImageFile2   '设置权限
        
        'aa=MsgBox  ("文件" & ImageFile2 & "已存在 ，覆盖吗？ ",32+4,"文件已存在")
        'If aa=6 Then  '覆盖
        Fso.DeleteFile ImageFile2          '删除文件
        '   Else Exit Sub
        ' End If
        
    End If
    NewImg.SaveFile ImageFile2  '把NewImg对象保存为图片    
    
    JpgSize=Fso.Getfile(ImageFile2).Size
    
    If JpgSize>256000 And OSVer<10 Then  '瘟七要求文件必须是jpg，不大于256K，瘟十没有此要求
        
        Call ReSize256K(ImageFile1,ImageFile2) '调整瘟七图片大小
    End If 
    
    
End Sub

Sub ReSize256K(ImageFile1,ImageFile2)
    '瘟七系统要求登录背景图片文件必须是jpg，小于256K
    '逐渐降低Jpg质量，直到文件小于256K
    
    'ImageFile1 '原始图片文件名
    'ImageFile2 '生成图片  
    NewFileSinz=256000   '图片尺寸
    JPGQuaqlityVal=85    '设置JPG压缩质量起始值为85
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Fso.fileExists(ImageFile2)=True  Then       '文件存在  
        SetPathPermissions ImageFile2   '设置权限
        Fso.DeleteFile ImageFile2          '删除文件
    End If
    
    Do     Until  NewFileSinz<256000  '文件超过256K，就降低jpg图片质量，然后保存，再测试文件大小
        Set Img = CreateObject("WIA.ImageFile")
        Set Proc = CreateObject("WIA.ImageProcess")
        Img.LoadFile ImageFile1 '打开文件
        Proc.Filters.Add Proc.FilterInfos("Convert").FilterID          '添加转换滤镜
        Proc.Filters(1).Properties("FormatID").Value = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"    '保存为JPG
        Proc.Filters(1).Properties("Quality").Value = JPGQuaqlityVal        
        Set NewImg = Proc.Apply(Img) '保存新图片到 NewImg 对象里   
        NewImg.SaveFile ImageFile2  '把NewImg对象保存为图片    
        NewFileSinz= FSO.Getfile(ImageFile2).Size  '文件大小
        If   NewFileSinz>256000 Then
            Set Img =Nothing
            Set Proc =Nothing
            Set NewImg = Nothing
            JPGQuaqlityVal= JPGQuaqlityVal-3   '降低Jpg压缩质量
            SetPathPermissions ImageFile2   '设置权限
            Fso.DeleteFile ImageFile2          '删除文件
        Else
            Exit Do
        End If       
    Loop        
    
End Sub

Sub SetPathPermissions(PathName)
    '设置权限
    ttt="Icacls " & PathName & " /grant everyone:F" 
    CreateObject("wscript.shell").run ttt,0,ture
End Sub

Sub GetScreenResolution(x,y)
    '获取屏幕分辨率
    x=CreateObject("HtmlFile").ParentWindow.Screen.Width    '屏幕的宽度
    y=CreateObject("HtmlFile").ParentWindow.Screen.Height    '屏幕的高度
End Sub

Sub SetRegValue(RegKeyName, RegValueName,RegValue,RegKeyType)
    '设置注册表
    'RegKeyName=项名, 例如 "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\test"
    'RegValueName=键名, 例如 "MySet"
    'RegValue=键值,例如"不忘初心牢记使命"
    'RegKeyType=键类型，例如 "REG_SZ"
    '没有RegKeyName会自动创建的
    'RegKeyName, RegValueName, RegKeyType, RegValue  都是字符串儿变量
    'RegValueName如果为空的话，只创建RegKeyName
    'RegKeyType取值如下：
    'REG_SZ      '字符串儿
    'REG_DWORD   '数值,32为
    'REG_BINARY   '二进制
    'REG_MULTI_SZ  '多字符串儿
    'REG_EXPAND_SZ   '字符串儿扩展
    'REG_QWORD    '数值,64位
    'REG_NONE
    
    
   
    If InStr(RegKeyName, " ") <> 0 Then  '带空格的RegKeyName处理
        RegKeyName = Chr(34) & RegKeyName & Chr(34)
    End If
    
    If InStr(RegValueName, " ") <> 0 Then  '带空格的RegKeyName处理
        RegValueName = Chr(34) & RegValueName & Chr(34)
    End If
    
    
    If InStr(RegValue, " ") <> 0 Then  '带空格的RegKeyName处理
        RegValue = Chr(34) & RegValue & Chr(34)
    End If
    
    
    RunShell = "cmd /c reg add   " & RegKeyName & " /f /v " & RegValueName & " /t " & RegKeyType & " /d " & RegValue
    If RegValueName = "" Then
        RunShell = "cmd /c reg add " & RegKeyName & " /ve "
    End If
    
    If OSBit = 64 Then            '64位系统的话
        RunShell = RunShell & " /reg:64"
    End If
    
    Set fklsn=WScript.CreateObject("WScript.Shell")
    FKLSN.Run RunShell, 0  ,ture          '执行DOS命令
    
End Sub

Function DelRegValue(RegKeyName, RegValueName, DelParameter)
    '删除注册表。采用此法，避开32/64位问题
    'RegKeyName=项名, 例如 "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Advanced\test"
    'RegValueName=键名, 例如 "MySet"
    'DelParameter=参数，三个值，
    '使用方法:
    '删除某键，必须指定键名。只要指定键名，参数是什么都是无效的。
    '删除项目，必须指定键名为空，而且必须指定参数DelParameter，参数DelParameter为：
    'DelParameter = "D"         '只删除该项的默认值
    '参数 = "V"         '删除该项下的所有键名，包括默认值
    '参数 = "K"        '删除该项以及该项下面所有的子项、键名，也就是删的啥也不剩"
    
    If InStr(RegKeyName, " ") <> 0 Then  '带空格的项名处理
        RegKeyName = Chr(34) & RegKeyName & Chr(34)
    End If
    If InStr(RegValueName, " ") <> 0 Then  '带空格的项名处理
        RegValueName = Chr(34) & RegValueName & Chr(34)
    End If
    DelParameter=UCase(DelParameter)       '大写
    If RegValueName <> "" Then
        RunShell = "cmd /c reg delete " & RegKeyName & " /v " & RegValueName & " /f"
    Else
        Select Case DelParameter
            Case "D"           '只删除该项下的默认值
            RunShell = "cmd /c reg delete " & RegKeyName & " /ve /f"
            Case "V"           '删除该项下的所有键名，包括默认值
            RunShell = "cmd /c reg delete " & RegKeyName & " /va /f"
            Case "K"           '删除该项以及该项下面所有的子项、键名，也就是删的啥也不剩
            RunShell = "cmd /c reg delete " & RegKeyName & " /f"
            Case Else
            Exit Function
        End Select
    End If
    If OSBit = 64 Then            '这是因为，如果编译为32位的exe，运行于64位系统，会导致注册表位置混乱
        RunShell = RunShell & " /reg:64"
    End If
    
    Set fklsn=WScript.CreateObject("WScript.Shell")
    FKLSN.Run RunShell, 0 ,ture           '执行DOS命令

End Function

Sub GetMyAppName(MyName,MyPath)
    '返回自身文件名
    Set fso = CreateObject("scripting.filesystemobject") 
    MyName=WScript.scriptname 
    MyPath=WScript.ScriptFullName
End Sub

Sub SetSystem32Dir
    '编译为32位可执行exe，保证在64位系统下运行正确
    '在编译为32位exe后在64位系统执行时,C:\windows\system32目录，会变成C:\Windows\SysWOW64
    '只要把C:\windows\system32目录改成c:\windows\sysnative目录，在64位系统执行时会变成C:\windows\system32
    '若编译成64位exe，不要执行本子程序 
        Call GetMyAppName(MyName,MyPath) '获取自身文件名
    
    If LCase(Right(MyName,4))=".exe" And OSBit=64 Then     '如果自己是32位exe文件，操作系统是64位的
        SysDirName="c:\windows\sysnative\"                 
    End If
End Sub

Sub OsInfo (OSName,OSBit,OSVer)
    '获取操作系统信息。
    'OSName=操作系统全称,OSVer=操作系统版本号,OSBit操作系统位数

    On Error Resume Next
    
    Set FKMXF = GetObject("winmgmts:\\.\root\cimv2")
    Set mxfyd = FKMXF.ExecQuery("Select * from Win32_OperatingSystem",,48)
    For Each wdjy In mxfyd
        OSName =wdjy.Caption     '操作系统全称    
        OSVer=wdjy.Version    '操作系统版本号
        '瘟十 10.0* 
        '瘟2016 10.0* 
        '瘟八1 6.3* 
        '瘟2012 R2 6.3* 
        '瘟八 6.2 
        '瘟2012 6.2 
        '瘟七 6.1 
        '瘟2008 R2 6.1 
        '瘟2008 6.0 
        '未死的 6.0 
        '瘟2003 5.2 
        '叉屁64位5.2 
        '叉屁32位5.1 
        '瘟两千 5.0 
        
        OSVer    =CInt(Left(OSVer,2))'左取两位转换为数值
        OSBit    =CInt(Left(wdjy.OSArchitecture,2))  ' 操作系统位数,返回64或32，转换为数值型。
    Next
End Sub