设为首页收藏本站Access中国

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步,快速开始

12下一页
返回列表 发新帖
查看: 16747|回复: 36
打印 上一主题 下一主题

[ActiveX] 学习使用microsoft windows common controls 6.0 (sp6)中几个常用控件

[复制链接]
跳转到指定楼层
1#
发表于 2010-9-9 14:25:47 | 显示全部楼层 回帖奖励 |倒序浏览 |阅读模式
这几个控件是:Toolbar、Imagelist、Statusbar、Treeview、Listview

这只是本人的学习体会,水平有限,谬误之处一定不少,欢迎斧正。

为确定起见,模仿资源管理器做一个示例。

一、具体有下面一些功能:

1、窗体自带一个用Toolbar生成的菜单

2、左边是Treeview控件,用来显示文件夹,每个节点表示一个文件夹

3、右边是Listview控件,用来显示左边选中节点(文件夹)下一级的文件夹和文件,每个Item表示一个文件夹或者一个文件

4、下面是Strtusbar控件,显示一些系统状态信息,同时第六个窗格显示即时操作的动作

5、左边的Treeview可以进行的操作有
a、添加节点(同级或下级节点)
b、修改节点名称
c、删除节点
d、拖动一个节点使其成为另一个节点的子节点(在合法的条件下)
e、可以把外部的文件夹或者文件拖放到节点下,并保存到数据库

6、右边的Listview可以进行的操作有
a、修改Item的名称
b、删除Item
c、拖动一个Item使其成为另一个节点下的文件夹或者文件
d、可以将外部的文件夹或者文件拖放到Listview里,使其成为当前节点下的子文件夹或者文件
e、可以改变Listview的样式(这里只用了二种样式)
f、可以按第一、第二或第四列排序

先看一下示例的演示



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x

评分

参与人数 2经验 +20 收起 理由
roych + 10 (其它)优秀教程、原创内容、以资鼓励、其.
todaynew + 10 精品文章

查看全部评分

分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏3 分享分享 分享淘帖 订阅订阅
2#
 楼主| 发表于 2010-9-9 14:26:32 | 显示全部楼层
本帖最后由 sgrshh29 于 2011-8-29 09:31 编辑

二、本示例涉及内容有:
1、建表,字段,数据类型,表间关系
2、建窗体,窗体式样,在窗体添加控件
3、建模块,自定义函数,事件过程
4、自动化对象:adodb.connection、adodb.recordset、filesystemobject、dictionary
5、sql语句中的select语句,update语句,insert语句,delete语句
6、ado连接,ado记录集,ado读写大字段
7、使用记录集
8、变量、变量类型转换、数组
9、用递归遍历指定的文件夹中的所有文件夹和文件、用递归遍历Treeview控件指定节点下的所有节点
10、Access自带的一些功能
11、自定义快捷菜单
12、imagelist,treeview,listwiew,toolbar,progressbar,statusbar等控件的初始化、加载、卸载等。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
3#
 楼主| 发表于 2010-9-9 14:29:13 | 显示全部楼层
本帖最后由 sgrshh29 于 2010-9-9 15:15 编辑

回复 sgrshh29 的帖子

三、下面来一步步编写这个示例

1、先新建一个mdb,然后新建一个窗体命名为frmMain,对窗体的式样进行一些设置后保存

2、然后在vba窗体里,引用microsoft windows common controls 6.0 (sp6)

3、按照从简至繁的原则,从Toolbar开始,看名称知道是一个工具栏控件

a、在窗体添加一个Toolbar控件
在窗体的设计视图中,打开工具箱,找到Microsoft Toolbar Control 6.0,将其添加到窗体页眉,适当调整一下大小。
命名为Toolbar0


b、在窗体添加一个Imagelist控件
Toolbar中的Botton是可以带图标的。为此,在窗体上添加一个Imagelist做为图标来源。
在窗体设计视图,从工具箱中找到Microsoft Imagelist Control 6.0 (sp6),将其添加到窗体
命名为Imagelist3,选择属性对话框,为它添加图标


c、设置Toolbar,有二种方法,一种是在Toolbar的属性对话框中直接设置。另一种是用代码设置

这里采用第一种方法设置属性


用第二种方法添加Button和ButtonMenu

添加Button
语法是:Toolbar.Buttons.Add Index, Key, Text, Type, Face

如果这个Button是下拉式的,还可以添加第二层ButtonMenu
语法是:Toolbar.Buttons(Index).ButtonMenus.Add Index, Key, Text


