楼主
amulee |
Q：如何利用自定义的剪切和粘贴实现TreeView的节点移动？
A：由于在VBA中，Treeview没了Drag方法，连鼠标的MouseUp事件也有问题。因而拖曳的方**有些问题，但是可以采取剪切和粘贴的方法移动节点。效果如动画：
参考代码如下：
- Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nindex As Long) As Long
- Private BlnCut As Boolean
- Private Nodex As Node '源节点
- Private NodeD As Node '目标节点
- Private PixX2TwipX As Double '像素转换成缇
- Private PixX2TwipY As Double
- Private Const LOGPIXELSX = 88
- Private Const LOGPIXELSY = 90
- '按下鼠标时显示右键菜单
- Private Sub TreeView1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
- If Button = 2 Then
- '非剪切状态，设定源节点
- If Not BlnCut Then
- Set Nodex = TreeView1.HitTest(x * PixX2TwipX, y * PixX2TwipY)
- If Not Nodex Is Nothing Then
- Set TreeView1.DropHighlight = Nodex
- Application.CommandBars("右键菜单").Controls("粘贴").Enabled = False
- Application.CommandBars("右键菜单").ShowPopup '显示菜单
- End If
- Else
- '当前剪切状态，设定目标节点
- Set NodeD = TreeView1.HitTest(x * PixX2TwipX, y * PixX2TwipY)
- If Not NodeD Is Nothing Then
- Set TreeView1.DropHighlight = NodeD
- Application.CommandBars("右键菜单").Controls("粘贴").Enabled = True
- Application.CommandBars("右键菜单").ShowPopup '显示菜单
- End If
- End If
- End If
- End Sub
- ''初始化窗体
- Private Sub UserForm_Initialize()
- Dim Dep1 As Node
- Dim Dep2 As Node
- Dim MyBar As CommandBar
- Dim MyItem As CommandBarControl
- Dim i As Long
- Dim Arr
-
- '数据初始化
- On Error Resume Next
- Arr = Range("A2:C" & Range("A65536").End(xlUp).Row)
- With TreeView1
- For i = 1 To UBound(Arr)
- Set Dep1 = .Nodes(Arr(i, 2))
- If Err.Number <> 0 Then
- Err.Clear
- Set Dep1 = .Nodes.Add(Key:=Arr(i, 2), Text:=Arr(i, 2))
- End If
- Set Dep2 = .Nodes(Arr(i, 3))
- If Err.Number <> 0 Then
- Err.Clear
- Set Dep2 = .Nodes.Add(relative:=Dep1, relationship:=tvwChild, Key:=Arr(i, 3), Text:=Arr(i, 3))
- End If
- .Nodes.Add relative:=Dep2, relationship:=tvwChild, Key:=i & Arr(i, 1), Text:=Arr(i, 1)
- Next
- Set Dep1 = .Nodes("人事")
- End With
- On Error GoTo 0
- PixX2TwipX = Application.InchesToPoints(1) * 20 / GetDeviceCaps(GetDC(0), LOGPIXELSX)
- PixX2TwipY = Application.InchesToPoints(1) * 20 / GetDeviceCaps(GetDC(0), LOGPIXELSY)
-
- '右键菜单的创建
- '创建新的自定义快捷菜单，类型为临时
- Set MyBar = Application.CommandBars.Add(Name:="右键菜单", _
- Position:=msoBarPopup, Temporary:=True)
-
- '为自定义快捷菜单添加菜单项
- Set MyItem = MyBar.Controls.Add(Type:=msoControlButton)
- MyItem.Caption = "剪切"
- MyItem.OnAction = "NodeCut"
-
- Set MyItem = MyBar.Controls.Add(Type:=msoControlButton)
- MyItem.Caption = "粘贴"
- MyItem.OnAction = "NodePaste"
-
- Set MyItem = Nothing
- Set MyBar = Nothing
- End Sub
- '剪切
- Sub NodeCut()
- BlnCut = True
- Application.CommandBars("右键菜单").Controls("粘贴").Enabled = True
- End Sub
- '粘贴
- Sub NodePaste()
- BlnCut = False
- On Error Resume Next
- Set Nodex.Parent = NodeD
- End Sub
- Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
- Application.CommandBars("右键菜单").Delete
- End Sub
附件下载：
 Treeview移动.rar
|