关于字典的用法

dogingate

字典怎么用呢，我罗列下
首先创建一个字典对象
Set zd = CreateObject("scripting.dictionary")

然后往字典里增加key和对应的item
zd.Add 1, "a"'这里key=1,item为"a"字符串
zd.Add 2, "b"

获得所有的keys，是一个下标从0开始的一维数组
zdkeys = zd.keys
获得所有的items，也是一个小标从0开始的一维数组
zditems = zd.items
获得字典中keys或者items的总数
zdcount = zd.Count

接下来是怎么获取key对应的item，首先要获得key值，可以指定key值，比如字典中有的2
zdkey=2
或者指定在keys中的编号来获得key值
keyindex =1
zdkey = zdkeys(keyindex)
这时zdkey值就是2

接下来是怎么获得key对应的item，有两种方法，一是
zditem1 = zd(zdkey)
二是
zditem3 = zd.Item(zdkey)

你可以发现二中方法获得item值是一样的，不过第一种比较常用

书上说zd.key(keynum)或zd.key(keyname)可以获得key值，是错误的
只能设置key值，完整写法应该是zd.key(keynum)=newkey

比如刚才的zdkey为2，修改为3
zd.Key(zdkey) = 3
然后获得的item和原来是2的时候是一样的
zditem0 = zd(3)

dogingate

Sub 字典用法()
Set zd = CreateObject("scripting.dictionary")

zd.Add 1, "a"
zd.Add 2, "b"

zdkeys = zd.keys
zditems = zd.items
zdcount = zd.Count

'keyindex = 0
'zdkey = zdkeys(keyindex)
'

zdkey = zdkeys(1)

zditem1 = zd(zdkey)
zditem3 = zd.Item(zdkey)

zd.Key(zdkey) = 3
zditem0 = zd(3)

End Sub

jiangxiaoyun

zd.Item(zdkey)  里   .item省略了，就变成 zd(zdkey)，是同一种用法。我是这么理解。key属性，可写不可读。就是能修改，不能读取，实际比较少用。

dogingate

是的key属性可写不可读，所以只能生成keys数组，然后从数组里面读取

dogingate

以下代码就是通过打开对话框来选择图片，并将图片路径和图片编号写入字典中，方便后期读取

Sub Main()

    'Declare a variable as a FileDialog object.
    Dim fd As FileDialog
    Dim zd


    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    Set zd = CreateObject("scripting.dictionary")

    'Declare a variable to contain the path
    'of each selected item. Even though the path is aString,
    'the variable must be a Variant because For Each...Next
    'routines only work with Variants and Objects.
    Dim vrtSelectedItem As Variant

    'Use a With...End With block to reference the FileDialog object.
    With fd

        'Set the initial view to the details view.
        .InitialView = msoFileDialogViewThumbnail

'Add a filter that includes GIF and JPEG images and make it the second item in the list.        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 2        'Sets the initial file filter to number 2.        .FilterIndex = 2
        'Use the Show method to display the File Picker dialog box and return the user's action.
        'If the user presses the button...
        If .Show = -1 Then

fnum = 1
            'Step through each string in the FileDialogSelectedItems collection.
            For Each fpath In .SelectedItems

                'vrtSelectedItem is aString that contains the path of each selected item.
                'You can use any file I/O functions that you want to work with this path.
                'This example displays the path in a message box.
zd.Add fpath, fnum
fnum = fnum + 1


            Next fpath




        'If the user presses Cancel...
        Else
        End If
    End With

    'Set the object variable to Nothing.
    Set fd = Nothing

End Sub

dogingate

以下代码是用字典实现了统计不同人的参加次数及考试通过次数

dogingate

这是三级嵌套字典的应用案例

在编代码的日子中，又发现，原来可以不使用zd.add 这个方法，直接赋值的
比如之前，使用zd.add key,item
现在直接写为zd(key)=item即可
如果是嵌套字典的话，需要加set,比如set zd(key)=new dictionary即可

多级嵌套字典的话，可以用
zd(key1)(key2)(key3)...来表示

dogingate

这是另外一个例子，用字典生成三级菜单，是在别人的基础上改的代码，改了一天，效率似乎提高不少

原贴在此http://club.excelhome.net/thread-1148468-1-1.html

dogingate

这是用来将vbe中的所有模块自动导出

因为不习惯用goto，所以就用字典来解决了，字典真的很强大啊，看你怎么使用了，哈哈