d、因为用的是access,理所当然用数据表来保存Toolbar的各项参数,创建二个表

一个命名为tblTbrBtn,保存Button参数


另一个命名为tblTbrBtnMenu,保存ButtonMenu参数


二个表之间用ID和PID组成一对多关系,并钩选实施参照完整性、级联更新和级联删除


e、在表中输入数据


f、在窗体加载事件中输入代码,加载Toolbar

Private Sub Form_Load()
    加载Toolbar Me.Toolbar0
End Sub

g、下面是加载Toolbar过程,新建一个模块,命名为modToolbar,将下面的过程复制到模块

Sub 加载Toolbar(ByVal objTbr As Object, ByVal objImglist As Object)
Dim Rs As Object
With objTbr
    .Top = 0
    .Left = 0
    .Width = Forms("frmMain").InsideWidth
    Set Rs = CurrentDb.OpenRecordset("select * from tblTbrBtn order by id")
    Do Until Rs.EOF
        .Buttons.Add CInt(Rs(0)), CStr(Rs(1)), CStr(Rs(2)), CStr(Rs(3)), CInt(Rs(4))
        Rs.movenext
    Loop
    Set Rs = Nothing
    Set Rs = CurrentDb.OpenRecordset("select * from tblTbrBtnMenu order by pid, id")
    Do Until Rs.EOF
        .Buttons(CInt(Rs(1))).ButtonMenus.Add CInt(Rs(0)), CStr(Rs(2)), CStr(Rs(3))
        Rs.movenext
    Loop
    Set Rs = Nothing
End With
End Sub

h、加载完成后的窗体,图13



i、为所有的Button和ButtonMenu的单击事件指定过程

Private Sub Toolbar0_ButtonClick(ByVal Button As Object)
    If Button.Key = "Exit" Then
        DoCmd.Close acForm, Me.Name
    Else
        TbrClick Button.Key
    End If
End Sub

Private Sub Toolbar0_ButtonMenuClick(ByVal ButtonMenu As Object)
    TbrClick ButtonMenu.Key
End Sub

j、下面的按钮过程放在模块modToolbar中
Sub TbrClick(ByVal strAction As String)
    MsgBox "当前调用的过程:" & strAction
End Sub

k、点击后的效果。至于调用的过程,也放在同一个模块中,如何写代码等具体使用时继续。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
4#
 楼主| 发表于 2010-9-9 14:31:05 | 显示全部楼层
本帖最后由 sgrshh29 于 2010-9-9 15:13 编辑

回复 sgrshh29 的帖子
4、Statusbar控件,看名称就知道是状态栏控件。接下来操作与Toolbar类似
a、在窗体页脚添加一个Statusbar控件,命名为Statusbar0,适当调整一下大小

b、创建一个数据表用来保存控件的参数,命名为tblStatusbar,并输入数据

c、添加Panel
语法:Statusbar.Panels.Add index, key, text, Style
其中style有几个特定的值是用来显示电脑硬件信息的,这时候的text是默认的
d、添加Panel以后,对每一个Panel的属性进行设置
e、在窗体的加载事件中添加一句,成为:
Private Sub Form_Load()
    加载Toolbar Me.Toolbar0
    加载StatusBar Me.StatusBar0, Me.ImageList3.Object
End Sub
f、下面是加载过程。新建一个模块,命名modStatusbar,把下面的代码复制进去
Sub 加载StatusBar(ByVal objStatusBar As Object, ByVal objImagelist As Object)
Dim Rs As Object
With objStatusBar
    .Top = 0
    .Left = 0
    .Width = Forms("frmMain").InsideWidth
    Set Rs = CurrentDb.OpenRecordset("select * from tblStatusbar order by id")
    Do Until Rs.EOF
        If IsNull(Rs(2)) Then
            .Panels.Add CInt(Rs(0)), Rs(1), , CInt(Rs(3))
        ElseIf Rs("strtext") = "currentuser" Then
            .Panels.Add CInt(Rs(0)), Rs(1), CurrentUser(), CInt(Rs(3))
        Else
            .Panels.Add CInt(Rs(0)), Rs(1), Rs(2), CInt(Rs(3))
        End If
        With .Panels(Int(Rs(0)))
            If CInt(Rs(4)) <> 0 Then
                .Picture = objImagelist.ListImages(CInt(Rs(4))).Picture
            End If
            .Alignment = Rs(5)
            .AutoSize = Rs(6)
            .Bevel = Rs(7)
            .Width = Rs(8)
            .ToolTipText = Rs(9)
        End With
        Rs.movenext
    Loop
    Set Rs = Nothing
