Mensajes

Código [Seleccionar] Expandir

http://www.xbeat.net/vbspeed/cod_InStrMarzo.htm
La funcion InStr01 debe ser la mas rapida en caso de que uses vbTextCompare, si no quieres trabajar con cadenas podras alterarla para que funcione con ByteArrays

El truco de esta funcion esta en sus Arrays trucados

si he visto el enlace inclusive saque algunos tips, trabaja practicamente igual solo que este pasa una cadena como puntero y lo pasa a un array (no entendi bien eso) pero en fin da lo mismo porque yo estoy trabajando directamente con byte array.
bueno creo que es lo maximo que se pude llegar con vb, no estoy seguro ejcutandolo con ASM o declarando las apis en .tlv

Saludos.

Gracias BlackZeroX por coloaborar, esta bien reducido pero es mucho mas lenta y si pasamos archivos grandes daria error (esto ultimo no importa mucho se puede solucionar)

un bucle de 101 lamadas testeado con GetTickCount

BlackZeroX  2437
LeandroA     782

Saludos.

creo que por el momento la unica que funciona bien es la de Novlucker las demas no esta trabajando correctamente

solo tengo mis dudas con la de Novlucker  con los numeros del 1 al 9 ya que dan numeros simples y no se cumple la condición de capicua

la de raul338  tambien anda bien con el mismo problea que el de Novlucker   y tambien pero hay un problema con el 11 ya que da como resultado 11 cuando deberia ser 22


@BlackZeroX

0 = blucle infinito
la funcion deve devolver true si no se logra el capicua en los determinados ciclos
tambien el problema del 1 al 10 pero peor, muestra erronos

@Tokes no estas devolviendo "numeroFinal" correctamente.

Buenas esto no es un reto, solo me intriga saber si se pude crear/mejorar una funcion mas rapida que esta que hice para buscar una palabra en un archivo, la funcion trabaja con bytes y no con string, como ejemplo puse que busque una palabra existente dentro del "Explorer.exe" y un bucle de 100 vueltas para exijirle un poco a la función. Tambien comente una palabra inexistente para probar.
no discrimina por mayusculas o minusculas "deve encontrarla de cualquier forma".

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Private Declare Function CharUpperBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long

Private Type LARGE_INTEGER
   lowpart As Long
   highpart As Long
End Type


Private Const GENERIC_READ          As Long = &H80000000
Private Const FILE_SHARE_READ       As Long = &H1
Private Const OPEN_EXISTING         As Long = 3
Private Const INVALID_HANDLE_VALUE  As Long = -1
Private Const FILE_BEGIN            As Long = 0

Private aUChars(255) As Byte

Private Function LargeIntToCurrency(Low As Long, High As Long) As Currency
   Dim LI As LARGE_INTEGER
   LI.lowpart = Low: LI.highpart = High
   CopyMemory LargeIntToCurrency, LI, LenB(LI)
   LargeIntToCurrency = LargeIntToCurrency * 10000
End Function

Private Function CurrencyToLargeInt(ByVal Curr As Currency) As LARGE_INTEGER
   Curr = Curr / 10000
   CopyMemory CurrencyToLargeInt, Curr, LenB(Curr)
End Function


