[文本处理] 求助VBS或BAT局域网电脑改名，硬件扫描，并上传至共享盘

' 重命名当前计算机，并获取当前系统硬件信息，保存到 %ComputerName%.txt
On Error Resume Next
RunasAdmin
pcName = InputBox("请输入新计算机名：","重命名PC")
' WScript.Echo pcName
' WScript.Quit
renameResult = RenamePC(pcName)

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Temp = 0
Set WSHNetwork = WScript.CreateObject("WScript.Network")
If renameResult Then
  ComputerName = pcName
Else
  ComputerName = WSHNetwork.ComputerName
End If
TempFiles = fso.GetParentFolderName(WScript.ScriptFullName) & "\" & ComputerName & ".txt"
Set TempFile = fso.CreateTextFile(TempFiles)
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set CPU = objWMIService.ExecQuery("Select * From Win32_Processor")
For Each Item In CPU
    CPU2 = "CPU:" & Item.Name
Next

Set Board = objWMIService.ExecQuery("Select * From Win32_BaseBoard")
For Each Item In Board
    Board2 = "主板: " & Item.Product
Next
Set colItems = objWMIService.ExecQuery("Select * From Win32_PhysicalMemory",,48)
For Each objItem In colItems
    A = objItem.Capacity/1048576
    Temp = temp+objItem.Capacity
    N = N+1
Next
Memory = Temp/1048576
If N = 1 Then
    Memory2 = "内存: " & N & "条" & A & "M"
Else
    Memory2 = "内存: " & N & "条" & A & "M" &" 总计" & Memory & "M"
End If
Set Video = objWMIService.ExecQuery("Select * From Win32_VideoController",,48)
For Each Item In Video
    Video2 = "显卡: " & Item.Description
    Video3 = "分辨率: " & Item.VideoModeDescription
Next
Set VideoA = objWMIService.ExecQuery("Select * From Win32_DesktopMonitor",,48)
For Each Item In VideoA
    VideoA = "显示器名称: " & Item.Description
    VideoB = "屏幕高度: " & Item.ScreenHeight & "   屏幕宽度: " & Item.ScreenWidth
Next
Set Disk = objWMIService.ExecQuery("Select * From Win32_DiskDrive")
For Each Item In Disk
    Disk2 = Disk2 & Item.Model
    Disk4 = Int(Item.Size/1000/1000/1000) & "G"
Next
Disk3 = "硬盘: " & Trim(Disk2)
Disk5 = "硬盘容量: " & Disk4
Set Network = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each Item In Network
    Lan = "网卡: " & Item.Description
    IP = "IP地址: " & Item.IPAddress(0)
    MacAdd = "MAC地址：" & Item.MACAddress
Next

TempFile.WriteLine(CPU2)
TempFile.WriteLine(Board2)
TempFile.WriteLine(Memory2)
TempFile.WriteLine(Video2)
TempFile.WriteLine(Video3)
TempFile.WriteLine(VideoA)
TempFile.WriteLine(VideoB)
TempFile.WriteLine(Disk3)
TempFile.WriteLine(Disk5)
TempFile.WriteLine(Lan)
TempFile.WriteLine(Ip)
TempFile.WriteLine(MacAdd)
TempFile.Close

fso.CopyFile TempFiles,"\\192.168.8.30\XINXIBU\",true

Set fso = Nothing
Set objWMIService = Nothing
Set WSHNetwork = Nothing

Sub RunasAdmin()
  On Error Resume Next
  If Not IsVista(".") Then Exit Sub
  Dim wshell
  Set wshell = CreateObject("WScript.Shell")
  wshell.RegRead "HKEY_USERS\S-1-5-19\Environment\TEMP"
  If Err.Number <> 0 Then
    Dim str,arg,shell
    str = ""
    Set shell = CreateObject("Shell.Application")
    For Each arg In WScript.Arguments
      str = str & " """ & arg & """"
    Next
    shell.ShellExecute WScript.FullName,"//nologo """ & WScript.ScriptFullName & """ " & str, "", "runas", 1
    Set shell = Nothing  
    Set wshell = Nothing
    WScript.Quit
  Else
    Set wshell = Nothing
  End If
End Sub

Function IsVista(strComputer)
  On Error Resume Next
  IsVista = False
  Dim objWMIService, colOperationSystems, objOperationSystem
  Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
  Set colOperationSystems = objWMIService.ExecQuery("Select Version from Win32_OperatingSystem")
  For Each objOperationSystem In colOperationSystems
    If CInt(Left(objOperationSystem.Version, InStr(1,objOperationSystem.Version,".") - 1)) > 5 Then
      IsVista = True
      Exit For
    End If
  Next
  Set colOperationSystems = Nothing
  Set objWMIService = Nothing
End Function

Function RenamePC(pcnameNew)
  ' 重命名当前计算机
  RenamePC = False
  On Error Resume Next
  With New RegExp
    .Global = True
    .Ignorecase = True
    .Multiline = False
    .Pattern = "[{|}~\[\]\\^':;<=>?@!""#$%`()+/.,*&\s\uD800-\uDFFF]"
    If .Test(pcnameNew) Then
      WScript.Echo "计算机名含有非法字符"
      Exit Function
    End If
  End With
  If Len(pcnameNew) > 15 Or Len(pcnameNew) = 0 Then
    WScript.Echo "计算机名长度非法"
    Exit Function
  End If
  Dim wshell,strCmd,oExec
  Set wshell = CreateObject("WScript.Shell")
  strCmd = "cmd.exe /c reg add ""HKEY_CURRENT_USER\Software\Microsoft\Windows\ShellNoRoam"" /ve /t REG_SZ /d """ & pcnameNew & """ /f&" &_
            "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName"" /v ""ComputerName"" /t REG_SZ /d """ & pcnameNew & """ /f&" &_
            "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\ComputerName\ActiveComputerName"" /v ""ComputerName"" /t REG_SZ /d """ & pcnameNew & """ /f&" &_
            "reg add ""HKLM\SYSTEM\CurrentControlSet\Services\Eventlog"" /v ""ComputerName"" /t REG_SZ /d """ & pcnameNew & """ /f&" &_
            "reg add ""HKLM\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters"" /v ""NV Hostname"" /t REG_SZ /d """ & pcnameNew & """ /f&" &_
            "reg add ""HKLM\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters"" /v ""Hostname"" /t REG_SZ /d """ & pcnameNew & """ /f"
  Set oExec = wshell.Exec(strCmd)
  ' If Not oExec.StdOut.AtEndOfStream Then
  '   WScript.Echo oExec.StdOut.ReadAll
  ' End If
  Do While oExec.Status = 0
     WScript.Sleep 100
  Loop
  If oExec.ExitCode <> 0 Then
    WScript.Echo "计算机重命名失败: " & oExec.ExitCode
  Else
    RenamePC = True
  End If
  Set oExec = Nothing
  Set wshell = Nothing
End Function
复制代码