End With
End Sub
g、其中第六个Panel是用来显示用户的操作信息的,当用户进行不同的操作时,提示简短的文字
过程如下,可以在需要的地方调用
Sub pnlEditText(ByVal strPnltext As String)
    Forms("frmMain").Controls("StatusBar2").Panels(6).Text = strPnltext
End Sub
h、然后把原来在modToolbar中的那个点击事件过程中msgbox显示的信息,改到用Ststusbar来显示。
Msgbox "当前调用的过程:" & strAction
改为
pnlEditText "当前调用的过程:" & strAction
i、加载Toolbar和Statusbar以后的窗体,图18



三个比较简单的控件已经ok了。重点是如何设计出合适的数据表并且添加合适的数据,然后创建合适的记录集来对控件进行加载。
接下去是二个相对要复杂一些的控件Treeview和Listview,暂时先到这里。

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
5#
 楼主| 发表于 2010-9-9 15:11:18 | 显示全部楼层
前面漏传了几个图片,正在编辑中。另外,到最后会有一个完整的示例附件上传的。
6#
 楼主| 发表于 2010-9-9 16:41:41 | 显示全部楼层
本帖最后由 sgrshh29 于 2010-9-9 16:44 编辑

回复 sgrshh29 的帖子

5、Treeview,从名称可以知道是一个树控件
a、在窗体主体添加一个Treeview控件,适当调整一下大小,命名为Treeview0。图19
b、添加一个Imagelist作为Treeview的图标来源,命名为Imagelist1。为其添加适当的图标,图20
c、在Treeview0的属性对话框中设置属性,图21
d、创建一个数据表作为加载Treeview1的数据源,这个表要比前面的表难一些。
在这个实例中Treeview是用来显示文件夹之间的关系,每一个节点表示一个文件夹
Treeview中的节点分为二种情况,一种是顶层节点,这种节点只可能有若干个子节点而没有父节点。
另一种节点一定有一个也只能有一个父节点同时可能有若干个子节点。
因而数据表的设计要体现这种关系,它是一个无限(借用这个词)层次的,各条记录之间具有上下级或者平级关系的表。
e、设计表

f、输入一些临时数据

g、加载Treeview0
添加节点的语法:
顶层节点:Treeview..Nodes.Add , , Key, Text, Icon, SmallIcon
其它节点:Treeview.Nodes.Add ParentKey, tvwChild, Key, Text, Icon, SmallIcon
在窗体加载事件中添加一句:
加载Treeview Me.TreeView0
成为:
Private Sub Form_Load()
    加载Toolbar Me.Toolbar0
    加载StatusBar Me.StatusBar0, Me.ImageList3.Object
    加载Treeview Me.TreeView0
End Sub
下面是加载Treeview0模块,命名为modTreeview,将下面的代码复制进去
加载过程,其中用到了ado的二个对象
Sub 加载Treeview(ByVal objTree As Object)
    objTree.Nodes.Clear
    CreateADOCnnRs
    objRs.Open "select * from tblTreeview order by gid,id;", objCnn
    递归函数 objTree
    objRs.Close
    RemoveADOCnnRs
End Sub
递归函数,其中用到的数组
Sub 递归函数(ByVal objTree As Object, Optional ByVal lngfilter As String = 0)
    Dim lngIndex As Long
    Dim lngFilters() As String
    objRs.Filter = "gid=" & lngfilter
    Do Until objRs.EOF
        lngIndex = lngIndex + 1
        ReDim Preserve lngFilters(1 To lngIndex)
        lngFilters(lngIndex) = objRs("id")
        加载节点 objTree, objRs("id"), objRs("gid"), objRs("pname")
        objRs.movenext
    Loop
    For lngIndex = 1 To lngIndex
        递归函数 objTree, lngFilters(lngIndex)
    Next lngIndex
End Sub
添加节点过程
Sub 加载节点(ByVal objTree As Object, ByVal lngKey As Long, ByVal lngParentKey As Long, ByVal strName As String)
    If lngParentKey = 0 Then
        objTree.Nodes.Add , , "T" & lngKey, strName, 1, 2
    Else
        objTree.Nodes.Add "T" & lngParentKey, tvwChild, "T" & lngKey, strName, 1, 2
    End If
End Sub

