VB关于OLE拖放的问题

发布网友发布时间：2022-05-18 19:46

共1个回答

热心网友时间：2023-10-28 00:15

'根据你的建议，重新作了修改,解决"我的文档"无法显示的问题"。
'分二步：
'一、新建一个模块，复制下面代码到模块中
Option Explicit
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 SendMessageByNum Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessageByString Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetForegroundWindow Lib "User32" () As Long
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 GetWindowText Lib "User32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetCapture Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetParent Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub keybd_event Lib "User32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const PROCESS_TERMINATE = &H1
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private Const CB_GETCURSEL = &H147
Private Const CB_GETLBTEXTLEN = &H149
Private Const CB_GETLBTEXT = &H148

Private Type POINTAPI
X As Long
Y As Long
End Type

Function GetPath() As String
Dim lu_POINT As POINTAPI, Curwindow As Long, parentWnd As Long
Dim S As String, Hwd As Long, K As Long, Recn As Long
Call GetCursorPos(lu_POINT)
Curwindow = WindowFromPoint(lu_POINT.X, lu_POINT.Y)
parentWnd = GetParent(Curwindow)
Do While parentWnd <> 0
Curwindow = GetParent(parentWnd)
If Curwindow = 0 Then Exit Do
parentWnd = Curwindow
Loop
Hwd = parentWnd
S = String(254, 0)
K = GetClassName(Hwd, S, 254)
S = StrConv(LeftB(StrConv(S, vbFromUnicode), K), vbUnicode)

Select Case LCase(S)
Case "cabinetwclass"
Hwd = FindWindowEx(Hwd, 0, "WorkerW", vbNullString)
Hwd = FindWindowEx(Hwd, 0, "ReBarWindow32", vbNullString)
Hwd = FindWindowEx(Hwd, 0, "ComboBoxEx32", vbNullString)
Recn = SendMessage(Hwd, CB_GETCURSEL, K, 0)
K = SendMessageByNum(Hwd, CB_GETLBTEXTLEN, Recn, 0)
If K > 0 Then
GetPath = String(K, 0)
SendMessageByString Hwd, CB_GETLBTEXT, Recn, GetPath
If GetPath = "我的文档" Then
GetPath = CreateObject("Wscript.Shell").SpecialFolders("MyDocuments")
End If
End If
Case "progman"
GetPath = CreateObject("Shell.Application").Namespace(&H10).self.Path
End Select

End Function

'二、当一个对象拖动到资源管理器后，调用下面函数即可获得外部已打开的那个文件夹的路径：
dim Path as string
Path=GetPath