Re: xl2k: Bei Import Textdatei kommt Laufz.fehler 1004
30.08.2002 10:52:38
Bongartz
Hallo Axelich habe das mal mit "On Error Resume Next" versucht. der Fehler wird übergangen aber dann sind keine Daten in Excel. Der Fehler kommt immer wenn ich das Verzeichnis wechsele.
Ich stelle mal den Kompletten Code rein, vieleicht ist es dann besser nachvollziehbar.
Gruß
Bongartz
'Formular frmDateiListe
Private Sub CommandButton1_Click()
Dim strFileName As String, strFileName2 As String, lCommandLine As String, strFile As String
Dim intX As Integer
'Dateinamen anhand des ListIndex der ComboBox1
'aus dem FileArray() auslesen.
strFileName = FileArray(ComboBox1.ListIndex + 1)
'Datei für Datenimport öffnen
strFileName2 = strFileName
strFile = strPath & strFileName2
Call PricatSendenImport(strFile, strFileName2)
Unload Me
End SubPrivate Sub CommandButton2_Click()
'Schaltfläche "Schließen" entlädt die UserForm.
Unload Me
End Sub
Private Sub ComboBox1_Change()
'Beim Auswählen eines Listeneintrags wird der
'CommandButton1 aktiviert.
CommandButton1.Enabled = True
End Sub
Code eingefügt mit Syntaxhighlighter 1.13
'Modul modFileList
Option Explicit
Public FileArray()
Public strPath As String
Public intCounter As IntegerPublic 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
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const MAX_PATH = 260
Public Declare Function SHGetPathFromIDList _
Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal _
lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function GetActiveWindow Lib "user32" () As Long
'Verzeichnisdialog anzeigen und Pfad festlegen
Sub VerzeichnisAuswahl()
Dim bi As BROWSEINFO
Dim pidl As Long
Dim path As String
Dim pos As Integer
Dim Hwnd As Long
Hwnd = GetActiveWindow
bi.hOwner = Hwnd
bi.pidlRoot = 0&
bi.lpszTitle = "Verzeichnis auswählen"
bi.ulFlags = BIF_RETURNONLYFSDIRS
pidl = SHBrowseForFolder(bi)
path = Space$(MAX_PATH)
If SHGetPathFromIDList(ByVal pidl, ByVal path) Then
'Pfad auslesen und Prozedur zum Einlesen der
'Dateien in Combobx aufrufen.
pos = InStr(path, Chr$(0))
Call Populate_Combo(Left(path, pos - 1))
'UserForm anzeigen
frmDateiListe.Show
End If
End Sub
Sub Populate_Combo(strDir As String)
Dim strFileName As String
frmDateiListe.ComboBox1.Clear
'ComboBox mit Dateiname im festgelegten Verzeichnis füllen.
With frmDateiListe
.Label1.Caption = strDir
If Right(strDir, 1) <> "\" Then strDir = strDir & "\"
strFileName = Dir(strDir)
Do Until strFileName = ""
'Nur die Textdateien im ausgewählten Verzeichnis
'in die Combobox und in das FileArray() einlesen.
If Right(strFileName, 3) = "txt" Then
intCounter = intCounter + 1
'FileArray() neu dimensionieren und den Datei-
'namen einlesen.
ReDim Preserve FileArray(1 To intCounter)
FileArray(intCounter) = strFileName
'Listeneintrag mit Dateinamen hinzufügen
.ComboBox1.AddItem strFileName
End If
strFileName = Dir
Loop
.CommandButton1.Enabled = False
End With
strPath = strDir
'Das Deaktivieren des CommandButton1 zwingt den Anwender,
'einen Listeneintrag auszuwählen, sonst kann die UserForm
'nur über den 2. Commandbutton geschlossen werden. Dadruch
'kann man sich Fehlerprüfungen ersparen.
End Sub
Code eingefügt mit Syntaxhighlighter 1.13
'Modul modPricat
Private Const Pfad2 = "P:\PRICAT\Archiv\"
Private Const Pfad3 = "P:\PRICAT\Senden\"Private Sub SendenListe_Show()
Call Populate_Combo(Pfad3)
frmDateiListe.Show
End Sub
Private Sub ArchivListe_Show()
Call Populate_Combo(Pfad2)
frmDateiListe.Show
End Sub
Public Sub PricatSendenImport(ByVal strFile As String, strFileName2 As String)
' EdekaImport Makro
'On Error Resume Next
'Dim strName
strConnection = "TEXT;" & strFile
strName = strFileName2
Workbooks.Add
'ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
strConnection, Destination:=Range("A1"))
.Name = strName
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, _
2, 2, 2, 2, 2, 2, 2, 2)
.TextFileFixedColumnWidths = Array(14, 14, 14, 10, 5, 30, 12, 7, 2, 2, 3, 3, 9, _
7, 4, 7, 7, 8, 8, 5, 2)
.Refresh BackgroundQuery:=False
End With
'Active
Sheets("Tabelle1").Name = strName
Call PricatUeberschrift
Call PricatSpaltenbreite
Range("D2").Select
End Sub
Code eingefügt mit Syntaxhighlighter 1.13