h、上面的代码用到了adodb.connection和adodb.recordset这二个自动化对象,新增一个模块来定义它们,命名为modAdo,代码如下
Public objCnn As Object                    '定义adoConnection对象
Public objRs As Object                      '定义adorecordset对象
注:因为这二个对象在以后还要用到,所以定义为全局对象变量
创建ado对象过程
Public Sub CreateADO()
    Set objCnn = CreateObject("adodb.connection")
    Set objRs = CreateObject("adodb.recordset")
    Set objCnn = CurrentProject.Connection
End Sub
销毁ado对象过程
Public Sub RemoveADO()
    Set objRs = Nothing
    Set objCnn = Nothing
End Sub

i、下面是加载Treeview后的窗体


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
7#
 楼主| 发表于 2010-9-9 16:49:26 | 显示全部楼层
回复 sgrshh29 的帖子

四、Treeview的操作
1、内容有:添加同级节点、添加子节点、删除节点(包含它的子节点)、编辑节点名称、拖动节点成为顶层节点或成为其它节点的子节点。
注意到Treeview是用数据表来保存信息的,所以进行上面的操作时,同时要对数据表进行相应的操作,即添加记录、删除记录、更新记录。

2、添加同级节点过程
Sub mAddNode()
    Dim strKey As String
    Dim objTree As Object
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    strKey = objTree.SelectedItem.Key
    pnlEditText "当前操作:添加" & objTree.SelectedItem & "同级节点"
    AddNewNode strKey, True
    Set objTree = Nothing
End Sub
3、添加子节点过程
Sub mAddSubNode()
    Dim strKey As String
    Dim objTree As Object
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    strKey = objTree.SelectedItem.Key
    pnlEditText "当前操作:添加" & objTree.SelectedItem & "子节点"
    AddNewNode strKey
    Set objTree = Nothing
End Sub
4、添加节点,这里用到了sql语句中的insert语句
Sub AddNewNode(ByVal strKey As String, Optional ByVal isSame As Boolean = False)
    Dim lngParent As String
    Dim objTree As Object
    Set objTree = Forms("frmMain").Controls("treeview0")
    lngParent = Mid(strKey, 2)
    If isSame Then lngParent = DLookup("gid", "tblTreeview", "id=" & Mid(strKey, 2))
    strKey = "T" & DMax("id", "tblTreeview") + 1
    CurrentDb.Execute ("insert into tblTreeview ( id, gid, pname, pdate ) " _
                              & "select dmax('id','tblTreeview')+1, '" & lngParent & "', 'New Item', '" & Now() & "'")
    If lngParent = 0 Then
        objTree.Nodes.Add , , strKey, "New Item", 1, 2
    Else
        objTree.Nodes.Add "T" & lngParent, tvwChild, strKey, "New Item", 1, 2
    End If
    Set objTree = Nothing
End Sub

5、删除节点过程
Sub mDeleteNode()
    Dim objNode As Object
    Dim objTree As Object
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    pnlEditText "当前操作:删除" & objTree.SelectedItem & "及其中的..."
    Set objNode = objTree.SelectedItem
    RemoveNode objNode
    Set objNode = Nothing
    Set objTree = Nothing
End Sub
6、删除节点并删除相应记录,当有子节点时确认同时删除子节点
Sub RemoveNode(ByVal objNode As Node)
    If objNode.Children > 0 Then
        If MsgBox("所选项目含有子项目,是否连子项目一起删除?", vbYesNo, "Infomation") = vbNo Then
            MsgBox "请先清除或移动所选项目的子项目再行删除!", vbOKOnly, "Infomation"
            pnlEditText "当前操作:取消删除" & objNode
            Exit Sub
        End If
    End If
    dirNode objNode
    Forms("frmMain").Controls("treeview0").Nodes.Remove objNode.Key
    pnlEditText "当前操作:删除" & objNode & "及其中...完成"
End Sub
7、删除数据表中相应记录过程,这里用到了sql语句的delete语句
Sub dirNode(nodeX As Node) '递归
    Dim IntNodes As Integer
    Dim CldNode As Node
    Dim i As Integer
    IntNodes = nodeX.Children
    CurrentDb.Execute ("delete * from tblTreeview where id=" & Mid(nodeX.Key, 2))
    If IntNodes > 0 Then
        Set CldNode = nodeX.Child
        For i = 1 To IntNodes
            dirNode CldNode
            Set CldNode = CldNode.Next
        Next
    End If
End Sub

