Excel

Miles21

Grünschnabel
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
 
Zurück