这里面有一个关键问题，就是vbcomp.name对于worksheet来说，保存的是它的codename，而不是name

也就是说如果一个worksheet的原来名是sheet3，你修改为“汇总表”，那么这个表的coename还是sheet3,不变，但是name变成了"汇总表"

而模块的name和worksheet的codename是一致的，这一点要注意
Attribute VB_Name = "模块导出"
'''1、引用Microsoft Visual Basic for Application Extensibility 5.3，
'''2、并且选择信任对VBA工程访问）
Sub VBComponentsExporting()
Dim strExportFolderPath As String
Dim oVBComp As VBComponent
Dim oExportFolder As Object
Dim strExtName As String
Dim oWb As Workbook

Set oWb = ThisWorkbook

Set fso = CreateObject("scripting.filesystemobject")

strExportFolderPath = oWb.Path & "\" & "所有模块"

If Not fso.folderexists(strExportFolderPath) Then
    fso.createfolder (strExportFolderPath)
End If

Set zd = CreateObject("scripting.dictionary")

For Each oVBComp In ThisWorkbook.VBProject.VBComponents
    If Not zd.exists(oVBComp.Name) Then
        Select Case oVBComp.Type
            Case vbext_ct_StdModule 'case 1
                zd(oVBComp.Name) = oVBComp.Name & ".bas"
            Case vbext_ct_ClassModule 'case 2
                zd(oVBComp.Name) = oVBComp.Name & ".cls"
            Case vbext_ct_MSForm 'case 3
                zd(oVBComp.Name) = oVBComp.Name & ".frm"
            Case vbext_ct_Document 'case 100
                If oVBComp.Name <> "ThisWorkbook" Then
                    For Each sht In ThisWorkbook.Worksheets
                        If sht.CodeName = oVBComp.Name Then
                            zd(oVBComp.Name) = sht.Name & ".txt"
                        End If
                    Next sht
                Else
                    zd(oVBComp.Name) = oVBComp.Name & ".txt"
                End If
        End Select
    End If
Next oVBComp

Set oVBProj = ThisWorkbook.VBProject
zdkeys = zd.keys
For i = 0 To zd.Count - 1
    strVBCompName = zdkeys(i)
    oVBProj.VBComponents(strVBCompName).Export strExportFolderPath & "\" & zd(strVBCompName)
Next i

MsgBox "所有模块导出完毕！"

End Sub

dogingate

Attribute VB_Name = "Word模块导入"
Sub ModuleUpdating()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim oVBProj As Object, oVBComp As Object, oDoc As Object
Dim strFilePath As String

Set fso = CreateObject("scripting.filesystemobject")

Set oDoc = ThisDocument

strFilePath = oDoc.Path & "\" & oDoc.Name

For i = 1 To Application.VBE.VBProjects.Count
    If Application.VBE.VBProjects(i).fileName = strFilePath Then
        Set oVBProj = Application.VBE.VBProjects(i)
    End If
Next i

For Each oVBComp In oVBProj.VBComponents
    Select Case oVBComp.Type
        Case 1, 2, 3
            With oVBProj.VBComponents
                .Remove .Item(oVBComp.Name) '删除模块、类模块、窗体
            End With
        Case Else
            oVBComp.CodeModule.DeleteLines 1, oVBComp.CodeModule.CountOfLines '删除工作表或Thisworkbook代码区代码
    End Select
Next

'   选择模块所在文件夹
strFolderPath = oDoc.Path & "\" & "Word所有模块"

Set reg = CreateObject("vbscript.regexp")
Set oFolder = fso.getfolder(strFolderPath)
For Each file In oFolder.Files
    strFileName = fso.getbasename(file)
    sText = LCase(strFileName)

    With reg
        .Global = True '设置是否匹配所有的符合项，True表示匹配所有, False表示仅匹配第一个符合项
        .IgnoreCase = True '           设置是否区分大小写，True表示不区分大小写, False表示区分大小写
        .Pattern = "^(thisdocument)" '           判断是否可以找到匹配的字符，若可以则返回True

        If .test(sText) Then '是document模块
            Set objMatches = .Execute(sText)
            strMatches = objMatches(0).Value '编号从0开始
            oVBProj.VBComponents("ThisDocument").CodeModule.AddFromFile file
        Else '非document模块
            oVBProj.VBComponents.Import file
        End If
    End With

Next file

MsgBox "所有模块导入完毕！"

End Sub