|
Netuším jestli je to ideální řešení ale možná by se to někomu jako inspirace mohlo hodit. Musel jsem řešit ještě pár možných problému, takže je to dost specifické řešení.
Function ImportText() As Boolean
Dim AdoConn As New Connection
Set AdoConn = CurrentProject.Connection
Dim LocRS As New ADODB.Recordset
Dim myF As ADODB.Field
Dim SQL_AppSet As String
Dim InitialDir As String
On Error GoTo Import_Err
Dim fso As New Scripting.FileSystemObject
Dim txt As Scripting.TextStream
Dim fAbsolutePath As String
Dim fOriginalFileName As String
Dim fImportFileName As String
Dim fPath As String
Dim fExtension As String
Dim ImportReady As Boolean
Dim fLine As String
Dim fText As String
Dim CutLine As String
Set fso = CreateObject("Scripting.FileSystemObject")
SQL_AppSet = "SELECT setValue as setValue " & _
"FROM tbl_AppSettings " & _
"WHERE Type = 'ImportFolder'"
If LocRS.State = 1 Then LocRS.Close
LocRS.Open SQL_AppSet, AdoConn, adOpenKeyset, adLockOptimistic
InitialDir = LocRS.Fields(0)
If Not fso.FolderExists(InitialDir) Then InitialDir = "C:\"
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = Application.hWndAccessApp
OFName.hInstance = Application.hWndAccessApp
OFName.lpstrFilter = "Import dat" & "(*.txt)" + Chr$(0) + "*.txt" + Chr$(0)
OFName.lpstrFile = Space$(254)
OFName.nMaxFile = 255
OFName.lpstrFileTitle = Space$(254)
OFName.nMaxFileTitle = 255
OFName.lpstrInitialDir = InitialDir
OFName.lpstrTitle = "Import dat "
OFName.flags = 0
If GetOpenFileName(OFName) Then
fAbsolutePath = Trim$(OFName.lpstrFile)
fOriginalFileName = fso.GetBaseName(fAbsolutePath)
fPath = Mid(fAbsolutePath, 1, Len(fAbsolutePath) - (Len(fOriginalFileName) + Len(fExtension) + 5))
fExtension = fso.GetExtensionName(fAbsolutePath)
If InitialDir <> fPath Then
LocRS.Fields(0).Value = fPath
LocRS.Update
If LocRS.State = 1 Then LocRS.Close
AdoConn.Close
End If
Else
Set fso = Nothing
If LocRS.State = 1 Then LocRS.Close
AdoConn.Close
ImportText = False
Exit Function
End If
Set txt = fso.OpenTextFile(fAbsolutePath, ForReading)
fText = txt.ReadAll
txt.Close
Set txt = fso.OpenTextFile(fAbsolutePath, ForReading)
Do Until txt.AtEndOfStream
fLine = txt.ReadLine
If Left(fLine, 8) = "Elapsed:" Then
CutLine = fLine
fText = Replace(fText, CutLine, "")
Exit Do
End If
Loop
txt.Close
fText = Trim(fText)
If Asc(Left(fText, 1)) = Asc(CStr(Chr(12))) Then
fText = Right(fText, Len(fText) - 1)
End If
Dim TestAsc As Byte
test:
TestAsc = Asc(Right(fText, 1))
If TestAsc = 12 Or TestAsc = 10 Then
fText = Left(fText, Len(fText) - 1)
GoTo test
End If
fText = Trim(fText)
Select Case True
Case Left(fOriginalFileName, 15) = "B05_TransDetail"
fAbsolutePath = fPath & Left(fOriginalFileName, 15) & "." & fExtension
ImportReady = True
Case Else
ImportReady = False
MsgBox "Neznámý název souboru pro import", vbInformation, "Neznámý import"
ImportText = False
Exit Function
End Select
If ImportReady Then
If fso.FileExists(fAbsolutePath) Then
fso.DeleteFile (fAbsolutePath)
End If
fso.CreateTextFile (fAbsolutePath)
Set txt = fso.OpenTextFile(fAbsolutePath, ForWriting)
txt.Write ""
txt.Write fText
txt.Close
DoCmd.SetWarnings False
DoCmd.TransferText acImportDelim, "B05_TransDetail", "B05_TransDetail",fAbsolutePath, True, "", 28592
DoCmd.SetWarnings True
ImportText = True
MsgBox "Import úspěšně dokončen", vbInformation, "Import"
End If
Set fso = Nothing
Set txt = Nothing
Exit Function
Import_Err:
ImportText = False
MsgBox Error$, vbCritical, "Chyba importu"
Exit Function
End Function
|