Autodesk Inventor

Небольшая утилита по поиску проектов Инвентора (файлов 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.

Скрытый текст

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

Функции для поиска файлов. Должны быть в модуле класса под названием clFindFiles.

Скрытый текст

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