如何使用VB模拟拖放文件操作到一个别的程序

Question

大家好，我想实现一个功能，模拟拖放文件的消息给别的程序（是发给一个非自己的程序，不是接受拖放消息）网上找到了一段c++的代码，经试验成功，但是不知道怎么改成VB的代码，请大家帮忙看看
#include "stdafx.h"
#include "windows.h"
#include "shlobj.h"
int main(int argc, char* argv[])
{
char szFile[] = "W:\\zzzzzzzz\\aa\\a.ini"; 
HWND hWnd = ::FindWindow("Notepad", NULL); 
if(hWnd == NULL) return; 

DWORD dwBufSize = sizeof(DROPFILES) + sizeof(szFile) + 1;  BYTE *pBuf = NULL; 
LPSTR pszRemote = NULL; 
HANDLE hProcess = NULL; 
 
 __try { 
 pBuf = new BYTE[dwBufSize]; 
 if(pBuf == NULL) __leave; 
 
 memset(pBuf, 0, dwBufSize); 
 DROPFILES *pDrop = (DROPFILES *)pBuf; 
 pDrop->pFiles = sizeof(DROPFILES); 
 strcpy((char *)(pBuf + sizeof(DROPFILES)), szFile); 
 
 DWORD dwProcessId; 
 GetWindowThreadProcessId(hWnd, &dwProcessId); 
 hProcess = OpenProcess(PROCESS_VM_OPERATION | PROCESS_VM_WRITE, FALSE, dwProcessId); 
 if(hProcess == NULL) __leave; 
 
 pszRemote = (LPSTR)VirtualAllocEx(hProcess, NULL, dwBufSize, MEM_COMMIT, PAGE_READWRITE); 
 if(pszRemote == NULL) __leave; 
 
 if(WriteProcessMemory(hProcess, pszRemote, pBuf, dwBufSize, 0)) 
 ::SendMessage(hWnd, WM_DROPFILES, (WPARAM)pszRemote, NULL); 
 } 
 __finally { 
 if(pBuf != NULL) delete []pBuf; 
 if(pszRemote != NULL) VirtualFreeEx(hProcess, pszRemote, dwBufSize, MEM_FREE); 
 if(hProcess != NULL) CloseHandle(hProcess); 
 } 
}
如上，这段代码也是在CSDN找到的，有一些语句不知道该怎么用VB写，比如
DROPFILES *pDrop = (DROPFILES *)pBuf; 
或
strcpy((char *)(pBuf + sizeof(DROPFILES)), szFile); 
有哪位能帮忙看看，改写成VB可以使用的代码，或者有别的方法实现相同功能（通过Sendmessage WM_DROPFILES使别的程序接受到一个文件拖放操作），请不吝赐教，谢谢！

Answer 1

    Const sFile = "W:\\zzzzzzzz\\aa\\a.ini"
    Dim tDF As DROPFILES
    Dim aFile() As Byte
    Dim aBuf() As Byte
    Dim lBufSize As Long
    Dim pBuf As Long
    
    aFile = StrConv(sFile, vbFromUnicode) 'sFile 转化为 Ansi 字节数组
    lBufSize = Len(tDF) + (UBound(aFile) + 1) + 1
    ReDim aBuf(lBufSize - 1)
    pBuf = VarPtr(aBuf(0))
    
    '设置 DROPFILES 的属性
    tDF.pFiles = Len(tDF)
    '将 DROPFILES 复制到 Buf 中
    CopyMemory ByVal pBuf, ByVal VarPtr(tDF), Len(tDF)    CopyMemory ByVal VarPtr(aBuf(Len(tDF))), ByVal VarPtr(aFile(0)), (UBound(aFile) + 1)余下的应该会写了吧

Answer 2