Private Function FindWordInFile(ByVal sPath As String, ByVal sWord As String, Optional ByVal bUnicode As Boolean) As Boolean
   Dim bArray() As Byte
   Dim lRet As Long
   Dim hFile As Long
   Dim sFind() As Byte
   Dim s As String
   Dim t As Long
   Dim i As Long
   Dim FileSize As Currency
   Dim tLI As LARGE_INTEGER
   Dim LenBuffer As Long
   Dim CurPos As Currency

   sWord = UCase(sWord)
   If bUnicode Then sWord = StrConv(sWord, vbUnicode)
   sFind = StrConv(sWord, vbFromUnicode)

   hFile = CreateFile(sPath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
   
   If hFile <> INVALID_HANDLE_VALUE Then
   
       
       tLI.lowpart = GetFileSize(hFile, tLI.highpart)
   
       LenBuffer = &H2800 ' 10 KB
   
       FileSize = LargeIntToCurrency(tLI.lowpart, tLI.highpart)
       
       If FileSize < UBound(sFind) Then GoTo OutSearch
   
       If LenBuffer > FileSize Then LenBuffer = FileSize
   
       ReDim bArray(LenBuffer - 1)

       Do
           ReadFile hFile, bArray(0), UBound(bArray) + 1, lRet, 0&
           
           If lRet = 0 Then Exit Do
           
           CurPos = CurPos + lRet

           If lRet < LenBuffer Then
               ReDim Preserve bArray(lRet)
           End If

           If InBytes(bArray, sFind) <> -1 Then
               FindWordInFile = True
               Exit Do
           End If
           
           If CurPos = FileSize Then Exit Do
           
           tLI = CurrencyToLargeInt(CurPos - UBound(sFind) + 1)
           
           SetFilePointer hFile, tLI.lowpart, tLI.highpart, FILE_BEGIN
                       
       Loop
       
OutSearch:
       
       CloseHandle hFile

   End If
End Function



Public Function InBytes(ByRef bvSource() As Byte, ByRef bvMatch() As Byte) As Long

   Dim i       As Long
   Dim j       As Long
   Dim lChr    As Byte
   Dim LenMach As Long

   LenMach = UBound(bvMatch)
   
   lChr = bvMatch(0)
   
   If LenMach > 0 Then
   
       For i = 0 To UBound(bvSource) - LenMach
     
           If (lChr = aUChars(bvSource(i))) Then

               j = LenMach - 1
   
               Do
                   If bvMatch(j) <> aUChars(bvSource(i + j)) Then GoTo NotEqual
                   j = j - 1
               Loop While j
               
               InBytes = i
               
               Exit Function
   
           End If
NotEqual:
       
       Next
   
   Else
       For i = 0 To UBound(bvSource)
           If (lChr = aUChars(bvSource(i))) Then
               InBytes = i
               Exit Function
           End If
       Next
   End If

   InBytes = -1
End Function

Private Sub Form_Initialize()
   Dim i As Long

   For i = 0 To 255: aUChars(i) = i: Next
   CharUpperBuffA aUChars(0), 256

End Sub

Private Sub Form_Load()
   Dim t As Long, i As Long, Ret As Boolean
   t = GetTickCount
   For i = 0 To 100 'Este bucle es solo para exijirle un poco mas a la funcion
       Ret = FindWordInFile(Environ("windir") & "\explorer.exe", "Mostrar en el escritorio", True)
       'Ret = FindWordInFile(Environ("windir") & "\explorer.exe", "esta palabra no existe")
   Next
   
   MsgBox GetTickCount - t
   Me.Caption = Ret
   
End Sub


PD: Complilarlo

che funciona?, no me muestra nada

Código [Seleccionar] Expandir


Option Explicit
Dim clsIsOblongo As cIsOblongo


Private Sub Form_Load()
    Dim i   As Long
    Dim n   As Long

    Set clsIsOblongo = New cIsOblongo

    For i = 0 To 100
        If clsIsOblongo.IsOblongo(i, n) Then
            Debug.Print n, i
        End If
       
    Next i

End Sub


[OffTopic]
estuve queriendo probar las diferencias de velocidades entre el IF, SELECT CASE, IF inline etc.
la cuestion es que vi que las funciones que se llaman primero tiene cierta ventaja con respecto a las otras, esto mismo pasa cuando queremos comparar las funciones que estamos haciendo. Es correcto esto que digo?¿?¿

esto es lo que hice
si alteran el orden de las llamadas hay ciertos cambios.

Código (vb) [Seleccionar] Expandir


Option Explicit

Private CTiming As CTiming


Private Sub Form_Load()
    Dim i As Long, j As Long
    Dim ValTest As Long
   
    Set CTiming = New CTiming
   
    Me.AutoRedraw = True
   
    Me.Print "Test de velocidad" & vbCrLf
   
    ValTest = 5000000
   
    CTiming.Reset

    For i = 0 To ValTest
        For j = 1 To 4
            Prueba1 j
        Next
    Next
   
    Me.Print "Prueba1 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba2 j
        Next
    Next
   
    Me.Print "Prueba2 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba3 j
        Next
    Next
   
    Me.Print "Prueba3 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba4 j
        Next
    Next
   
    Me.Print "Prueba4 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba5 j
        Next
    Next
   
    Me.Print "Prueba5 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba6 j
        Next
    Next
   
    Me.Print "Prueba6 " & CTiming.sElapsed
   
    CTiming.Reset
   
    For i = 0 To ValTest
        For j = 1 To 4
            Prueba7 j
        Next
    Next
   
    Me.Print "Prueba7 " & CTiming.sElapsed
   
End Sub



Private Function Prueba1(ByVal num As Long) As Long
    Select Case num
        Case 1
            Prueba1 = 1
        Case 2
            Prueba1 = 2
        Case 3
            Prueba1 = 3
        Case Else
            Prueba1 = -1
    End Select
End Function


Private Function Prueba2(ByVal num As Long) As Long
    If num = 1 Then Prueba2 = 1 Else If num = 2 Then Prueba2 = 2 Else If num = 3 Then Prueba2 = 3 Else Prueba2 = -1
End Function


Private Function Prueba3(ByVal num As Long) As Long

    If num = 1 Then
        Prueba3 = 1
        Exit Function
    End If
   
    If num = 2 Then
        Prueba3 = 2
        Exit Function
    End If
   
    If num = 3 Then
        Prueba3 = 3
        Exit Function
    End If
   
    Prueba3 = -1
   
End Function

Private Function Prueba4(ByVal num As Long) As Long

    If num = 1 Then
        Prueba4 = 1
    Else
        If num = 2 Then
            Prueba4 = 2
        Else
            If num = 3 Then
                Prueba4 = 3
            Else
                Prueba4 = -1
            End If
        End If
    End If
   
End Function

Private Function Prueba5(ByVal num As Long) As Long

    If num = 1 Then
            Prueba5 = 1
        ElseIf num = 2 Then
                Prueba5 = 2
            ElseIf num = 3 Then
                    Prueba5 = 3
                Else
                    Prueba5 = -1
                End If

   
End Function


Private Function Prueba6(ByVal num As Long) As Long
    Prueba6 = IIf(num = 1, 1, IIf(num = 2, 2, IIf(num = 3, 3, -1)))
End Function

Private Function Prueba7(ByVal num As Long) As Long
    If num = 1 Then Prueba7 = 1: Exit Function
    If num = 2 Then Prueba7 = 2: Exit Function
    If num = 3 Then Prueba7 = 3: Exit Function
    Prueba7 = -1
End Function


lmax = Sqr(lNumb) = al numero

carajo cuando lo probe no me daba poreso restaba uno y ahora veo que si funciona.  

me gusto esta (nval And &H80000000) para los negativos.

jaja eso me pasa por copiar 

[Cobein+Karcrack]

Si, estuve comprobando y Cobein+Karcrack solo se va un par de milisegundos de LeandroA( aka Gilad )+Tokes

Ya tenemos vencedores !! (?)

yo pongo esta pero me siento un ladron 

jajaja y si yo lo dije, de todas formas esOdiosoTokLean se lleva la copa jejej

Hola me matan las matematicas @~#~#

bueno pongo dos funciones una a lo bruto y la otra mejor es en base a la de tokes pero mas rapida.

Código (vb) [Seleccionar] Expandir


Private Function IsOblongoLeo(ByVal lNumb As Long, ByRef n As Long) As Boolean
   Dim R As Long
   Dim lSum As Long
   
   If (lNumb And 1) Then Exit Function
   
   lSum = lNumb + 1
   
   R = lSum ^ 0.48
   If lNumb = R * (R + 1) Then
       IsOblongoLeo = True
       n = R
   Else
       R = lSum ^ 0.49
       If lNumb = R * (R + 1) Then
           IsOblongoLeo = True
           n = R
       Else
           R = lSum ^ 0.495
           If lNumb = R * (R + 1) Then
               IsOblongoLeo = True
               n = R
           Else
               R = lSum ^ 0.498
               If lNumb = R * (R + 1) Then
                   IsOblongoLeo = True
                   n = R
               Else
                   R = lSum ^ 0.499
                   If lNumb = R * (R + 1) Then
                       IsOblongoLeo = True
                       n = R
                   Else
                       If (lNumb = 0) Or (lNumb = 2) Then n = lNumb \ 2: IsOblongoLeo = True: Exit Function
                       If (lNumb = 6) Then n = 2: IsOblongoLeo = True
                   End If
               End If
           End If
       End If
   End If
End Function


y esta mucho mas rapida

Código (vb) [Seleccionar] Expandir


Private Function IsOblongoLeo2(ByVal lNumb As Long, ByRef n As Long) As Boolean

    Dim lmax As Long, i As Long

    If (lNumb And 1) Then Exit Function
    If lNumb = 0 Then n = 0: IsOblongoLeo2 = True: Exit Function

    lmax = Sqr(lNumb)

    For i = lmax - 1 To lmax
        If lNumb = i * (i + 1) Then
            IsOblongoLeo2 = True
            n = i
            Exit Function
        End If
    Next
End Function