Mittels VBA Code in Tabellenmodul eintragen
22.09.2005 07:48:52
Josef
Mit nachfolgendem Code möchte ich mittels VBA den Code in das Modul der Tabelle1 eintragen lassen.
1.) LineNr = .CreateEventProc("Change", "Worksheet") ist auf jeden Fall falsch.
Ohne LineNr dürfte dies alles anscheinend aber nicht funktionieren.
Die erste Zeile würde mit "Private Type BrowseInfo" anfangen.
2.) Watum bricht der code immer nach der Zeile .InsertLines LineNr + 32, "DateiName = fl.Name"
ab?
Wo müßte man hier bitte eine Änderung durchführen damit dieser code funkitoniert?
Danke
Josef
Sub WB_Code_via_VBA_Wien()
Const WS As String = "Tabelle1"
'Dim WB As Workbook
Dim VBC As Object
Dim LineNr
'Set WB = Workbooks.Add
With ActiveWorkbook.VBProject.VBComponents(WS).CodeModule
LineNr = .CreateEventProc("Change", "Worksheet")
.InsertLines LineNr + 1, "Private Type BrowseInfo"
.InsertLines LineNr + 2, "hwndOwner As Long"
.InsertLines LineNr + 3, "pIDLRoot As Long"
.InsertLines LineNr + 4, "pszDisplayName As Long"
.InsertLines LineNr + 5, "lpszTitle As Long"
.InsertLines LineNr + 6, "ulFlags As Long"
.InsertLines LineNr + 7, "lpfnCallback As Long"
.InsertLines LineNr + 8, "lParam As Long"
.InsertLines LineNr + 9, "iImage As Long"
.InsertLines LineNr + 10, "End Type"
.InsertLines LineNr + 11, "Private Const BIF_RETURNONLYFSDIRS = 1"
.InsertLines LineNr + 12, "Private Const MAX_PATH = 1000"
.InsertLines LineNr + 13, "Private Declare Sub CoTaskMemFree Lib ""ole32.dll"" (ByVal hMem As Long)"
.InsertLines LineNr + 14, "Private Declare Function lstrcat Lib ""kernel32"" Alias ""lstrcatA"" (ByVal lpString1 As String, ByVal lpString2 As String) As Long"
.InsertLines LineNr + 15, "Private Declare Function SHBrowseForFolder Lib ""shell32"" (lpbi As BrowseInfo) As Long"
.InsertLines LineNr + 16, "Private Declare Function SHGetPathFromIDList Lib ""shell32"" (ByVal pidList As Long, ByVal lpBuffer As String) As Long"
.InsertLines LineNr + 17, "' Deklarationen für das Tabellenblatt"
.InsertLines LineNr + 18, "Private Const TBL = ""Einlesen"""
.InsertLines LineNr + 19, "Private Const STARTZEILE = 1"
.InsertLines LineNr + 20, "Private Const SPALTE = 1"
.InsertLines LineNr + 21, "' liest alle ersten Zeilen jeder Textdatei des gewählten Ordners"
.InsertLines LineNr + 22, "' in das auf TBL definierte Tabellenblatt ein"
.InsertLines LineNr + 23, "' Startzeile + Startspelte sin doben definiert"
.InsertLines LineNr + 24, "Sub ersteZeile_einlesen_Wien()"
.InsertLines LineNr + 25, "Dim fs, Txt, Fld, fl, pf$"
.InsertLines LineNr + 26, "pf = BrowseForFolder(0, ""Pfad für die Textdateien wählen .."")"
.InsertLines LineNr + 27, "If pf = vbNullString Then Exit Sub"
.InsertLines LineNr + 28, "Set fs = CreateObject(""Scripting.Filesystemobject"")"
.InsertLines LineNr + 29, "Set Fld = fs.GetFolder(pf)"
.InsertLines LineNr + 30, "With Sheets(""Wien"")"
.InsertLines LineNr + 31, "For Each fl In Fld.Files"
.InsertLines LineNr + 32, "DateiName = fl.Name"
.InsertLines LineNr + 33, "DateiName = Right(DateiName, Len(DateiName) - InStrRev(DateiName, " \ "))"
.InsertLines LineNr + 34, "If Left(DateiName, 1) = 1 Then"
.InsertLines LineNr + 35, "If LCase(fs.GetExtensionName(fl.Path)) = ""txt"" Or LCase(fs.GetExtensionName(fl.Path)) = ""dat"" Or _"
.InsertLines LineNr + 36, "IsNumeric(fs.GetExtensionName(fl.Path)) Or IsNumeric(Left(fs.GetExtensionName(fl.Path), 1)) Then"
.InsertLines LineNr + 37, "Set Txt = fl.OpenAsTextStream"
.InsertLines LineNr + 38, "If .Cells(STARTZEILE, SPALTE).Value = vbNullString Then"
.InsertLines LineNr + 39, ".Cells(STARTZEILE, SPALTE).Value = Txt.ReadLine"
.InsertLines LineNr + 40, ".Cells(STARTZEILE, SPALTE + 1).Value = fl.Path"
.InsertLines LineNr + 41, "Else"
.InsertLines LineNr + 42, ".Cells(.Cells(Rows.Count, SPALTE).End(xlUp).Row + 1, SPALTE).Value = Txt.ReadLine"
.InsertLines LineNr + 43, ".Cells(.Cells(Rows.Count, SPALTE).End(xlUp).Row, SPALTE + 1).Value = fl.Path"
.InsertLines LineNr + 44, "End If"
.InsertLines LineNr + 45, "Txt.Close"
.InsertLines LineNr + 46, "End If"
.InsertLines LineNr + 47, "End If"
.InsertLines LineNr + 48, "Next"
.InsertLines LineNr + 49, "End With"
.InsertLines LineNr + 50, "Set fs = Nothing: Set Txt = Nothing: Set Fld = Nothing: Set fl = Nothing"
.InsertLines LineNr + 51, "End Sub "
.InsertLines LineNr + 52, "
Private Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String"
.InsertLines LineNr + 53, "Dim iNull As Integer"
.InsertLines LineNr + 54, "Dim lpIDList As Long"
.InsertLines LineNr + 55, "Dim lResult As Long"
.InsertLines LineNr + 56, "Dim sPath As String"
.InsertLines LineNr + 57, "Dim udtBI As BrowseInfo"
.InsertLines LineNr + 58, "With udtBI"
.InsertLines LineNr + 59, ".hwndOwner = hwndOwner"
.InsertLines LineNr + 60, ".lpszTitle = lstrcat(sPrompt, "")"
.InsertLines LineNr + 61, ".ulFlags = BIF_RETURNONLYFSDIRS"
.InsertLines LineNr + 62, "End With"
.InsertLines LineNr + 63, "lpIDList = SHBrowseForFolder(udtBI)"
.InsertLines LineNr + 64, "If lpIDList Then"
.InsertLines LineNr + 65, "sPath = String$(MAX_PATH, 0)"
.InsertLines LineNr + 66, "lResult = SHGetPathFromIDList(lpIDList, sPath)"
.InsertLines LineNr + 67, "Call CoTaskMemFree(lpIDList)"
.InsertLines LineNr + 68, "iNull = InStr(sPath, vbNullChar)"
.InsertLines LineNr + 69, "If iNull Then sPath = Left$(sPath, iNull - 1)"
.InsertLines LineNr + 70, "End If"
.InsertLines LineNr + 71, "BrowseForFolder = sPath"
.InsertLines LineNr + 72, "End Function
End With
End Sub
Anzeige