您好，非常感谢您的提点，我试着用vb6和03改写，出现了一些错误，导致VB6直接崩溃不知如何调试，这是我尝试的代码，能否再请您帮我看一下        Const sFile = "W:\\zzzzzzzz\\aa\\a.ini" ' char szFile[] = "W:\\zzzzzzzz\\aa\\a.ini";
        Dim pDrop As DROPFILES
        Dim szFile() As Byte
        Dim aBuf() As Byte
        Dim dwBufSize As Long
        Dim pBuf As Long        szFile = StrConv(sFile, vbFromUnicode)
        Debug.Print LBound(szFile)
        'char szFile[] = "W:\\zzzzzzzz\\aa\\a.ini";        dwBufSize = Len(pDrop) + (UBound(szFile) + 1) + 1
        'DWORD dwBufSize = sizeof(DROPFILES) + sizeof(szFile) + 1;        ReDim aBuf(dwBufSize - 1)
        pBuf = VarPtr(aBuf(0))        '设置 DROPFILES 的属性
        pDrop.pFiles = Len(pDrop)
        '将 DROPFILES 复制到 Buf 中
        Call CopyMemory(ByVal pBuf, ByVal VarPtr(pDrop), Len(pDrop))
        'Debug.Print LBound(szFile)
        Call CopyMemory(ByVal VarPtr(aBuf(Len(pDrop))), ByVal VarPtr(szFile(0)), (UBound(szFile) + 1))
        Dim hWnd As Long
        hWnd = FindWindow("Notepad", vbNullString)
        'HWND hWnd = ::FindWindow("Notepad", NULL);
        If hWnd = 0 Then MsgBox ("没有找到进程！"): Exit Sub
        Dim dwProcessId As Long
        Call GetWindowThreadProcessId(hWnd, dwProcessId)
        Dim hProcess As Long
        hProcess = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, False, dwProcessId)        If hProcess = 0 Then MsgBox ("无法打开句柄！"): Exit Sub
        Dim pszRemote() As Byte        pszRemote = StrConv(sFile, vbFromUnicode)
        Dim pszBuf As Long
        pszBuf = VirtualAllocEx(hProcess, Null, dwBufSize, MEM_COMMIT, PAGE_READWRITE)
        Call CopyMemory(VarPtr(pszRemote(0)), pszBuf, dwBufSize)
        'If IsNothing(pszRemote) Then MsgBox ("虚拟函数失败"): Exit Sub
        If (WriteProcessMemory(hProcess, VarPtr(pszRemote(0)), VarPtr(aBuf(0)), dwBufSize, 0)) Then
            Call SendMessage(hWnd, WM_DROPFILES, VarPtr(pszRemote(0)), 0)
        Else
            MsgBox ("write内存失败")
        End If
在vb.net中，执行到WriteProcessMemory失败，但是在FindWindow中把句柄改成窗口自身，WriteProcessMemory成功，只是获得的消息中文件数目为-1，肯定是我哪里写错了，但找了一段时间没有找出来        Const sFile = "W:\\zzzzzzzz\\aa\\a.ini" ' char szFile[] = "W:\\zzzzzzzz\\aa\\a.ini"; 
        Dim pDrop As DROPFILES
        Dim szFile() As Byte
        Dim aBuf() As Byte
        Dim dwBufSize As Int32
        Dim pBuf As Int32        szFile = System.Text.Encoding.ASCII.GetBytes(sFile)
        'char szFile[] = "W:\\zzzzzzzz\\aa\\a.ini";         dwBufSize = Len(pDrop) + (UBound(szFile) + 1) + 1
        'DWORD dwBufSize = sizeof(DROPFILES) + sizeof(szFile) + 1;         ReDim aBuf(dwBufSize - 1)
        pBuf = VarPtr(aBuf(0))        '设置 DROPFILES 的属性
        pDrop.pFiles = Len(pDrop)
        '将 DROPFILES 复制到 Buf 中
        Call CopyMemory(pBuf, VarPtr(pDrop), Len(pDrop))        Call CopyMemory(VarPtr(aBuf(Len(pDrop))), VarPtr(szFile(0)), (UBound(szFile) + 1))
        Dim hWnd As Int32
        hWnd = FindWindow("Notepad", vbNullString)
        'HWND hWnd = ::FindWindow("Notepad", NULL); 
        If hWnd = 0 Then MsgBox("没有找到进程！") : Exit Sub
        Dim dwProcessId As Long
        Call GetWindowThreadProcessId(hWnd, dwProcessId)
        Dim hProcess As IntPtr
        hProcess = New IntPtr(OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, False, dwProcessId))        If IntPtr.Equals(hProcess, IntPtr.Zero) Then MsgBox("无法打开句柄！") : Exit Sub
        Dim pszRemote() As Byte        pszRemote = System.Text.Encoding.ASCII.GetBytes(sFile)
        Dim pszBuf As Int32
        pszBuf = VirtualAllocEx(hProcess.ToInt32, 0, dwBufSize, MEM_COMMIT, PAGE_READWRITE)
        Call CopyMemory(VarPtr(pszRemote(0)), pszBuf, dwBufSize)
        If pszRemote Is Nothing Then MsgBox("虚拟函数失败") : Exit Sub
        If (WriteProcessMemory(hProcess, VarPtr(pszRemote), VarPtr(aBuf(0)), dwBufSize, 0)) Then
            SendMessage(hWnd, WM_DROPFILES, VarPtr(pszRemote(0)), 0)
        Else
            MsgBox("write内存失败")
        End If

