Yo primero haria un do loop y CONTARIA cada coherencia con
stFind cada offset de dicha coherencia la almacenaría en una cola o algún vector (simulando la cola), después al termino de este pasaría a crear un buffer y por ultimo un while que copiaría a tramos cada bloque de caracteres: Esto se traduce en velocidad...
OJO: NO SE SI FUNCIONA puesto que lo escribí en el Block de Notas y estoy bajo Linux...
Function AltReplace(stExpression As String, stFind As String, stReplace As String) As String
Dim offsetDst As long
Dim offsetSrc As long
dim listOffset() As long
dim listOffsetCount as long
dim listOffsetIndex as long
if Len(stFind) == 0 then
AltReplace = stExpression
exit function
end if
' // Match Count
offsetSrc = 1
Do
offsetSrc = InStr(offsetSrc, stExpression, stFind)
If lnCount <= offsetSrc Then Exit Do
redim preserve listOffset(0 to listOffsetCount)
listOffset(listOffsetCount) = offsetSrc
listOffsetCount = (listOffsetCount + 1)
offsetSrc = (offsetSrc + len(stFind))
Loop
if listOffsetCount == 0 then
AltReplace = stExpression
exit function
end if
' // Buffer
AltReplace = space((stExpression - (Len(stFind) * listOffsetCount)) + (Len(stReplace) * listOffsetCount))
' // Copiamos por "bloques"
while not (listOffsetIndex = listOffsetCount)
if listOffset(listOffsetIndex) > 1 then
offsetDst = (listOffset(listOffsetIndex - 1) + (len(stReplace) * listOffsetIndex))
offsetSrc = (listOffset(listOffsetIndex - 1) + (len(stFind) * listOffsetIndex))
mid$(AltReplace, _
offsetDst, _
(offsetDst - listOffset(listOffsetIndex))) = mid$(stExpression, _
offsetSrc, _
(offsetSrc - (listOffset(listOffsetIndex) - offsetSrc)))
else
mid$(AltReplace, 1, listOffset(listOffsetIndex)) = mid$(stExpression, _
1, _
listOffset(listOffsetIndex))
end if
mid$(AltReplace, listOffset(listOffsetIndex), len(stReplace)) = stReplace
listOffsetIndex = (listOffsetIndex + 1)
Wend
End Function
* En lugar de usar Mid$() seria bueno usar CopyMemory() o algun For Next, o si no quieres APIS usa mMemoryEx (Busca en el foro)
* Configuración de mMemoryEx y/o mMemory:
http://foro.elhacker.net/programacion_visual_basic/mmemory_writeprocessmemoryvbacopybytesrtlmovememory_replacement_noapi-t343343.0.html * ejemplo mMemoryEx:
http://foro.elhacker.net/programacion_visual_basic/class_cstack_vb6-t365372.0.html;msg1760659#msg1760659
Option Explicit
Public Const PAGE_EXECUTE_READWRITE As Long = &H40
Public Const PAGE_EXECUTE_WRITECOPY As Long = &H80
Public Const PAGE_EXECUTE_READ As Long = &H20
Public Const PAGE_EXECUTE As Long = &H10
Public Const PAGE_READONLY As Long = 2
Public Const PAGE_WRITECOPY As Long = &H8
Public Const PAGE_NOACCESS As Long = 1
Public Const PAGE_READWRITE As Long = &H4
Declare Function VarPtrArr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Declare Function IsBadWritePtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long
Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByVal lpflOldProtect As Long) As Long
Private bvHack(0) As Byte
Private lHackDelta As Long
Private bInitialized As Boolean
Public Function initialize() As Boolean ' By KarCrack
On Error GoTo Error_Handle
bvHack(-1) = bvHack(-1) 'Error check
lHackDelta = VarPtr(bvHack(0))
initialize = True
bInitialized = initialize
Exit Function
Error_Handle:
If Err.Number = 9 Then Debug.Print "Remember to tick 'Remove array boundary check' and compile before using"
' End
End Function
Public Function getByte(ByVal lptr As Long) As Byte ' By KarCrack
If bInitialized Then getByte = bvHack(lptr - lHackDelta)
End Function
Public Function getWord(ByVal lptr As Long) As Integer ' By KarCrack
If bInitialized Then getWord = makeWord(getByte(lptr + &H0), getByte(lptr + &H1))
End Function
Public Function getDWord(ByVal lptr As Long) As Long ' By KarCrack
If bInitialized Then getDWord = makeDWord(getWord(lptr + &H0), getWord(lptr + &H2))
End Function
Public Sub putByte(ByVal lptr As Long, ByVal bByte As Byte) ' By KarCrack
If bInitialized Then bvHack(lptr - lHackDelta) = bByte
End Sub
Public Sub putWord(ByVal lptr As Long, ByVal iWord As Integer) ' By KarCrack
If bInitialized Then Call putByte(lptr + &H0, iWord And &HFF): Call putByte(lptr + &H1, (iWord And &HFF00&) / &H100)
End Sub
Public Sub putDWord(ByVal lptr As Long, ByVal lDWord As Long) ' By KarCrack
If bInitialized Then Call putWord(lptr + &H0, IIf(lDWord And &H8000&, lDWord Or &HFFFF0000, lDWord And &HFFFF&)): Call putWord(lptr + &H2, (lDWord And &HFFFF0000) / &H10000)
End Sub
Public Function makeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long '[http://www.xbeat.net/vbspeed/c_MakeDWord.htm#MakeDWord05]
makeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function
' // Funciones agregadas...
Function makeWord(ByVal lByte As Byte, ByVal hByte As Byte) As Integer ' By BlackZeroX
makeWord = (((hByte And &H7F) * &H100&) Or lByte)
If hByte And &H80 Then makeWord = makeWord Or &H8000
End Function
'/////////////////////
Public Function allocMem(ByVal lSize As Long) As Long
' // By BlackZeroX (Thanks to Karcrack).
' // Retorna la Dirrecion de un SafeArray.
Dim pBuff() As Byte
If (lSize <= &H0) Then Exit Function
ReDim pBuff(0 To (lSize - 1))
allocMem = getDWord(VarPtrArr(pBuff))
putDWord VarPtrArr(pBuff), 0
End Function
Public Function reallocMem(ByVal lptr As Long, ByVal lSize As Long) As Long
' // By BlackZeroX (Thanks to Karcrack).
' // Retorna la Dirrecion de un SafeArray que se retorno en allocMem()/reallocMem().
Dim pBuff() As Byte
putDWord VarPtrArr(pBuff), lptr
If Not (lSize = &H0) Then
ReDim Preserve pBuff(0 To (lSize - 1))
Else
Erase pBuff
End If
reallocMem = getDWord(VarPtrArr(pBuff))
putDWord VarPtrArr(pBuff), 0
End Function
Public Function getMemData(ByVal lptr As Long) As Long
' // By BlackZeroX (Thanks to Karcrack).
' // lPtr debe ser el valor (Address) que retorno en allocMem()/reallocMem().
' // Esta funcion retorna la Dirrecion de memoria EDITABLE de lPtr (Dirrecion de un SafeArray).
' // Referencias.
' // http://msdn.microsoft.com/en-us/library/aa908603.aspx
If (lptr = &H0) Then Exit Function
getMemData = getDWord(lptr + &HC) ' // obtenemos pvData
End Function
Public Sub releaseMem(ByVal lptr As Long)
' // By BlackZeroX (Thanks to Karcrack).
' // lPtr debe ser la Dirrecion que retorno en allocMem()/reallocMem().
Dim pBuff() As Byte
putDWord VarPtrArr(pBuff), lptr
End Sub
Public Sub releaseMemStr(ByVal lptr As Long)
' // By BlackZeroX (Thanks to Karcrack).
' // lPtr debe ser la Dirrecion que retorno en cloneString().
Dim sStr As String
putDWord VarPtr(sStr), lptr
End Sub
Public Sub swapVarPtr(ByVal lpVar1 As Long, ByVal lpVar2 As Long)
' // By BlackZeroX (Thanks to Karcrack).
Dim lAux As Long
lAux = getDWord(lpVar1)
Call putDWord(lpVar1, getDWord(lpVar2))
Call putDWord(lpVar2, lAux)
End Sub
Public Function cloneString(ByVal lpStrDst As Long, ByVal sStrSrc As String) As Long
' // By BlackZeroX (Thanks to Karcrack).
' // lPtr -> Puntero a una variable destino (Preferiblemente String).
' // sStr -> Cadena Clonada ( gracias a Byval ).
Dim lpStrSrc As Long
If Not (lpStrDst = &H0) And (mMemoryEx.initialize = True) Then
Call mMemoryEx.swapVarPtr(lpStrDst, VarPtr(sStrSrc))
Call mMemoryEx.swapVarPtr(VarPtr(cloneString), VarPtr(sStrSrc))
End If
End Function
Public Function copyMemory(ByVal lpDst As Long, ByVal lpSrc As Long, ByVal lLn As Long) As Long
' // By BlackZeroX (Thanks to Karcrack).
Dim i As Long
If (lpSrc = &H0) Or (lpDst = &H0) Or (lLn = &H0) Then Exit Function
i = (lLn Mod 4)
If ((i And &H2) = &H2) Then
Call putWord(lpDst, getWord(lpSrc))
lpDst = (lpDst + 2)
lpSrc = (lpSrc + 2)
copyMemory = (copyMemory + 2)
lLn = (lLn - 2)
End If
If ((i And &H1) = &H1) Then
Call putByte(lpDst, getByte(lpSrc))
lpDst = (lpDst + 1)
lpSrc = (lpSrc + 1)
copyMemory = (copyMemory + 1)
lLn = (lLn - 1)
End If
For i = 0 To (lLn - 1) Step 4
Call putDWord(lpDst + i, getDWord(lpSrc + i))
Next
copyMemory = (copyMemory + lLn)
End Function
Dulces Lunas!¡.
Mostrar Mensajes
