Private Sub ListView1_OLESetData(Data As MSComctlLib.DataObject, DataFormat As Integer) '要确保指定文件在磁盘上存在,否则会提示文件找不到 '如果文件数据保存在数据库中,则先要取出保存在磁盘上 Data.Files.Add ListView1.SelectedItem.Text End SubPrivate Sub ListView1_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long) AllowedEffects = vbDropEffectCopy Data.Clear Data.SetData , vbCFFiles End Sub
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _ "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long'剪贴版处理函数 Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd _ As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _ As Long, ByVal hMem As Long) As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat _ As Long) As Long Private Declare Function IsClipboardFormatAvailable Lib "user32" _ (ByVal wFormat As Long) As LongPrivate Declare Function DragQueryFile Lib "shell32.dll" Alias _ "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, _ ByVal lpStr As String, ByVal ch As Long) As Long Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal _ hDrop As Long, lpPoint As POINTAPI) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags _ As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As _ Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As _ Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As _ Long) As Long Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, Source As Any, ByVal Length As Long)上 If SetClipboardData(CF_HDROP, hGlobal) Then clipCopyFiles = True End If End If Call CloseClipboard End If '确定剪贴版的数据格式是文件,并打开剪贴版 If IsClipboardFormatAvailable(CF_HDROP) Then If OpenClipboard(0&) Then hDrop = GetClipboardData(CF_HDROP) '获得文件数 nFiles = DragQueryFile(hDrop, -1&, "", 0)
ReDim Files(0 To nFiles - 1) As String filename = Space(MAX_PATH)
For i = 0 To nFiles - 1 '根据获取的每一个文件执行文件拷贝操作 Call DragQueryFile(hDrop, i, filename, Len(filename)) Files(i) = TrimNull(filename) tfStr.pFrom = Files(i) SHFileOperation tfStr Next i Form1.File1.Refresh Form1.Dir1.Refresh
Call CloseClipboard End If clipPasteFiles = nFiles End If我是乱贴的,你有问题,我当然要帮你,尽管不正确,是吧
如何将listview中显示出来的记录拖到treeview中去 Option Explicit Private Sub Form_Load() TreeView1.Nodes.Add , , "aa", "aa" TreeView1.Nodes.Add , , "bb", "bb" ListView1.ListItems.Add , , "cc" ListView1.ListItems.Add , , "dd" ListView1.OLEDragMode = ccOLEDragAutomatic ListView1.LabelEdit = lvwManual End Sub Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = vbLeftButton Then ListView1.DragIcon = ListView1.SelectedItem.CreateDragImage ListView1.Drag vbBeginDrag End If End Sub Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single) If Not TreeView1.DropHighlight Is Nothing Then TreeView1.Nodes.Add TreeView1.DropHighlight.Key, tvwChild, GetNextKey() & ListView1.SelectedItem.Text, ListView1.SelectedItem.Text TreeView1.DropHighlight.Expanded = True End If End Sub Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer) Set TreeView1.DropHighlight = TreeView1.HitTest(x, y) End Sub Private Function GetNextKey() As String Dim sNewKey As String Dim iHold As Integer Dim i As Integer On Error GoTo myerr iHold = Val(TreeView1.Nodes(1).Key) For i = 1 To TreeView1.Nodes.Count If Val(TreeView1.Nodes(i).Key) > iHold Then iHold = Val(TreeView1.Nodes(i).Key) End If Next iHold = iHold + 1 sNewKey = CStr(iHold) & "_" GetNextKey = sNewKey Exit Function myerr: GetNextKey = "1_" End Function
那位高手有相關檢驗指點一下吧
謝謝,請給個例子給我學習
现在是想加多一点更方便的功能而已,就差不知道如何获得鼠标放下所在位置的绝对路径了,知道以后我就可以把选中的文件提取到鼠标放下的地方,或者桌面或者目录
我的api只停留在使用现成模块的水准,请问是否有这样的API函数,有的话如何用,贴个例子吧。
实在不行就只好放弃这个小功能了(下决心啃下api)
还有什么高见吗?一起研究一下吧
我的程序基本功能都已经完成,这个只是锦上添花的小功能而已
不过我觉得获取绝对路径还是很有用的,没办法,不熟悉API,没思路
再帮忙看看吧
'要确保指定文件在磁盘上存在,否则会提示文件找不到
'如果文件数据保存在数据库中,则先要取出保存在磁盘上
Data.Files.Add ListView1.SelectedItem.Text
End SubPrivate Sub ListView1_OLEStartDrag(Data As MSComctlLib.DataObject, AllowedEffects As Long)
AllowedEffects = vbDropEffectCopy
Data.Clear
Data.SetData , vbCFFiles
End Sub
先謝謝你的幫助.這種方法我想應該是可以的,但問題是:
所有文件都保存在sqlserver中,按上面的方法就要先提取出來,然後在寫到指定的地方去,最後刪除提取的臨時文件,這樣效率很低,如果是幾個2m左右的大文件就要先喝點咖啡等待鼠標由沙漏變回箭頭了
如果能夠直接得到鼠標up時的絕對路徑就會好很多了....
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long'剪贴版处理函数
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd _
As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat _
As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As LongPrivate Declare Function DragQueryFile Lib "shell32.dll" Alias _
"DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, _
ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal _
hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags _
As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As _
Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As _
Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As _
Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)上
If SetClipboardData(CF_HDROP, hGlobal) Then
clipCopyFiles = True
End If
End If
Call CloseClipboard
End If
'确定剪贴版的数据格式是文件,并打开剪贴版
If IsClipboardFormatAvailable(CF_HDROP) Then
If OpenClipboard(0&) Then
hDrop = GetClipboardData(CF_HDROP)
'获得文件数
nFiles = DragQueryFile(hDrop, -1&, "", 0)
ReDim Files(0 To nFiles - 1) As String
filename = Space(MAX_PATH)
'确定执行的操作类型为拷贝操作
tfStr.wFunc = FO_COPY
'目的路径设置为File1指定的路径
tfStr.pTo = Form1.File1.Path
For i = 0 To nFiles - 1
'根据获取的每一个文件执行文件拷贝操作
Call DragQueryFile(hDrop, i, filename, Len(filename))
Files(i) = TrimNull(filename)
tfStr.pFrom = Files(i)
SHFileOperation tfStr
Next i
Form1.File1.Refresh
Form1.Dir1.Refresh
Call CloseClipboard
End If
clipPasteFiles = nFiles
End If我是乱贴的,你有问题,我当然要帮你,尽管不正确,是吧
你老人家又年輕又漂亮又熱心又厲害,謝謝...不過沒用,問題還是沒解決.
把你的程序发给我老人家看看吧,OK?
但我是api菜鳥,不知如何實現,那位高人再指點?
婆婆我又帮你找了一个,供你参考啊,我老眼昏花,看不懂,一会我吃完饭回来发给你
Option Explicit
Private Sub Form_Load()
TreeView1.Nodes.Add , , "aa", "aa"
TreeView1.Nodes.Add , , "bb", "bb"
ListView1.ListItems.Add , , "cc"
ListView1.ListItems.Add , , "dd"
ListView1.OLEDragMode = ccOLEDragAutomatic
ListView1.LabelEdit = lvwManual
End Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
ListView1.DragIcon = ListView1.SelectedItem.CreateDragImage
ListView1.Drag vbBeginDrag
End If
End Sub
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
If Not TreeView1.DropHighlight Is Nothing Then
TreeView1.Nodes.Add TreeView1.DropHighlight.Key, tvwChild, GetNextKey() & ListView1.SelectedItem.Text, ListView1.SelectedItem.Text
TreeView1.DropHighlight.Expanded = True
End If
End Sub
Private Sub TreeView1_DragOver(Source As Control, x As Single, y As Single, State As Integer)
Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
End Sub
Private Function GetNextKey() As String
Dim sNewKey As String
Dim iHold As Integer
Dim i As Integer
On Error GoTo myerr
iHold = Val(TreeView1.Nodes(1).Key)
For i = 1 To TreeView1.Nodes.Count
If Val(TreeView1.Nodes(i).Key) > iHold Then
iHold = Val(TreeView1.Nodes(i).Key)
End If
Next
iHold = iHold + 1
sNewKey = CStr(iHold) & "_"
GetNextKey = sNewKey
Exit Function
myerr:
GetNextKey = "1_"
End Function