Answer 3

原始代码中，pszRemote 是在 NotePad 进程申请的内存块，却给你翻译成了本进程内的数组了!
跨进程不能用 CopyMemory 而是用 WriteProcessMemory，原始代码就是这么做的，你怎么会多出一个 CopyMemory?
原始代码中 VirtualAllocEx 返回值需要判断一下是否成功。
最后 VB 字符串不存在转义符，所以不需要用 \\ 表示 \。

Answer 4

alifriend，能不能给个实验成功的代码？ 本人水平有限，依据上面的代码我研究了半天也没有成功总有不同的错误出现。谢谢！

Answer 5

帮你结贴 此代码测试通过Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type DROPFILES
    pFiles As Long
    pt As POINTAPI
    fNC As Long
    fWide As Long
End TypePrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As LongPrivate Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Long, ByVal lpString2 As String) As LongPrivate Const MEM_COMMIT = &H1000
Private Const PAGE_READWRITE = &H4Private Const PROCESS_VM_OPERATION = (&H8)
Private Const PROCESS_VM_READ = (&H10)
Private Const PROCESS_VM_WRITE = (&H20)Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
Private Const WM_DROPFILES = &H233
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, lpAddress As Any, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Const MEM_FREE = &H10000
Private Const HEAP_ZERO_MEMORY = &H8
Sub main()
    Dim szFile$: szFile = GetAppPath & "TEST.INI"
    Dim hwnd&: hwnd = FindWindow("Notepad", vbNullString)
    If (hwnd = 0) Then Exit Sub
    Dim dwBufSize&: dwBufSize = Len(DROPFILES) + LenB(szFile) + 1
    Dim pBuf&: pBuf = 0
    Dim pszRemote&
    Dim hProcess&: hProcess = 0
 '     __try {
     pBuf = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, dwBufSize) 'pBuf = new BYTE[dwBufSize];
     If pBuf = 0 Then GoTo leave 'if(pBuf == NULL) __leave;
      
     Dim pDrop As DROPFILES:  'DROPFILES *pDrop = (DROPFILES *)pBuf;
     pDrop.pFiles = Len(pDrop) 'pDrop->pFiles = sizeof(DROPFILES);
     CopyMemory ByVal pBuf, pDrop, Len(pDrop)
     lstrcpy pBuf + Len(pDrop), szFile  'strcpy((char *)(pBuf + sizeof(DROPFILES)), szFile);
 
     Dim dwProcessId&: Call GetWindowThreadProcessId(hwnd, dwProcessId)
     hProcess = OpenProcess(PROCESS_VM_WRITE Or PROCESS_VM_READ Or PROCESS_VM_OPERATION, False, dwProcessId)
     If (hProcess = 0) Then GoTo leave
 
     'pszRemote = (LPSTR)VirtualAllocEx(hProcess, NULL, dwBufSize, MEM_COMMIT, PAGE_READWRITE);
     pszRemote = VirtualAllocEx(hProcess, ByVal 0, dwBufSize, MEM_COMMIT, PAGE_READWRITE)
     If (pszRemote = 0) Then GoTo leave
 
     If (WriteProcessMemory(hProcess, ByVal pszRemote, ByVal pBuf, dwBufSize, 0)) Then
        Call SendMessage(hwnd, WM_DROPFILES, pszRemote, ByVal 0&)
     End If
'     __finally {
leave:
     If pBuf <> 0 Then HeapFree GetProcessHeap, 0, ByVal pBuf 'if(pBuf != NULL) delete []pBuf;
     If (pszRemote <> 0) Then Call VirtualFreeEx(hProcess, ByVal pszRemote, dwBufSize, MEM_FREE)
     If (hProcess <> 0) Then Call CloseHandle(hProcess)
     
End SubFunction GetAppPath$()
    GetAppPath = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
End FunctionPrivate Sub Command1_Click()
Shell "Notepad.exe"
    Call main
End Sub