modelList

mdlSelectFolder' ''''''''''''''''''''''''''''''''''''''''''''''''''' 模块名称：SelectFolder' 模块功能: 选择文件夹' 创建者: Andy' 创建时间: 2009年6月20日' 输出: 所选文件夹的路径' ''''''''''''''''''''''''''''''''''''''''''''''''''' 使用变量之前必须首先声明Option Explicit' 声明API函数Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPublic Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPublic Declare Function SHBrowseForFolder Lib "shell32" (lpbi As udtBrowseInfo) As LongPublic Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long' 声明常量Public Const BIF_EDITBOX = 1Public Const MAX_PATH = 260' 声明自定义数据类型Public Type udtBrowseInfo hWndOwner As Long ' 对话框的所有者(如果没有,则参数为0) pIDLRoot As Long ' 从何根路径开始展开文件夹,参数及路径如下 ' 参数 路径 ' 0 桌面及我的电脑 ' 2 程序 ' 3 控制面板 ' 4 打印机及传真 ' 5 我的文档 ' 6 收藏夹 ' 7 启动 ' 8 我最近的文档 ' 10 回收站 ' 11 开始 ' 26 Application Data ' 36 Windows ' 37 System32 ' 38 Program Files ' 39 图片收藏夹 pszDisplayName As Long ' 指向一个缓存,该缓存返回用户选中的文件夹的显示名称,缓存的大小设置为MAX_PATH lpszTitle As Long ' 对话框上的treeview控件上方显示的标题, 并不是对话框的标题 ulFlags As Long ' 显示标志控制项. 'BIF_RETURNONLYFSDIRS, 只有当用户选中的是文件夹时"确定"按钮才有效 'BIF_BROWSEFORCOMPUTER, 只有选中"我的电脑"时"确定"按钮才有效 'BIF_EDITBOX, 在对话框上显示一个Edit, 允许用户输入选中项的名称 'BIF_STATUSTEXT, 界面上包含一块statu区域, 回调函数通过向对话框发送 ' BFFM_SETSTATUSTEXT消息设置静态文本 'BIF_VALIDATE , 当用户在Edit中输入不正确的名字时, 向对话框发送 ' BFFM_VALIDATEFAILED消息 , 并调用对话框的回调函数处理该消息 lpfnCallback As Long lParam As Long ' 对话框传递给回调函数的参数 iImage As Long ' 返回与选中文件夹关联的图片的index , 该index是图片在系统ImageList中的index值End Type' 声明选择文件夹函数Public Function SelectFolder(hWndOwner As Long, sPrompt As String) As String ' 声明变量 Dim intNull As Integer Dim lngList As Long Dim strPath As String Dim myBI As udtBrowseInfo ' 初始化参数 With myBI .hWndOwner = hWndOwner .lpszTitle = lstrcat(sPrompt, "") .pIDLRoot = 0 .ulFlags = BIF_EDITBOX End With lngList = SHBrowseForFolder(myBI) If lngList Then strPath = String$(MAX_PATH, 0) lngList = SHGetPathFromIDList(lngList, strPath) Call CoTaskMemFree(lngList) intNull = InStr(strPath, vbNullChar) If intNull Then strPath = Left(strPath, intNull - 1) End If ' 确保路径字符串的最后一个字符为"/" If Right(Trim(strPath), 1) <> "/" Then strPath = strPath & "/" End If SelectFolder = strPathEnd Function'Sub mySelectFolder()'' ' 浏览并选择目录' Dim sFolder As String' sFolder = SelectFolder(0, "请选择目录")'' ' 显示所选择目录的路径' Debug.Print Trim(sFolder)'End SubmdlReferenceProcessingPublic i As IntegerSub ReferenceProcessing() Dim myFSO As New Scripting.FileSystemObject Dim myFolder As Scripting.Folder Set myFolder = myFSO.GetFolder(SelectFolder(0, "请选择目录")) On Error GoTo ErrHander ProcessFileAndSubs myFolder ErrHander: Debug.Print Err.Description Resume Next End SubSub ProcessFileAndSubs(FolderIn As Scripting.Folder) Dim myFile As Scripting.File Dim mySubFolder As Scripting.Folder Dim myModel As ModelReference Dim att As Attachment For Each myFile In FolderIn.Files Select Case UCase(Right(myFile.Name, 3)) Case "DGN" i = i + 1 Application.OpenDesignFile myFile.Path, True 'On Error Resume Next If Application.HasActiveDesignFile = True Then ' 循环读取每个DGN文件的model名称 ' 写入文件进行备份 Open "D:/log.txt" For Append As #1 Print #1, "*****************************************************************************" Print #1, "(" & i; ") " & Application.ActiveDesignFile.FullName Dim j As Integer j = 0 For Each myModel In Application.ActiveDesignFile.Models j = j + 1 Print #1, " Model(SHEET " & j & " OF " & Application.ActiveDesignFile.Models.Count & "):" & myModel.Name Dim k As Integer k = 0 For Each att In Application.ActiveModelReference.Attachments Dim strAttachName As String strAttachName = att.AttachName k = k + 1 Print #1, " Attachment(SHEET " & k & " OF " & Application.ActiveModelReference.Attachments.Count & "):" & strAttachName Next Next Close #1 End If End Select Next For Each mySubFolder In FolderIn.SubFolders ProcessFileAndSubs mySubFolder NextEnd Sub引用:microsoft script runtime