Mensajes

.

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 engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit

Private Declare Function lstrcmp Lib "kernel32" Alias "lstrcmpA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function FindFirstFile& Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName$, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function FindNextFile& Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile&, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose& Lib "kernel32" (ByVal hFindFile&)

Const MAX_PATH                              As Integer = 260
Const MAXDWORD                              As Long = &HFFFF
Const INVALID_HANDLE_VALUE                  As Long = -1

Private Type FILETIME
   dwLowDateTime                           As Long
   dwHighDateTime                          As Long
End Type

Private Type WIN32_FIND_DATA
   dwFileAttributes                        As Long
   ftCreationTime                          As FILETIME
   ftLastAccessTime                        As FILETIME
   ftLastWriteTime                         As FILETIME
   nFileSizeHigh                           As Long
   nFileSizeLow                            As Long
   dwReserved0                             As Long
   dwReserved1                             As Long
   cFileName                               As String * MAX_PATH
   cAlternate                              As String * 14
End Type

Event Folder(ByRef PathFolder As String, ByVal Atrributes As VbFileAttribute)
Event File(ByRef NameFile As String, ByRef TypeOfFile As Long, ByVal Atrributes As VbFileAttribute)
Event Begin()
Event Finish()

Private Priv_StrDir$, Priv_StrCri$(), Priv_IncFolder As Boolean, Priv_Cancel As Boolean
Private Priv_CriFindInDir As VbFileAttribute, Priv_CriFindInFile  As VbFileAttribute
Private Hwnd_SearchF&(), LS_Index&(0 To 1), BytesNow_#
Private Bool_Run As Byte

Public AllowEvents                          As Boolean

Private Sub Class_Initialize()
   Priv_IncFolder = True
   AllowEvents = True
   Priv_CriFindInDir = vbDirectory
   Priv_CriFindInFile = vbArchive
End Sub

Public Property Get BytesNow#()
   BytesNow# = BytesNow_#
End Property

Public Property Get FindInPath() As String
   FindInPath = Priv_StrDir$
End Property

Public Property Let FindInPath(ByVal vData$)
   Call Stop_
   Call NormalizePath&(vData$)
   Priv_StrDir$ = vData$
End Property



Public Property Get CriterionFindDir() As VbFileAttribute
   CriterionFindDir = Priv_CriFindInDir
End Property
Public Property Let CriterionFindDir(ByVal vData As VbFileAttribute)
   Call Stop_
   Priv_CriFindInDir = vData Or vbDirectory
End Property

Public Property Get CriterionFindFile() As VbFileAttribute
   CriterionFindFile = Priv_CriFindInFile
End Property
Public Property Let CriterionFindFile(ByVal vData As VbFileAttribute)
   Call Stop_
   Priv_CriFindInFile = vData Or vbArchive
End Property



Public Property Get CriterionToFind() As Variant
   CriterionToFind = Priv_StrCri$
End Property

Public Property Let CriterionToFind(ByRef vData As Variant)
On Error GoTo Err_
Dim L_Index                             As Long
   Call Stop_
   Erase Priv_StrCri$
   LS_Index&(0) = INVALID_HANDLE_VALUE
   LS_Index&(1) = INVALID_HANDLE_VALUE
   If IsArray(vData) Then
       LS_Index&(0) = LBound(vData)
       LS_Index&(1) = UBound(vData)
       ReDim Priv_StrCri$(LS_Index&(0) To LS_Index&(1))
       For L_Index = LS_Index&(0) To LS_Index&(1)
           Priv_StrCri$(L_Index) = CStr(vData(L_Index))
       Next L_Index
   Else
       LS_Index&(0) = 0
       LS_Index&(1) = 0
       ReDim Priv_StrCri$(0)
       Priv_StrCri$(0) = vData
   End If
Exit Property
Err_:
   Err.Clear
End Property

Public Property Get IncludeSubFolders() As Boolean: IncludeSubFolders = Priv_IncFolder: End Property
Public Property Let IncludeSubFolders(ByVal vData As Boolean): Priv_IncFolder = vData: End Property

Public Property Get ItsRun() As Boolean:    ItsRun = Bool_Run = 1:      End Property

Public Sub Stop_():    Bool_Run = 0: Priv_Cancel = True: End Sub

