http://foro.elhacker.net/programacion_vb/newmapiobfuscation_ofuscar_strings_de_las_apis_no_callapibyname-t265942.0.html

'---------------------------------------------------------------------------------------
' Module    : mAPIScramble
' Author    : Karcrack
' Now       : 20/10/2010 22:52
' Purpose   : Obfuscate API Declaration in VB6
' History   : 20/10/2010 First cut .........................................................
'---------------------------------------------------------------------------------------
 
Option Explicit
 
'KERNEL32
Private Declare Function WriteProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
 
Public Function UnScrambleAPI(ByVal sLibName As String, ByVal sFuncName As String) As Boolean
    Dim pBaseAddress    As Long
    Dim pVB5            As Long
    Dim pProjectInfo    As Long
    Dim pExtTable       As Long
    Dim pLibraryName    As Long
    Dim pFunctionName   As Long
    Dim iExtCount       As Long
    Dim iIndex          As Long
 
    'Do NOT run it on the IDE
    If App.LogMode = 0 Then Debug.Assert (0 = 1): Exit Function
 
    pBaseAddress = App.hInstance
    pVB5 = ReadDWORD(pBaseAddress + ReadDWORD(pBaseAddress + ReadDWORD(pBaseAddress + &H3C) + &H28) + 1)
    pProjectInfo = ReadDWORD(pVB5 + &H30)
    pExtTable = ReadDWORD(pProjectInfo + &H234)
    iExtCount = ReadDWORD(pProjectInfo + &H238)
 
    For iIndex = 0 To iExtCount - 1
        If ReadDWORD(pExtTable) <> 6 Then
            pLibraryName = ReadDWORD(ReadDWORD(pExtTable + &H4) + &H0)
            pFunctionName = ReadDWORD(ReadDWORD(pExtTable + &H4) + &H4)
 
            If (pLibraryName <> 0) And (pFunctionName <> 0) Then
                If ReadString(pLibraryName) = sLibName Then
                    If ReadString(pFunctionName) = sFuncName Then
                        Call WriteString(pLibraryName, Decrypt(sLibName))
                        Call WriteString(pFunctionName, Decrypt(sFuncName))
                        UnScrambleAPI = True
                    End If
                End If
            End If
        End If
        pExtTable = pExtTable + 8
    Next iIndex
End Function
 
Private Function ReadDWORD(ByVal lPtr As Long) As Long
    Call WriteProcessMemory(-1, ReadDWORD, ByVal lPtr&, &H4, ByVal 0&)
End Function
 
Private Sub WriteDWORD(ByVal lPtr As Long, ByVal lLng As Long)
    Call WriteProcessMemory(-1, ByVal lPtr&, lLng, &H4, ByVal 0&)
End Sub
 
Private Function ReadString(ByVal lPtr As Long) As String
    Dim i               As Long
    Dim b               As Byte
 
    Do
        Call WriteProcessMemory(-1, b, ByVal lPtr& + i, &H1, ByVal 0&)
        If b = 0 Then Exit Do
        ReadString = ReadString & Chr$(b)
        i = i + 1
    Loop
End Function
 
Private Sub WriteString(ByVal lPtr As Long, ByVal sStr As String)
    Dim bvStr()         As Byte
 
    bvStr = StrConv(sStr, vbFromUnicode)
    Call WriteProcessMemory(-1, ByVal lPtr, bvStr(0), UBound(bvStr) + 1, ByVal 0&)
End Sub
 
Private Function Decrypt(ByVal sData As String) As String
    Dim i               As Long
 
    For i = 1 To Len(sData)
        Decrypt = Decrypt & Chr$(Asc(Mid$(sData, i, 1)) - 1)
    Next i
End Function

http://www.box.net/shared/sr8rky5tku