--------------------------------------------------------------------------------
Hallo zusammen,
ich würde gern das Marko in ein VB.NET umschreiben kann mir jemand helfen?
Public Function GetXLFiles(ByRef astrXLFiles() As String, _
ByVal strLookIn As String, Optional fSearchSubfolders _
As Boolean = False) As Boolean
Dim nFilesCnt As Long
Dim nFile As Long
Dim nCounter As Long
Dim strFileName As String
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = strLookIn
.SearchSubFolders = fSearchSubfolders
.Filename = ".xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName, SortOrder:= _
msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then
nFilesCnt = .FoundFiles.Count
ReDim astrXLFiles(0 To nFilesCnt - 1)
nCounter = -1
For nFile = 1 To nFilesCnt
strFileName = .FoundFiles(nFile)
If Len(Dir$(strFileName)) > 0 Then
nCounter = nCounter + 1
astrXLFiles(nCounter) = strFileName
End If
Next
If nCounter > -1 Then
ReDim Preserve astrXLFiles(0 To nCounter)
GetXLFiles = True
End If
End If
End With
On Error GoTo 0
End Function
Public Sub Demo()
Dim strPath As String
Dim astrXLFiles() As String
Dim nFile As Long
strPath = "c:\test\"
If Len(Dir$(strPath, vbDirectory)) > 0 Then
If GetXLFiles(astrXLFiles(), strPath, True) Then
For nFile = 0 To UBound(astrXLFiles)
Debug.Print astrXLFiles(nFile)
Workbooks.Open astrXLFiles(nFile), UpdateLinks:=3
ActiveWorkbook.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
ActiveWorkbook.Close
Next
Erase astrXLFiles
Else
MsgBox "Keine Excel-Arbeitsmappen im Verzeichnis " & _
vbCrLf & strPath & vbCrLf & "gefunden!", _
vbInformation, "DEMO"
End If
Else
MsgBox "Das Verzeichnis " & vbCrLf & strPath & vbCrLf & _
"existiert nicht!", vbInformation, "DEMO"
End If
End Sub
DANKE im Vorraus
Miles
Hallo zusammen,
ich würde gern das Marko in ein VB.NET umschreiben kann mir jemand helfen?
Public Function GetXLFiles(ByRef astrXLFiles() As String, _
ByVal strLookIn As String, Optional fSearchSubfolders _
As Boolean = False) As Boolean
Dim nFilesCnt As Long
Dim nFile As Long
Dim nCounter As Long
Dim strFileName As String
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = strLookIn
.SearchSubFolders = fSearchSubfolders
.Filename = ".xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName, SortOrder:= _
msoSortOrderAscending, AlwaysAccurate:=True) > 0 Then
nFilesCnt = .FoundFiles.Count
ReDim astrXLFiles(0 To nFilesCnt - 1)
nCounter = -1
For nFile = 1 To nFilesCnt
strFileName = .FoundFiles(nFile)
If Len(Dir$(strFileName)) > 0 Then
nCounter = nCounter + 1
astrXLFiles(nCounter) = strFileName
End If
Next
If nCounter > -1 Then
ReDim Preserve astrXLFiles(0 To nCounter)
GetXLFiles = True
End If
End If
End With
On Error GoTo 0
End Function
Public Sub Demo()
Dim strPath As String
Dim astrXLFiles() As String
Dim nFile As Long
strPath = "c:\test\"
If Len(Dir$(strPath, vbDirectory)) > 0 Then
If GetXLFiles(astrXLFiles(), strPath, True) Then
For nFile = 0 To UBound(astrXLFiles)
Debug.Print astrXLFiles(nFile)
Workbooks.Open astrXLFiles(nFile), UpdateLinks:=3
ActiveWorkbook.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
ActiveWorkbook.Close
Next
Erase astrXLFiles
Else
MsgBox "Keine Excel-Arbeitsmappen im Verzeichnis " & _
vbCrLf & strPath & vbCrLf & "gefunden!", _
vbInformation, "DEMO"
End If
Else
MsgBox "Das Verzeichnis " & vbCrLf & strPath & vbCrLf & _
"existiert nicht!", vbInformation, "DEMO"
End If
End Sub
DANKE im Vorraus
Miles