8、编辑节点文本过程,这里用到了sql语句的update语句
Sub mEditNode()
    Dim objTree As Object
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    Dim strNew As String
    strNew = InputBox("请输入新的节点名称")
    If strNew = "" Or IsNull(strNew) Then Exit Sub
    pnlEditText "当前操作:编辑" & objTree.SelectedItem
    CurrentDb.Execute ("update tblTreeview set pname='" & strNew & "' where id=" & Mid(objTree.SelectedItem.Key, 2))
    objTree.SelectedItem.Text = strNew
End Sub

9、展开当前节点及其子节点过程
Sub mExpandNode()
    Dim i As Integer
    Dim objTree As Object
    Dim objNode As Node
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    Dim lngIndex As Integer
    Set objNode = objTree.SelectedItem
    pnlEditText "当前操作:展开" & objTree.SelectedItem
    objTree.Nodes(objNode.Index).Expanded = True
    lngIndex = objNode.Child.Index
    For i = 0 To objNode.Children - 1
        objTree.Nodes(lngIndex + i).Expanded = True
    Next i
End Sub

10、拖曳节点
先在窗体中添加事件
Private Sub Treeview0_OLEStartDrag(Data As Object, AllowedEffects As Long)
    pnlEditText "当前操作:拖曳" & Me.TreeView0.SelectedItem
