Lektüre VBA hauptsächlich mit Dateien?! (Autodesk/AutoCAD VBA)

ahh alles klar, ein dir *.dwg /s >> frm_1

Beispielcode um Dateitypen vorzufiltern, dwg, dxf, 3ds, dwt, dws ist am Ende doch immer ein Bestandteil von einem wichtigen Modul und sollte (womöglich auch schon in Vordergrund in der Form als ein Pulldown existieren.

Code:

Option Explicit
'///API FOR RETURN FOLDER DIALOG///
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Const MAX_PATH = 2600
'///END API FOR THE RETURN FOLDER DIALOG///
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
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 FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'A variable to hold found files from the
'FindFile method
Private cFiles As Collection
Private Sub Class_Initialize()
Set cFiles = New Collection
End Sub
'//Display the Browse For Folder Dialog ///
Public Function ReturnFolder() As String
Dim Browser As BROWSEINFO
Dim lngFolder As Long
Dim strPath As String
With Browser
.hOwner = FindWindow(vbNullString, Application.Caption)
.lpszTitle = "Select Directory to work in"
.pszDisplayName = String(MAX_PATH, 0)
End With
strPath = String(MAX_PATH, 0)
lngFolder = SHBrowseForFolder(Browser)
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
End If
End Function
'//Search for files
Public Sub FindFile(StartPath As String, _
Extension As String, GetSubs As Boolean)
Dim strFileName As String
'Dim cDir As New Collection
Dim intCnt As Integer
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
On Error GoTo Err_Control
If Len(StartPath) > 0 Then
If Right(StartPath, 1) <> "\" Then
StartPath = StartPath & "\"
End If
hFile = FindFirstFile(StartPath & "*.*", WFD)
If hFile <> INVALID_HANDLE_VALUE Then
Do
strFileName = Left(WFD.cFileName, _
InStr(WFD.cFileName, vbNullChar) - 1)
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
If strFileName <> "." And strFileName <> ".." Then
If GetSubs Then
FindFile StartPath & strFileName, Extension, GetSubs
End If
End If
Else
If StrComp(Right(strFileName, 3), Extension, _
vbTextCompare) = 0 Then
cFiles.Add StartPath & strFileName
End If
End If
'Just in case someone does a search from the root
'Of a BIG drive
DoEvents
Loop While FindNextFile(hFile, WFD)
hFile = FindClose(hFile)
End If
End If
Exit_Here:
Exit Sub
Err_Control:
'There are several system files that
'will cause errors...
Err.Raise Err.Number, "Find File", Err.Description
End Sub
'After FindFile is run, this will return
'The count of files found!
Public Property Get FileCount() As Long
FileCount = cFiles.Count
End Property
'Get the path of a file in the cFiles collection
Public Function GetFile(lngID As Long) As String
On Error GoTo Err_Control
GetFile = cFiles(lngID)
Exit_Here:
Exit Function
Err_Control:
Err.Raise Err.Description
End Function
'//Returns just the file name, no path
Public Function GetFileName(strFilePath) As String
Dim intPos As Integer
Dim intCnt As Integer
GetFileName = strFilePath
intPos = InStr(strFilePath, "\")
Do While intPos
intCnt = intPos
intPos = InStr(intCnt + 1, strFilePath, "\")
Loop
If intCnt > 0 Then GetFileName = Mid(strFilePath, intCnt + 1)
End Function
'// Returns only the path, no file name
Public Function GetFilePath(strFileName As String) As String
Dim intCnt As Long
For intCnt = Len(strFileName) To 1 Step -1
Select Case Mid(strFileName, intCnt, 1)
Case ":"
GetFilePath = Left(strFileName, intCnt)
Exit For
Case "\"
GetFilePath = Left(strFileName, intCnt - 1)
Exit For
End Select
Next intCnt
End Function
'Fast way to clear the collection
Public Sub ResetFiles()
Set cFiles = New Collection
End Sub

---------------------------------------------------------------------'
Deine Anpassungen dürften minimal mit dem Beispiel-Projekt, als Anhang eingefügt, sein.

Code:

'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.
'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!
'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm ---------
'Control CheckBox: Check1
'Control DriveListBox: Drive1
'Control DirListBox: Dir1
'Control TextBox: Text2
'Control TextBox: Text1
'Control CommandButton: Command1
'Control ListBox: List1
'Control Label: Label6
'Control Label: Label5
'Control Label: Label4
'Control Label: Label3
'Control Label: Label2
'Control Label: Label1
'Dank an Lothar Kriegerow für die Verwirklichung der Filter-
'funktion.
Option Explicit
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 FindClose Lib "kernel32" (ByVal _
hFindFile As Long) As Long
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MAX_PATH = 259
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
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_COMPRESSED = &H800
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 Sub Dir1_Change()
Text1.Text = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
Text1.Text = Dir1.Path
Text2.Text = "*.*"
End Sub
Private Sub Command1_Click()
Dim Files() As String, X&, Such$
Dim DatCnt%, DirCnt%
Such$ = Trim$(UCase$(Text2.Text))
If Left$(Such$, 1) = "*" Then Such$ = Right$(Such$, Len(Such$) - _
InStr(Such$, "."))
ReDim Files(0 To 0)
MousePointer = 11
DoEvents
Call GetAllFiles(Text1.Text, Such$, Files)
MousePointer = 0
DoEvents
List1.Clear
For X = 0 To UBound(Files) - 1
List1.AddItem Files(X)
If Left$(Files(X), 2) = ">>" Then
DirCnt = DirCnt + 1
Label5.Caption = DirCnt
Label5.Refresh
Else
DatCnt = DatCnt + 1
Label6.Caption = DatCnt
Label6.Refresh
End If
Next X
End Sub
Private Sub GetAllFiles(ByVal Root$, ByVal Such$, ByRef Field$())
Dim File$, hFile&, FD As WIN32_FIND_DATA
DoEvents
If Right(Root, 1) <> "\" Then Root = Root & "\"
hFile = FindFirstFile(Root & "*.*", FD)
If hFile = 0 Then Exit Sub
Do
File = Left(FD.cFileName, InStr(FD.cFileName, Chr(0)) - 1)
If (FD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
= FILE_ATTRIBUTE_DIRECTORY Then
If (File <> ".") And (File <> "..") Then
'Verz.: ">>" kann entfernt werden,da nur zur Visualisierung

If Check1.Value Then
Field(UBound(Field)) = ">>" & Root & File
ReDim Preserve Field(0 To UBound(Field) + 1)
End If
GetAllFiles Root & File, Such$, Field
End If
Else
'Datei: " " kann entfernt werden,da nur zur Visualisierung
If Such$ = Right$(UCase$(File), Len(Such$)) Or Such$ = "*" Then
Field(UBound(Field)) = " " & Root & File
ReDim Preserve Field(0 To UBound(Field) + 1)
End If
End If
Loop While FindNextFile(hFile, FD)
Call FindClose(hFile)
End Sub
'---------- Ende Formular "Form1" alias Form1.frm ----------
'-------------- Ende Projektdatei Project1.vbp --------------

------------------
"Lisp?!?! Why the Hell did you pick the most arcane, obscure, and hopelessly-rooted-in-the-computer-science-department language in the world for an AutoCAD programming language?" Read the whole story: The Autodesk File ca. 890 Seiten | 7500 KB PDF

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

GWB Get wooden beams CAD APP für Holzarbeiten, 3D, Tiefbau