Public Function Start_(Optional StrFindInPath As Variant = "", Optional StrCriterionToFind As Variant = Nothing) As Double

   Call Stop_
   BytesNow_# = 0
   If Not StrFindInPath = "" Then FindInPath = StrFindInPath
   If Not IsObject(StrCriterionToFind) Then CriterionToFind = StrCriterionToFind
   If Not (LS_Index&(0) = INVALID_HANDLE_VALUE And LS_Index&(0) = INVALID_HANDLE_VALUE) And Priv_StrDir$ <> "" And CStr(Dir(Priv_StrDir$, vbDirectory)) <> "" Then
       RaiseEvent Begin
       Bool_Run = 1
       Priv_Cancel = False
       Call FindFilesAPI#(Priv_StrDir$, Priv_StrCri$())
       Start_# = BytesNow_#
       Bool_Run = 0
       RaiseEvent Finish
   End If
   
End Function

Private Sub FindFilesAPI(ByVal StrPath$, ByRef StrSearch$())
Dim str_NameNow$
Dim Str_NameDir$()
Dim Lng_DirCant&
Dim Lng_DirCount&
Dim LF_Index&
'Dim Lng_Res&
Dim Hwnd_Search&
Dim WFD                                 As WIN32_FIND_DATA

   Lng_DirCount& = 0
   Hwnd_Search& = FindFirstFile&(StrPath$ & "*", WFD)
   
   If Hwnd_Search& <> INVALID_HANDLE_VALUE Then
       RaiseEvent Folder(StrPath$, WFD.dwFileAttributes)
       Do
           If AllowEvents Then DoEvents
           If Priv_Cancel Then Exit Sub
           With WFD
               str_NameNow$ = Left$(.cFileName, InStr(.cFileName, Chr(0)) - 1)
               If (((.dwFileAttributes Or Priv_CriFindInDir) = .dwFileAttributes) And ((.dwFileAttributes And vbDirectory) = vbDirectory)) Then
                   If (str_NameNow$ <> ".") And (str_NameNow$ <> "..") Then
                       ReDim Preserve Str_NameDir$(Lng_DirCount&)
                       Str_NameDir$(Lng_DirCount&) = str_NameNow$
                       Lng_DirCount& = Lng_DirCount& + 1
                   End If
               End If
           End With
       Loop While FindNextFile&(Hwnd_Search&, WFD)
       
       Call FindClose(Hwnd_Search&)
       
       For LF_Index& = LS_Index&(0) To LS_Index&(1)
           Hwnd_Search& = FindFirstFile&(StrPath$ & StrSearch$(LF_Index&), WFD)
           If Hwnd_Search& <> INVALID_HANDLE_VALUE Then
               Do
                   If AllowEvents Then DoEvents
                   If Priv_Cancel Then Exit Sub
                   With WFD
                       str_NameNow$ = Left$(.cFileName, InStr(.cFileName, Chr(0)) - 1)
                       If (((.dwFileAttributes Or Priv_CriFindInFile) = .dwFileAttributes) And ((.dwFileAttributes And vbArchive) = vbArchive)) Then
                       
                           If (str_NameNow$ <> ".") And (str_NameNow$ <> "..") Then
                               BytesNow_# = BytesNow_# + ((.nFileSizeHigh& * MAXDWORD&) + .nFileSizeLow&) + 0
                               RaiseEvent File(str_NameNow$, LF_Index&, .dwFileAttributes)
                           End If
                       End If
                   End With
               Loop While FindNextFile&(Hwnd_Search&, WFD)
               Call FindClose(Hwnd_Search&)
           End If
       Next LF_Index
       
       If Lng_DirCount& > 0 And Priv_IncFolder Then
           For Lng_DirCant& = 0 To Lng_DirCount& - 1
               Call FindFilesAPI#(StrPath$ & Str_NameDir$(Lng_DirCant&) & "\", StrSearch$)
           Next
       End If
       
   End If
   
End Sub