End Sub
Private Sub Treeview0_OLEDragOver(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
    If Me.TreeView0.SelectedItem Is Nothing Then
        Set Me.TreeView0.SelectedItem = Me.TreeView0.HitTest(x, y)      ' 如无节点被选中,则选择你曾经拖过的一个.
    Else
        Set Me.TreeView0.DropHighlight = Me.TreeView0.HitTest(x, y)      ' 如有节点被选中,则选择高亮显示的一个.
    End If
End Sub
然后在模块中添加过程,这里用到了sql语句的update语句
Public Sub 拖曳节点()
    On Error GoTo Err_TreeDragDrop
    Dim strKey As String
    Dim objTree As Object
    Dim nodDragged As Node
    Set objTree = Forms("frmMain").Controls("treeview0").Object
    If objTree.SelectedItem Is Nothing = False Then
        Set nodDragged = objTree.SelectedItem
        strKey = nodDragged.Key
        If objTree.DropHighlight Is Nothing Then        ' 节点被拖放到空白区,则将其设为根节点
            CurrentDb.Execute ("update tblTreeview set gid=0 where id=" & Mid(nodDragged.Key, 2))
            加载Treeview Forms("frmMain").treeview0
            objTree.Nodes(strKey).Selected = True
            objTree.Nodes(strKey).Expanded = True
        ElseIf nodDragged.Index <> objTree.DropHighlight.Index Then     '节点被拖到选定节点
            Set nodDragged.Parent = objTree.DropHighlight
            CurrentDb.Execute ("update tblTreeview set gid=" & Mid(nodDragged.Parent.Key, 2) _
                                      & " where id=" & Mid(nodDragged.Key, 2))
        End If
    End If
Exit_TreeDragDrop:
    Set objTree.DropHighlight = Nothing
    Set nodDragged = Nothing
    Set objTree = Nothing
    Exit Sub
Err_TreeDragDrop:
     MsgBox "节点拖曳错误" & vbCrLf & Error.Description, vbCritical, "Information"
     Resume Exit_TreeDragDrop
End Sub

五、为“Tree视图”菜单按钮“ 及下级菜单的单击事件添加调用的过程
1、在窗体的botton和bottonmenu的单击事件中,分别将
TbrClick Button.Key
改为
TbrClick "m" & Button.Key
TbrClick ButtonMenu.Key
改为
TbrClick "m" & ButtonMenu.Key
2、在模块中添加一个Button单击事件的过程
Sub mTreeview()
    pnlEditText "添加删除节点(子节点)、编辑节点、展开节点。"
End Sub
3、在下面过程中添加一句执行代码

Sub TbrClick(ByVal strAction As String)
    pnlEditText "当前调用的过程:" & strAction
End Sub
改为
Sub TbrClick(ByVal strAction As String)
    pnlEditText "当前调用的过程:" & strAction
    Application.Run strAction
End Sub
4、上面几节完成以后的演示


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
8#
 楼主| 发表于 2010-9-11 15:44:25 | 显示全部楼层
回复 sgrshh29 的帖子

这一节是文件夹导入导出

六、导入导出文件夹
这是难度比较大的一节内容。
操作过程是:
选择一个节点,点击菜单按钮“导入文件夹”,在选择文件夹对话框中把选中的文件夹连同它下面的所有文件夹添加到节点下,顺序、,名称不变
如果没有选择节点,则把这个文件夹作为一个新的根节点导入,它下面的文件夹顺序不变、不变。
1、选择文件夹对话框代码
Function getFolderName() As String
    Dim dlgFolder As Variant
    Set dlgFolder = Application.FileDialog(4)
    With dlgFolder
        .title = "请选择文件夹"
        .AllowMultiSelect = False
        .Filters.Clear
        .Show
    End With
    If dlgFolder.SelectedItems.count > 0 Then
        getFolderName = dlgFolder.SelectedItems(1)
    Else
        getFolderName = ""
    End If
    Set dlgFolder = Nothing
    DoEvents
End Function
2、创建对filesystemobject和dictionary二个对象的引用
Public objFso As Object
Public objDic As Object
Sub CreateFsoDic()
    Set objDic = CreateObject("scripting.dictionary")
    Set objFso = CreateObject("scripting.filesystemobject")
End Sub
Sub RemoveFsoDic()
    objDic.RemoveAll
    Set objDic = Nothing
    Set objFso = Nothing
End Sub
3、添加一个全局变量
Public lngGid AS Long

4、为"导入文件夹"菜单按钮添加事件过程
Sub mImportFolder()
    Dim strGetFolderPath As String
    strGetFolderPath = getFolderName
    If strGetFolderPath = "" Then Exit Sub
    Set objTree = Forms("frmMain").Controls("treeview0")
    pnlEditText "当前操作:正在保存文件夹..."
    CreateADOCnnRs
    CreateFsoDic
    If objTree.SelectedItem Is Nothing Then
        strKey = "T" & Nz(DMax("id", "tblTreeview")) + 1
        SaveFolderFile strGetFolderPath
    Else
        strKey = objTree.SelectedItem.Key
        lngGid = Mid(objTree.SelectedItem.Key, 2)
        SaveFolderFile strGetFolderPath
    End If
    RemoveADOCnnRs
    RemoveFsoDic
    pnlEditText "当前操作:保存文件夹完成"
    加载Treeview Forms("frmMain").Controls("Treeview0")
    objTree.Nodes(strKey).Selected = True
    objTree.Nodes(strKey).Expanded = True
End Sub

5、导入文件夹模块,这是一个递归函数
Dim lngIDp As Long
Function SaveFolderFile(ByVal strPath As String)
On Error Resume Next
    Dim lngSubP As Long
    Dim strSubP() As String
    Dim strParent As String
    Dim objFolder As Object
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    If Len(strPath) - Len(Replace(strPath, "\", "")) = 1 Then
        strParent = objFso.GetFolder(strPath)
    Else
        strParent = objFso.GetFolder(strPath).ParentFolder
    End If
    If Right(strParent, 1) <> "\" Then strParent = strParent & "\"
    If objDic.Exists(strParent) Then
        lngGid = objDic(strParent)
    End If
    If DCount("id", "tblTreeview") > 0 Then
        lngIDp = DMax("id", "tblTreeview") + 1
    Else
        lngIDp = lngIDp + 1
    End If
    objDic.Add strPath, lngIDp
    If Len(strPath) - Len(Replace(strPath, "\", "")) = 1 Then
        AddFolder lngIDp, lngGid, objFso.getdriveName(objFso.getdrive(strPath)), _
                        objFso.getdrive(strPath).totalsize
    Else
        AddFolder lngIDp, lngGid, objFso.GetFolder(strPath).Name, _
                        objFso.GetFolder(strPath).Size, objFso.GetFolder(strPath).DateLastModified
    End If
    For Each objFolder In objFso.GetFolder(strPath).SubFolders
        Select Case objFolder.Attributes
            Case 16, 17, 48
            lngSubP = lngSubP + 1
            ReDim Preserve strSubP(1 To lngSubP)
            strSubP(lngSubP) = objFolder.Path
        End Select
    Next
    For lngSubP = 1 To lngSubP
        SaveFolderFile strSubP(lngSubP)
    Next lngSubP
End Function
6、将记录追加到数据表的过程,这里用到了sql语句的insert语句
Sub AddFolder(ByVal lngIDp As Long, ByVal lngGid As Long, ByVal strPName As String, _
                       ByVal lngPsize As Double, Optional ByVal datPDLModi As Date)
    Dim strSql As String
    strSql = "insert into tblTreeview (id, gid, pname, psize, pdate) select " & """" & lngIDp & """" & "," & """" & lngGid _
              & """" & "," & """" & strPName & """" & "," & """" & lngPsize & """" & "," & """" & datPDLModi & """"
    CurrentDb.Execute (strSql)
End Sub



七、在硬盘指定的位置将节点按原样导出为文件夹,实际就是上一节的反向操作
1、为"导出文件夹"菜单按钮添加事件过程
Sub mExportFolder()
    Set objTree = Forms("frmMain").Controls("treeview0")
    If objTree.SelectedItem Is Nothing Then Exit Sub
    pnlEditText "当前操作:正在将文件夹保存到硬盘..."
    ExportNode objTree.SelectedItem, objTree.SelectedItem.Text
    pnlEditText "当前操作:文件夹保存到硬盘完成"
End Sub
2、导出过程
Sub ExportNode(ByVal objNode As Node, ByVal strNodText As String)
On Error Resume Next
    Dim strPath As String
    strPath = getFolderName
    If strPath <> "" Then
        CreateADOCnnRs
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        ExportSubNode objNode, strPath, strNodText
        RemoveADOCnnRs
    Else
        MsgBox "没有选择保存位置。", vbInformation, "Information"
        Exit Sub
    End If
End Sub
3、递归过程
Sub ExportSubNode(ByVal objNode As Node, ByVal strPath As String, ByVal strNodText As String) '节点递归
    Dim i As Integer
    Dim strFolder As String
    Dim strSubFld As String
    Dim intNodChildren As Integer
    Dim nodChild As Node
    intNodChildren = objNode.Children
    strSubFld = Mid(objNode.FullPath, InStr(objNode.FullPath, strNodText))
    strFolder = strPath & strSubFld & "\"
    If Dir(strFolder, vbDirectory) = "" Then
        MkDir strFolder
    Else
        If MsgBox("文件夹: " & strFolder & Chr(10) & Chr(13) & " 已经存在,是否继续?", _
                        vbInformation + vbYesNo, "Information") = vbNo Then End
    End If
    If intNodChildren > 0 Then
        Set nodChild = objNode.Child
        For i = 1 To intNodChildren
            ExportSubNode nodChild, strPath, strNodText
            Set nodChild = nodChild.Next
        Next i
    End If
End Sub


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
9#
 楼主| 发表于 2010-9-11 15:47:58 | 显示全部楼层
回复 sgrshh29 的帖子

八、将外部文件夹拖曳到Treeview里
上一节是用菜单来导入文件夹及它的子文件夹,这一节是不用菜单,而是直接将外部文件夹拖曳到Treeview来进行导入文件夹和它的子文件夹
1、在窗体的Treeview0的拖放事件中添加代码来判断拖曳状态,有四种情况:
a、拖动Treeview的Node(在前面已经讲过了,这里就是添加判断)
b、拖动Listview的Item(以后要讲到)
c、拖动外部文件(以后要讲到)
d、拖动外部文件夹

2、拖曳外部文件夹到treeview的代码
先定义一个拖曳类型的全局变量
Public strDragType as String
然后在Treeview0_OLEStartDrag事件中对这个变量赋值
Private Sub Treeview0_OLEStartDrag(Data As Object, AllowedEffects As Long)
    strDragType = "TreeView"
End Sub
在拖曳结束时将这个变量置空
Private Sub TreeView0_OLECompleteDrag(Effect As Long)
    strDragType = ""
End Sub
在窗体的TreeView0_OLEDragDrop事件改写代码
Private Sub TreeView0_OLEDragDrop(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo Err_TreeX_OLEDragDrop
    Dim i As Integer
    If strDragType = "TreeView" Then        '拖曳的是treeview的node
        pnlEditText "当前操作:拖曳" & Me.TreeView0.SelectedItem
        拖曳节点
    ElseIf strDragType = "ListView" Then   '拖曳的是listrview的item
    ElseIf Effect = 7 Then
        For i = 1 To Data.Files.count
            CreateFsoDic
            If objFso.FileExists(Data.Files(i)) Then  '拖曳的是外部文件
            ElseIf objFso.folderexists(Data.Files(i)) Then  '拖曳的是外部文件夹
            pnlEditText "当前操作:拖曳外部文件夹到Treeview"
            If Me.TreeView0.DropHighlight Is Nothing Then
                    lngGid = 0
                    strKey = "T" & DMax("id", "tblTreeview") + 1
                    SaveFolderFile Data.Files(i)
                Else                                                     
                    strKey = Me.TreeView0.DropHighlight.Key
                    lngGid = Mid(strKey, 2)
                    SaveFolderFile Data.Files(i)
                End If
            End If
        Next i
        RemoveFsoDic
        加载Treeview Me.TreeView0
        Me.TreeView0.Nodes(strKey).Selected = True
        Me.TreeView0.Nodes(strKey).Expanded = True
    End If
    Set TreeView0.DropHighlight = Nothing
Exit_TreeX_OLEDragDrop:
    Exit Sub
Err_TreeX_OLEDragDrop:
    MsgBox Err.Number & Err.Description
    Resume Exit_TreeX_OLEDragDrop
End Sub


本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
10#
 楼主| 发表于 2010-9-11 15:53:50 | 显示全部楼层
回复 sgrshh29 的帖子

九、接下来是Listview控件,从名称可以知道是一个列表控件。
在示例中控件是用来显示树节点(文件夹)下的内容(子文件夹和文件)
1、在窗体添加一个Listview控件,命名为Listview0,适当调整大小
2、添加一个Imagelist控件,命名为Imagelist2,在其属性对话框中添加图标,作为Listview0的大图标的来源
3、在属性中设置属性



4、创建一个数据表来保存Listview0项目数据,命名为tblListview
5、设计表



6、将这个表与tblTreeview建立关系,并且钩选实施参照完整性、级联更新、级联删除



7、输入一些临时数据

8、加载Listview0,在窗体加载中添加二句
初始化Listview Me.ListView0
加载ListItem
这二句的过程分别是
9、初始化
Sub 初始化Listview(ByVal objListview As Object)
    With objListview
        .ListItems.Clear
        .ColumnHeaders.Clear
        .LabelEdit = lvwManual
        .ColumnHeaders.Add , , "文件名", .Width * 3.1 / 5, lvwColumnLeft, 3
        .ColumnHeaders.Add , , "文件类型", .Width * 0.55 / 5, lvwColumnCenter
        .ColumnHeaders.Add , , "文件大小K   ", .Width * 0.67 / 5, lvwColumnRight
        .ColumnHeaders.Add , , "修改日期     ", .Width * 0.67 / 5, lvwColumnRight
    End With
End Sub
10、加载
Public Sub 加载ListItem(Optional strKey As String = "T1")
    Dim ItemX As ListItem
    Forms("frmMain").Controls("listview0").ListItems.Clear
    Set objRs = CurrentDb.OpenRecordset("select * from tblTreeview where gid=" & Mid(strKey, 2) & " order by id;")
    Do Until objRs.EOF
        Set ItemX = Forms("frmMain").Controls("listview0").ListItems.Add(, "P" & objRs("id"), objRs("pname"), 2, 1)
        ItemX.SubItems(1) = ""
        ItemX.SubItems(2) = Format(IIf(Not IsNull(objRs("psize")), objRs("psize"), "") / 1024, "#,##0.000")
        ItemX.SubItems(3) = IIf(Not IsNull(objRs("pdate")), Format(objRs("pdate"), "yyyy-mm-dd"), "")
        objRs.movenext
    Loop
    objRs.Close
    Set objRs = CurrentDb.OpenRecordset("select id, fname, ftype, fsize, fdate from tblListview where gid=" & Mid(strKey, 2) & " order by id;")
    Do Until objRs.EOF
        If blnSingle Then objRs.movelast
        Set ItemX = Forms("frmMain").Controls("listview0").ListItems.Add(, "L" & objRs("id"), objRs("fname"), 1, 4)
        ItemX.SubItems(1) = IIf(Not IsNull(objRs("ftype")), objRs("ftype"), "")
        ItemX.SubItems(2) = Format(IIf(Not IsNull(objRs("fsize")), objRs("fsize"), "") / 1024, "#,##0.000")
        ItemX.SubItems(3) = IIf(Not IsNull(objRs("fdate")), Format(objRs("fdate"), "yyyy-mm-dd"), "")
        objRs.movenext
    Loop
    objRs.Close
    Set objRs = Nothing
    Set ItemX = Nothing
    Exit Sub
End Sub

11、为不同的文件类型指定图标

12、然后在窗体的Treeview0的节点点击事件中,重新加载Listview0
Private Sub TreeView0_NodeClick(ByVal Node As Object)
    加载ListItem Node.Key
End Sub

13、完成以上步骤后的窗体演示





本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?注册

x
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-5-14 12:02 , Processed in 0.110341 second(s), 35 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表