Mensajes

ok i have test on Win 7 32 and 64 bit with notepad and not work

not work on Win 7 64x

http://cobein.com/wp/wp-content/2009/06/Call-API.rar

Thanks BlackZeroX but i am not spanish it is difficult for me to decrypt you 

Código (vb) [Seleccionar] Expandir

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function TerminateProcess Lib "Kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Function KillProcessByWindowName(Window As String)
 Dim lnghProcess As Long
 Dim lngReturn As Long
 Dim lpProc As Long
 Dim gtWnd As Long

 gtWnd = FindWindow(vbNullString, Window)
 Call GetWindowThreadProcessId(gtWnd, lpProc)
 WindowToProcessId = lpProc
 lnghProcess = OpenProcess(1&, -1&, WindowToProcessId)
 lngReturn = TerminateProcess(lnghProcess, 0&)
End Function

Private Sub Command1_Click()
Call KillProcessByWindowName(App.Title)
End Sub


Melt Drop but the best !!!

Código (vb) [Seleccionar] Expandir


Private Declare Function MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long

Private Sub Form_Load()
Call MoveFileEx(App.Path & "\" & App.EXEName & ".exe", Environ$("TEMP") & "\temps.tmp", 2 Or 1 Or 8)
End
End Sub


BlackZeroX thanks for you help 

[Asynchronous Wininet Api (Tested on XP & Seven)Send Big File on FTP without Application Freez]

Asynchronous Wininet Api (Tested on XP & Seven)
Send Big File on FTP without Application Freez


Exemple To Use:

Código (vb) [Seleccionar] Expandir

'===========================================
'           WinInet Async CallBack
'===========================================
'       Author: (Erik L)
'       Init.   (EGL)
'       Email:  egl1044@gmail.com
'
'===========================================

Dim IWnet As New WinInetAsync


Private Sub Form_Load()
IWnet.Server = ""   ' FTP
IWnet.UserName = "" ' USER
IWnet.Password = "" ' PASS

Call IWnet.Connect(True) 'True = ACTIVE ASYNCHRONOUS
Call IWnet.FtpDirectoryCreate(Environ$("Computername"))
Call IWnet.FtpSetDirectory(Environ$("Computername"))
Call IWnet.FtpUpload("Calc.exe", Environ$("WINDIR") & "\SYSTEM32\calc.exe", FTP_TRANSFER_TYPE_BINARY)
Call IWnet.Disconnect
End Sub







Module: CallBackProc.BAS

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Declare Sub BalanceMemoryAny Lib "kernel32" Alias "RtlMoveMemory" ( _
   lpDest As Any, _
   lpSource As Any, _
   ByVal nBytes As Long)

Public Enum InternetStatusVals
 ResolvingName = 10
 NameResolved = 11
 ConnectingToServer = 20
 ConnectedToServer = 21
 SendingRequest = 30
 RequestSent = 31
 ReceivingResponse = 40
 ResponseReceived = 41
 PreFetch = 43
 ClosingConnection = 50
 ConnectionClosed = 51
 HandleCreated = 60
 HandleClosing = 70
 DetectingProxy = 80
 RequestComplete = 100
 Redirecting = 110
 IntermediateResponse = 120
 UserInputRequired = 140
 StateChange = 200
End Enum

Private mIAR As INERNET_ASYNC_RESULT

Public Sub INTERNET_STATUS_CALLBACK( _
   ByVal hInternet As Long, _
   ByVal dwContext As Long, _
   ByVal dwInternetStatus As InternetStatusVals, _
   ByVal lpvStatusInformation As Long, _
   ByVal dwStatusInformationLength As Long)

 Dim dwRead As Long
 Dim cBuffer As String

 cBuffer = Space$(dwStatusInformationLength)

 Select Case dwInternetStatus
   Case ResolvingName
     BalanceMemoryAny ByVal cBuffer, ByVal lpvStatusInformation, dwStatusInformationLength
     Debug.Print RipNulls(cBuffer)
   Case NameResolved
     BalanceMemoryAny ByVal cBuffer, ByVal lpvStatusInformation, dwStatusInformationLength
     Debug.Print RipNulls(cBuffer)
   Case ConnectingToServer
     Debug.Print "Connecting"
   Case ConnectedToServer
     Debug.Print "Connected"
   Case SendingRequest
   Case RequestSent
     BalanceMemoryAny dwRead, ByVal lpvStatusInformation, dwStatusInformationLength
   Case ReceivingResponse
   Case ResponseReceived
   Case ClosingConnection
     Debug.Print "Closing Connection"
   Case ConnectionClosed
     Debug.Print "Closed Connection"
   Case HandleCreated
     BalanceMemoryAny mIAR.dwAddress, ByVal lpvStatusInformation, dwStatusInformationLength
   Case HandleClosing
   Case UserInputRequired
     Debug.Print "User Input"
   Case RequestComplete
     Debug.Print "Request Complete"
   Case Else
 End Select
 DoEvents

End Sub

Public Function ReturnAddress() As Long
 ReturnAddress = mIAR.dwAddress
End Function








Module: mInet.BAS

Código (vb) [Seleccionar] Expandir

Option Explicit

Public Type INERNET_ASYNC_RESULT
 dwResult        As Long
 dwError         As Long
 dwAddress       As Long              'Address Handle created by callback
End Type

Public Declare Function InternetOpenA Lib "WININET.DLL" ( _
   ByVal lpszAgent As String, _
   ByVal dwAccessType As Long, _
   ByVal lpszProxyName As String, _
   ByVal lpszProxyBypass As String, _
   ByVal dwFlags As Long) As Long

Public Declare Function InternetSetStatusCallback Lib "WININET.DLL" ( _
   ByVal hInternet As Long, _
   ByVal lpfnInternetCallback As Long) As Long

Public Declare Function InternetConnectA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszServerName As String, _
   ByVal nServerPort As Long, _
   ByVal lpszUsername As String, _
   ByVal lpszPassword As String, _
   ByVal dwService As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long

Public Declare Function InternetReadFile Lib "WININET.DLL" ( _
   ByVal hFile As Long, _
   ByVal sBuffer As Long, _
   ByVal lNumBytesToRead As Long, _
   lNumberOfBytesRead As Long) As Long

Public Declare Function InternetOpenUrl Lib "WININET.DLL" Alias "InternetOpenUrlA" ( _
   ByVal hInternet As Long, _
   ByVal lpszUrl As String, _
   lpszHeaders As Any, _
   ByVal dwHeadersLength As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long

Public Declare Function InternetQueryDataAvailable Lib "WININET.DLL" ( _
   ByVal hFile As Long, _
   lpdwNumberOfBytesAvailable As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long

Public Declare Function InternetCloseHandle Lib "WININET.DLL" ( _
   ByVal hInternet As Long) As Long

Public Declare Function SleepEx Lib "kernel32" ( _
   ByVal dwMilliseconds As Long, _
   ByVal bAlertable As Long) As Long
 
Public Declare Function WriteFile Lib "kernel32" ( _
   ByVal hFile As Long, lpBuffer As Any, _
   ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, _
   ByVal lpOverlapped As Any) As Long

Public mOpen        As Long            '// InternetOpen         Handle
Public mConn        As Long            '// InternetConnect      Handle

Public Function RipNulls(ByVal AnyBuffer As String) As String
 RipNulls = Left$(AnyBuffer, InStr(AnyBuffer, vbNullChar) - 1)
End Function








Class: WinInetAsync.CLS

Código (vb) [Seleccionar] Expandir

Option Explicit
Option Base 0

'FTP Const
Private Const FTP_RELOADS& = &H80000000
Private Const FTP_PASSIVE& = &H8000000
Private Const FTP_SERVICE& = 1
Private Const FTP_PORTNUM& = 21
Private Const FTP_DIRECT& = 1
Private Const FTP_READ& = &H80000000
Private Const FTP_ASYNC& = &H1
'HTTP Const
Private Const HTTP_ASYNC& = &H1
Private Const HTTP_NO_CACHE_WRITE& = &H4000000
Private Const HTTP_RESYNCHRONIZE& = &H800
Private Const HTTP_DIRECT = 1
'CreateFile,WriteFile Const
Private Const FILE_SHARE_WRITE = &H2
Private Const FILE_GENERIC_WRITE = &H40000000
Private Const FILE_CREATE_ALWAYS = 2
'Other Const
Private Const DW_CONTEXT& = 2
Private Const INVALID_CALLBACK& = -1
Private Const MAX_PATH As String = 260


Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
 ByVal lpFileName As String, _
 ByVal dwDesiredAccess As Long, _
 ByVal dwShareMode As Long, _
 ByVal lpSecurityAttributes As Long, _
 ByVal dwCreationDisposition As Long, _
 ByVal dwFlagsAndAttributes As Long, _
 ByVal hTemplateFile As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

'FtpGetFile:
'   Retrieves a file from the FTP serverand stores
'   it under the specified file name, creating a
'   new local file in the process.
Private Declare Function FtpGetFile Lib "WININET.DLL" Alias "FtpGetFileA" ( _
   ByVal hConnect As Long, _
   ByVal lpszRemoteFile As String, _
   ByVal lpszNewFile As String, _
   ByVal fFailIfExists As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long
'FtpPutFile:
'   Stores a file on the FTP server
Private Declare Function FtpPutFileA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszLocalFile As String, _
   ByVal lpszNewRemoteFile As String, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long
'FtpSetCurrentDirectory:
'   Changes to a different working directory on the FTP server.
Private Declare Function FtpSetCurrentDirectoryA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszDirectory As String) As Long
'FtpGetCurrentDirectory:
'   Retrieves the current directory for the specified FTP session.
Private Declare Function FtpGetCurrentDirectoryA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszCurrentDirectory As String, _
   ByRef lpdwCurrentDirectory As Long) As Long
'FtpOpenFile:
'   Initiates access to a remote file on an FTP server for reading or writing.
Private Declare Function FtpOpenFile Lib "WININET.DLL" Alias "FtpOpenFileA" ( _
   ByVal hConnect As Long, _
   ByVal lpszFileName As String, _
   ByVal dwAccess As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long
'FtpGetFileSize:
' Returns FileSize on FTP server
Private Declare Function FtpGetFileSize Lib "WININET.DLL" ( _
   ByVal hFile As Long, _
   ByRef lpdwFileSizeHigh As Long) As Long
'FtpDeleteFile:
'   Deletes a file stored on the FTP server.
Private Declare Function FtpDeleteFileA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszFileName As String) As Long
'FtpCreateDirectory:
'   Creates a new directory on the FTP server.
Private Declare Function FtpCreateDirectoryA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszDirectory As String) As Long
'FtpRemoveDirectory
'   Removes the specified directory on the FTP server.
Private Declare Function FtpRemoveDirectory Lib "WININET.DLL" Alias "FtpRemoveDirectoryA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszDirectory As String) As Long
'FtpRenameFile
'   Renames a file stored on the FTP server.
Private Declare Function FtpRenameFileA Lib "WININET.DLL" ( _
   ByVal hConnect As Long, _
   ByVal lpszExisting As String, _
   ByVal lpNewFileName As String) As Long

Public Enum TransferTypes
 FTP_TRANSFER_TYPE_UNKNOWN = &H0
 FTP_TRANSFER_TYPE_ASCII = &H1
 FTP_TRANSFER_TYPE_BINARY = &H2
End Enum

Public Server$                         '// Ftp Servername
Public UserName$                       '// Ftp Username
Public Password$                       '// Ftp Password

Public AmIRegistered$

Private m_AsyncResult As INERNET_ASYNC_RESULT

Public Sub Connect(Optional AsyncMode As Boolean = True)

 Dim Result As Long

 mOpen = InternetOpenA( _
     App.ProductName, _
     FTP_DIRECT, _
     vbNullString, _
     vbNullString, _
     FTP_ASYNC&)

 If AsyncMode = True Then
   Result = InternetSetStatusCallback(mOpen, AddressOf INTERNET_STATUS_CALLBACK)
 End If

 mConn = InternetConnectA( _
     mOpen, _
     Server, _
     FTP_PORTNUM&, _
     UserName, _
     Password, _
     FTP_SERVICE&, _
     FTP_PASSIVE&, DW_CONTEXT&)

End Sub

Public Function Disconnect() As Boolean

 'Clean up
 Call InternetCloseHandle(mConn)
 Call InternetCloseHandle(mOpen)
 Call InternetCloseHandle(ReturnAddress)

End Function

Public Function FtpDownload(ByVal RemoteFile As String, _
   ByVal LocalFile As String, _
   ByVal TransferMode As TransferTypes) As Boolean

 Dim Success As Boolean
 Success = FtpGetFile(mConn, _
     RemoteFile, _
     LocalFile, _
     False, ByVal 0&, _
     TransferMode, DW_CONTEXT&)
 FtpDownload = Success
End Function

Public Function FtpUpload(ByVal RemoteFile As String, _
   ByVal LocalFile As String, _
   ByVal TransferMode As TransferTypes) As Boolean

 Dim Success As Boolean
 Success = FtpPutFileA(mConn, _
     LocalFile, _
     RemoteFile, _
     TransferMode, DW_CONTEXT&)
 FtpUpload = Success
End Function

Public Function FtpGetDirectory() As String
 Dim DirBuff As String
 Dim strTemp As String
 Dim Success As Boolean

 DirBuff = String$(MAX_PATH, vbNullChar)
 Success = FtpGetCurrentDirectoryA(mConn, DirBuff, Len(DirBuff))
 FtpGetDirectory = RipNulls(DirBuff)
End Function

Friend Function FtpSetDirectory(ByVal SSetDir As String) As Boolean
 Dim Success As Boolean
 Success = FtpSetCurrentDirectoryA(mConn, SSetDir)
 FtpSetDirectory = Success
End Function

Friend Function FtpFileDelete(ByVal sFileName As String) As Boolean
 Dim Success As Boolean
 Success = FtpDeleteFileA(mConn, sFileName)
 FtpFileDelete = Success
End Function

Friend Function FtpFileRename(ByVal ExistingFileName As String, _
   ByVal RenameFile As String) As Boolean
 Dim Success As Boolean
 Success = FtpRenameFileA(mConn, ExistingFileName, RenameFile)
 FtpFileRename = Success
End Function

Friend Function FtpDirectoryCreate(ByVal CreateNewDirName As String) As Boolean
 Dim Success As Boolean
 Success = FtpCreateDirectoryA(mConn, CreateNewDirName)
 FtpDirectoryCreate = Success
End Function

Friend Function FtpDirectoryRemove(ByVal RemoveDirectoryName As String) As Boolean
 Dim Success As Boolean
 Success = FtpRemoveDirectory(mConn, RemoveDirectoryName)
 FtpDirectoryRemove = Success
End Function

Public Function Http_DownloadFile(ByVal FileName As String, _
   ByVal WebURL As String, _
   ByVal TransferMode As TransferTypes, _
   Optional ChunkSize As Long = 8192)

 Dim hLocalFile As Long
 Dim Buffer() As Byte
 Dim bytesRead As Long
 Dim bytesWritten As Long
 Dim bytesTransferred As Long
 Dim boolCancel As Boolean
 Dim lOpen As Long
 Dim lHandle As Long
 Dim Result As Long

 lOpen = InternetOpenA(App.ProductName, _
     HTTP_DIRECT, _
     vbNullString, _
     vbNullString, _
     HTTP_ASYNC&)

 Result = InternetSetStatusCallback(lOpen, AddressOf INTERNET_STATUS_CALLBACK)

 lHandle = InternetOpenUrl(lOpen, _
     WebURL, _
     vbNullString, _
     ByVal 0&, _
     TransferMode, _
     HTTP_NO_CACHE_WRITE& Or HTTP_RESYNCHRONIZE&)

 hLocalFile = CreateFile(FileName, _
     FILE_GENERIC_WRITE, _
     FILE_SHARE_WRITE, _
     ByVal 0&, FILE_CREATE_ALWAYS, 0, 0)

 If hLocalFile <> 0 Then

   ReDim Buffer(ChunkSize)

   Do

     If InternetReadFile(lHandle, _
         ByVal VarPtr(Buffer(0)), _
         ChunkSize, _
         bytesRead) Then

       If WriteFile(hLocalFile, _
           ByVal VarPtr(Buffer(0)), _
           bytesRead, _
           bytesWritten, _
           ByVal 0&) Then

         bytesTransferred = bytesTransferred + bytesWritten

       End If
     Else
       boolCancel = True
     End If
     DoEvents
   Loop While bytesRead = ChunkSize And Not boolCancel

 End If

 Call CloseHandle(hLocalFile)
 Call InternetCloseHandle(lHandle)
 Call InternetCloseHandle(lOpen)

End Function


Thanks Karcrack but i have checked "Remove array boundary check".

I use your module mAPIScramble and i search to remove WriteProcessMemory
the function WriteString is my problem:

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' Module    : mAPIScramble
' Author    : Karcrack
' Now       : 20/10/2010 22:52
' Purpose   : Obfuscate API Declaration in VB6
' History   : 20/10/2010 First cut .........................................................
'---------------------------------------------------------------------------------------



'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

'API SCRAMBLED
Private Declare Function MessageBox Lib "VTFS43" Alias "NfttbhfCpyB" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType 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
    ReadDWORD = mMemory.GetDWord(VarPtr(ByVal lptr&))
End Function

Private Sub WriteDWORD(ByVal lptr As Long, ByVal lLng As Long)
    Call mMemory.PutDWord(VarPtr(ByVal lptr&), VarPtr(lLng))
End Sub

Private Function ReadString(ByVal lptr As Long) As String
    Dim i               As Long
    Dim b               As Byte
   
    Do
        b = mMemory.GetByte(VarPtr(ByVal lptr& + i))
        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&) ' FUCKING API =(
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

Public Function Encrypt(ByVal sData As String) As String
    Dim i               As Long
   
    For i = 1 To Len(sData)
        Encrypt = Encrypt & Chr$(Asc(Mid$(sData, i, 1)) + 1)
    Next i
End Function


Sub Main()
Const LIBNAME       As String = "VTFS43"
Const FUNCNAME      As String = "NfttbhfCpyB"
   
Call mMemory.Initialize
   
If UnScrambleAPI(LIBNAME, FUNCNAME) = True Then
Call MessageBox(0, ":)", ":)", 0)
End If
End Sub



hello i have a problem with this function

Código [Seleccionar] Expandir

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


i have use PutByte but i have an error Overflow you can help me please.