'   Returns
'   //  0   =   NoPathValid
'   //  1   =   Ok
'   //  2   =   Fixed/Ok
Public Function NormalizePath&(ByRef sData$)
   
   If Strings.Len(sData$) > 1 Then
       sData$ = Strings.Replace(sData$, "/", "\")
       If Not Strings.Right$(sData$, 1) = "\" Then
           sData$ = sData$ & "\"
           NormalizePath& = 2
       Else
           NormalizePath& = 1
       End If
   Else
       NormalizePath& = 0
   End If
   
End Function



Modo de declaración...

Código (Vb) [Seleccionar] Expandir



Private WithEvents ClsScanDisk          As Cls_Files

' // Proceso X
   If ClsScanDisk Is Nothing Then Set ClsScanDisk = New Cls_Files
   With ClsScanDisk
       If .ItsRun Then Call .Stop_
       .CriterionToFind = Split("*.mp3,*.wma,*.mid,*.midi", ",")
       '   //  ó tambien...
       .CriterionToFind = "*.mp3"
       .FindInPath = "c:\"
       Call .Start_
   End With
' // Fin Proceso X



Eventos:

Código (Vb) [Seleccionar] Expandir



Event Folder(ByRef PathFolder As String, ByVal Atrributes As VbFileAttribute)
Event File(ByRef NameFile As String, ByRef TypeOfFile As Long, ByVal Atrributes As VbFileAttribute)
Event Begin()
Event Finish()



Código (vb) [Seleccionar] Expandir



Option Explicit

Private WithEvents ClsScanDisk          As cls_files
Private ThisPath$
Private CountFiles&

Private Sub ClsScanDisk_Begin()
   ThisPath$ = ClsScanDisk.FindInPath
   CountFiles& = 0
   Caption = "ScanDisk ha Encontrado: "
End Sub

Private Sub ClsScanDisk_File(NameFile As String, TypeOfFile As Long, ByVal Atrributes As Long)
   CountFiles& = CountFiles& + 1
   Caption = "ScanDisk ha Encontrado: " & CountFiles&
   Debug.Print ThisPath$ & NameFile
   Debug.Print vbTab & "Criterio:"; ClsScanDisk.CriterionToFind(TypeOfFile),
   Debug.Print "Atributos:"; Atrributes
End Sub

Private Sub ClsScanDisk_Finish()
   Caption = "ScanDisk ha Encontrado: " & CountFiles& & " -> Finalizado."
End Sub

Private Sub ClsScanDisk_Folder(PathFolder As String, ByVal Atrributes As Long)
   ThisPath$ = PathFolder
End Sub


Private Sub Form_Load()
   If ClsScanDisk Is Nothing Then Set ClsScanDisk = New cls_files
   With ClsScanDisk
       If .ItsRun Then .Stop_
       .CriterionToFind = Split("*.mp3,*.wma,*.avi,*.mid,*.mid", ",")
       '.CriterionFindDir = vbReadOnly                  '   //  Solo directorios de Solo lectura.
       '.CriterionFindFile = vbHidden Or vbReadOnly     '  //  Solo archivos ocultos.
       .FindInPath = "c:\"
       .AllowEvents = True
       Call .Start_
   End With
End Sub



Dulce Infierno Lunar!¡.

.
Solo le faltaron los Byval en la linea del Copymemory.
.
Thank's... ando algo traumado ahorita son unas cosillas como esta... y andaba probando (Esto no lo sabia), por eso use Dos Arrays...

Código (Vb) [Seleccionar] Expandir



Option Explicit

Enum tAlign
   Align_Left = 0
   Align_Center
   Align_Right
End Enum

Private Type RECTFila
   Left                                    As Long
   Top                                     As Long
   'Right                                   As Long
   Bottom                                  As Long
End Type

Private Type tConfigItem
   Text                                    As String
   Tag                                     As String
   Key                                     As String
   ForeColor                               As Long
   Bold                                    As Byte
   Italic                                  As Byte
   Underline                               As Byte
   Aligh                                   As tAlign
End Type

Private Type tConfigFilas                           '   //  Region General de las Filas.
   ToolTip                                 As String
   Tag                                     As String
End Type

Private Type tFilas     '   //  Region General de las Filas.
   Item                                    As tConfigItem
   SubItems()                              As tConfigItem
   ConfiguracionFila                       As tConfigFilas
   Region                                  As RECTFila
End Type

Dim Item(0 To 1)            As tFilas

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Sub SwaptFilas(StructOrigen As tFilas, StructDest As tFilas)
Dim lng_PtrOld()                            As Byte
Dim ln_Bytes                                As Long
   ln_Bytes = LenB(StructDest)
   If ln_Bytes > 0 Then
       ReDim LHold(1 To ln_Bytes)
       CopyMemory LHold(0), ByVal VarPtr(StructOrigen), ln_Bytes
       CopyMemory ByVal VarPtr(StructOrigen), ByVal VarPtr(StructDest), ln_Bytes
       CopyMemory ByVal VarPtr(StructDest), LHold(0), ln_Bytes
   End If
End Sub

Private Sub Command1_Click()
   'MsgBox LenB(Item(0))
   With Item(0)
       ReDim .SubItems(20)
       MsgBox UBound(.SubItems)
       .Item.Text = "Miguel Angel"
       .Item.Tag = "Ortega Avila"
   End With
   Call SwaptFilas(Item(0), Item(1))
   Debug.Print
   With Item(1)
       MsgBox UBound(.SubItems)
       Debug.Print .Item.Text, .Item.Tag, UBound(.SubItems)
   End With
   With Item(0)
       MsgBox UBound(.SubItems)
       Debug.Print .Item.Text, .Item.Tag, UBound(.SubItems)
   End With
End Sub



Dulce Infierno Lunar!¡.

[ReadDirectoryChangesW]

@FileSystemWatcher  me suena a algo similar a esto... ReadDirectoryChangesW

http://planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=61052&lngWId=1

Dulces Lunas!¡.

.
Bien aquí esta la cosa... lo lamento pero estaba algo atontado con algunas cosas xP.

Código (Vb) [Seleccionar] Expandir



Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
       (Destination As Any, Source As Any, ByVal Length As Long)
Private Const InvalidValueArray = -1

Private Sub Form_Load()
Dim Arr()           As Long
Dim a               As Long
   For a = 0 To 99999  '   //  Es solo para verificar si hay Crash
       DoEvents
       ReDim Arr(0 To 5)
       Arr(0) = 12
       Arr(1) = 13
       Arr(2) = 14
       Arr(3) = 15
       Arr(4) = 16
       Arr(5) = 17
       RemoveInArrayLong 3, Arr
       Debug.Print a
   Next a
End Sub

Private Function RemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim lng_Old         As Long
Dim lng_LBound      As Long
Dim lng_UBound      As Long
Dim lng_LenArray    As Long
Dim lng_lenToCopy   As Long
Dim Arrlng_Old()    As Long

   If Not (Not ThisArray) = InvalidValueArray Then
       lng_LBound = LBound(ThisArray)
       lng_UBound = UBound(ThisArray)
       If Index& <= lng_UBound Then
           lng_LenArray = lng_UBound
           If lng_LBound = 0 Then lng_LenArray = lng_LenArray + 1
           If lng_LenArray > 1 Then
               lng_lenToCopy = lng_UBound - Index& - 1
               If lng_LBound = 0 Then lng_lenToCopy = lng_lenToCopy + 1
               If lng_UBound - Index& - 1 >= 0 Then
                   ReDim Arrlng_Old(lng_LBound To lng_UBound - Index& - 1)
                   Call CopyMemory(ByVal VarPtr(Arrlng_Old(lng_LBound)), _
                                   ByVal VarPtr(ThisArray(Index& + 1)), 4 * lng_lenToCopy)
                   Call CopyMemory(ByVal VarPtr(ThisArray(Index&)), _
                                   ByVal VarPtr(Arrlng_Old(lng_LBound)), 4 * lng_lenToCopy)
               End If
               ReDim Preserve ThisArray(lng_LBound To lng_UBound - 1)
               RemoveInArrayLong = True     '   // Estos son Returns que uso yo... en si son True
           Else
               Erase ThisArray
               RemoveInArrayLong = False    '   // Estos son Returns que uso yo... en si son True
           End If
       End If
   End If
End Function



Dulce Infierno Lunar!¡.

[For Next]

.
@Miseryk

No me Sirven los For Next son tardados y lo que requiero es Velocidad a punta de derrame..

Gracias... miura ahorita ando con punteros y estructuras de variables... ya di con el problema de hecho esto me soluciona MUCHAS cosas anteriores... enseguida publico la solucion xD

Dulces Lunas!¡

.
Alquien sabe como solucionar esto?...

Me da el error 10: La matriz está fija o temporalmente bloqueada

Código (Vb) [Seleccionar] Expandir



Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
       (Destination As Any, Source As Any, ByVal Length As Long)
Private Const InvalidValueArray = -1

Private Sub Form_Load()
Dim arr()          As Long
   redim arr(0 to 5)
   arr(0) = 12
   arr(1) = 13
   arr(2) = 14
   arr(3) = 15
   arr(4) = 16
   arr(5) = 17
   RemoveInArrayLong 4, arr
End Sub

Private Function RemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim LenArray        As Long
Dim tArray()        As Long

   If Not (Not ThisArray) = InvalidValueArray Then
       LenArray = UBound(ThisArray) - LBound(ThisArray)
       If LenArray - 1 >= 0 Then
           If LenArray = Index& Then
               ReDim Preserve ThisArray(LBound(ThisArray) To (UBound(ThisArray) - 1))
           Else
               ReDim tArray(LenArray - 1)
               If Index > 0 Then
                   Call CopyMemory(ByVal VarPtr(tArray(LBound(tArray))), ByVal VarPtr(ThisArray(LBound(ThisArray))), 4 * Index&)
               End If
               Call CopyMemory(ByVal VarPtr(tArray(Index)), ByVal VarPtr(ThisArray(Index& + 1)), 4 * (LenArray - Index&))
               ReDim ThisArray&(LenArray - 1)
               Call CopyMemory(ByVal VarPtr(ThisArray(LBound(ThisArray))), (tArray(LBound(tArray))), 4 * LenArray)
               Erase tArray
           End If
           RemoveInArrayLong = True
       Else
           Erase ThisArray
           RemoveInArrayLong = False
       End If
   End If
End Function



Edito
.
Ojo tiene que ser via parametro el Array...

Dulces Lunas!¡.

.
Muy bonito...

Yo ando haciendo algo siilar pero voy por otro modo... hasta ahora es Indetectable (los AV's no detectan las conexiones Salientes xP).

a si se me olvidaba si se compila en

P-Code

Se reduce mucho el peso del Ejecutable (De 700KB a unos 500KB)!¡, y en el cliente o Stup sea como sea... se baja de 120KB a 76KB.

Dulces Lunas!¡.

Esto lo puedes hacer mas facil usando el API de DirectX...

revisa unos post atras como hace 1 año mas o menos publique unos ejemplos de la SDK del DirectX... o mas facil bajate la SDK en sus ejemplos esta la respuesa!¡.

Dulces Lunas!¡.

[devuelves la dirrecion de variable de RESULTADO del Proceso]

Hola, quería saber si me podrían guiar con este tema:

Yo inyecto una dll en un programa, el programa tiene muchas funciónes y procedimientos, como hago para llamarlos desde la dll inyectada? alguna idea? Desde ya muchas gracias por resolver y aclarar mis dudas en los posts.

Ej: del ejecutable.

Option Explicit

Private Sub Command1_Click()
Dim var As Long

var = VarPtr(Valor(1, 1))

MsgBox var & " (" & Hex(var) & ")"
End Sub

Public Function Valor(ByVal v1 As Long, ByVal v2 As Long) As Long
Valor = v1 + v2
End Function

Esto hice para saber el address de la función.

lo que haces hay no es devolver la dirección del proceso, devuelves la dirrecion de variable de RESULTADO del Proceso

si quieres saber la dirrecion del Proceso, Funcion, u otra cosa similar

En un Modulo (Bas)

Código (Vb) [Seleccionar] Expandir



Option Explicit

Sub main()
Dim ThisAddress&
    ThisAddress& = Adrs&(AddressOf procesoX)
    MsgBox ThisAddress& & " - (" & Hex(ThisAddress&) & ")"
End Sub

Public Function Adrs(ByVal Addrs As Long) As Long
    Adrs& = Addrs&
End Function

Public Function procesoX(ParamArray ParametrosX() As Variant) As String

End Function



Dulce Infierno Lunar!¡.

[DataArrival]

mmm
esta mal tu recivo de datos


...

ponlo en el evento DataArrival

Código (Vb) [Seleccionar] Expandir



Private Sub Socket_Out_DataArrival(ByVal bytesTotal As Long)
Dim vData                               As String
    Call Socket_In.GetData(vData)
    Call MsgBox(vData)
End Sub