Поиск проектов Inventor и создание ярлыков

Форум » Программирование в Autodesk Inventor|VBA, iPart, iFeature » Поиск проектов Inventor и создание ярлыков » Ответить

Поиск проектов Inventor и создание ярлыков

Ab: Небольшая утилита по поиску проектов Инвентора (файлов ipj) на дисках или указанных папках и создающая ярлыки этих проектов в соответствующей папке Инвентора (для отображения в диалоге проектов). Тестировалось на AIS 11 SP3. Название: IPJSearch1.rar Размер: 388.28 кб Доступен до: 2007-11-03 07:29:46 Ссылка для скачивания файла: http://ifolder.ru/3588879 Ниже макрос, делающий тоже самое. Sub FindProjects() Dim cFind As New clFindFiles Dim cfList As New Collection Dim path As String path = Module2.BrowseForFolder(0, "Select folder for search") Set cfList = cFind.DoFileSystemSearch(path, "*.ipj", PathsAndFilenames) If cfList.Count > 0 Then Dim I As Integer For I = 1 To cfList.Count Dim dir As String Dim name As String dir = Left(cfList.Item(I), InStrRev(cfList.Item(I), "\") - 1) name = Right(cfList.Item(I), Len(cfList.Item(I)) - InStrRev(cfList.Item(I), "\")) name = Left(name, Len(name) - 4) Dim VbsObj As Object Set VbsObj = CreateObject("WScript.Shell") Dim MyShortcut As Object Set MyShortcut = VbsObj.CreateShortcut(ThisApplication.FileOptions.ProjectsPath & "\" & name & ".lnk") MyShortcut.TargetPath = cfList.Item(I) MyShortcut.IconLocation = cfList.Item(I) MyShortcut.Save Next End If End Sub Диалог выбора папок. Должен быть в модуле с названием Module2. [more] Option Explicit Private Type BrowseInfo lngHwnd As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Private Const BIF_RETURNONLYFSDIRS = 1 Private Const MAX_PATH = 260 Private Declare Sub CoTaskMemFree Lib "ole32.dll" _ (ByVal hMem As Long) Private Declare Function lstrcat Lib "Kernel32" _ Alias "lstrcatA" (ByVal lpString1 As String, _ ByVal lpString2 As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32" _ (lpbi As BrowseInfo) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" _ (ByVal pidList As Long, ByVal lpBuffer As String) As Long Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String On Error GoTo ehBrowseForFolder 'Trap for errors Dim intNull As Integer Dim lngIDList As Long, lngResult As Long Dim strPath As String Dim udtBI As BrowseInfo 'Set API properties (housed in a UDT) With udtBI .lngHwnd = lngHwnd .lpszTitle = lstrcat(strPrompt, "") .ulFlags = BIF_RETURNONLYFSDIRS End With 'Display the browse folder... lngIDList = SHBrowseForFolder(udtBI) If lngIDList <> 0 Then 'Create string of nulls so it will fill in with the path strPath = String(MAX_PATH, 0) 'Retrieves the path selected, places in the null 'character filled string lngResult = SHGetPathFromIDList(lngIDList, strPath) 'Frees memory Call CoTaskMemFree(lngIDList) 'Find the first instance of a null character, 'so we can get just the path intNull = InStr(strPath, vbNullChar) 'Greater than 0 means the path exists... If intNull > 0 Then 'Set the value strPath = Left(strPath, intNull - 1) End If End If 'Return the path name BrowseForFolder = strPath Exit Function 'Abort ehBrowseForFolder: 'Return no value BrowseForFolder = Empty End Function [/more] Функции для поиска файлов. Должны быть в модуле класса под названием clFindFiles. [more] Dim colInPaths As Collection Dim colOutpaths As Collection Dim sInputPath As String Dim sOutputPath As String Dim sInputPath2 As String Dim sOutputPath2 As String Dim lTotalProcess As Long Dim SearchPath As String, FindStr As String Dim FileSize As Long Dim NumFiles As Integer, NumDirs As Integer Dim AppStringName As String Dim cTempCollection As Collection Private Declare Function FindFirstFile Lib "Kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "Kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function GetFileAttributes Lib "Kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long Private Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long Const MAX_PATH = 260 Const MAXDWORD = &HFFFF Const INVALID_HANDLE_VALUE = -1 Const FILE_ATTRIBUTE_ARCHIVE = &H20 Const FILE_ATTRIBUTE_DIRECTORY = &H10 Const FILE_ATTRIBUTE_HIDDEN = &H2 Const FILE_ATTRIBUTE_NORMAL = &H80 Const FILE_ATTRIBUTE_READONLY = &H1 Const FILE_ATTRIBUTE_SYSTEM = &H4 Const FILE_ATTRIBUTE_TEMPORARY = &H100 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Enum ListPaths PathsAndFilenames = 1 FilenamesOnly = 2 PathsOnly = 3 End Enum Dim ListSelected As ListPaths Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Function StripNulls(OriginalStr As String) As String If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function Function FindFilesAPI(ByVal path As String, ByVal SearchStr As String, ByVal FileCount As Integer, ByVal DirCount As Integer) Dim FileName As String ' Walking filename variable... Dim DirName As String ' SubDirectory Name Dim dirNames() As String ' Buffer for directory name entries Dim nDir As Integer ' Number of directories in this path Dim I As Integer ' For-loop counter... Dim hSearch As Long ' Search Handle Dim WFD As WIN32_FIND_DATA Dim Cont As Integer If Right(path, 1) <> "\" Then path = path & "\" ' Search for subdirectories. nDir = 0 ReDim dirNames(nDir) Cont = True hSearch = FindFirstFile(path & "*", WFD) If hSearch <> INVALID_HANDLE_VALUE Then Do While Cont DirName = StripNulls(WFD.cFileName) ' Ignore the current and encompassing directories. If (DirName <> ".") And (DirName <> "..") Then ' Check for directory with bitwise comparison. If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then If InStr(1, path & DirName, "Processed") = 0 Then dirNames(nDir) = DirName DirCount = DirCount + 1 nDir = nDir + 1 ReDim Preserve dirNames(nDir) End If End If End If Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory. Loop Cont = FindClose(hSearch) End If ' Walk through this directory and sum file sizes. hSearch = FindFirstFile(path & SearchStr, WFD) Cont = True If hSearch <> INVALID_HANDLE_VALUE Then While Cont FileName = StripNulls(WFD.cFileName) If (FileName <> ".") And (FileName <> "..") Then FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow FileCount = FileCount + 1 If InStr(1, path & FileName, "SYSTEM FILES") <> 0 Then '// SYSTEM FILES DIRECTORY Else '// OTHER DIRECTORIES cTempCollection.Add path & FileName End If End If Cont = FindNextFile(hSearch, WFD) ' Get next file Wend Cont = FindClose(hSearch) End If ' If there are sub-directories... If nDir > 0 Then ' Recursively walk into them... For I = 0 To nDir - 1 FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(I) & "\", SearchStr, FileCount, DirCount) Next I End If End Function Public Function DoFileSystemSearch(ByVal sPath As String, ByVal sFilter As String, ByVal ListAction As ListPaths) As Collection ListSelected = ListAction Set cTempCollection = New Collection FindFilesAPI sPath, sFilter, NumFiles, NumDirs Set DoFileSystemSearch = cTempCollection End Function [/more]

Ответов - 0

полная версия страницы