|
| | | |
 • V.1. Inne - Shell, MS-DOS •
- 1.1 Jak uzyskać uchwyt okna programu otwartego Shell'em mając jego PID ?
- 1.2 Synchroniczny Shell - wywołanie funkcji Shell w sposób synchroniczny.
- 1.3 Synchroniczny Shell - uruchomiemie pliku wsadowego (*.bat) w sposób synchroniczny.
- 1.4 Jak odczytać tekst z okna poleceń MS-DOS (konsoli) ?
- 1.5 Jak za pomocą komendy DIR wylistować wszystkie pliki na dysku (odczyt z konsoli, przekierowanie do pliku) ?
| | | | |
 |
| | |
|
1.1 Jak uzyskać uchwyt okna programu otwartego Shell'em mając jego PID ?
Private Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, _
lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Const WM_SETTEXT = &HC
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
' Zwraca uchwyt okna uruchomionego w procesie o ID = lPID,
' przy błędzie zwraca ZERO,
Private Function zbPIDtoHwnd(lPID As Long) As Long
Dim lProcID As Long
Dim hNext As Long
Dim lRet As Long
' pobieraj kolejno uchwyty okien (dzieci) pulpitu
hNext = GetWindow(GetDesktopWindow(), GW_CHILD)
Do While hNext <> 0
' pobierz PID okna hNext i porównaj z PID'em Shella
lRet = GetWindowThreadProcessId(hNext, lProcID)
If lProcID = lPID Then
' PID'y są takie same, tzn. mamy uchwyt okna
zbPIDtoHwnd = hNext
Exit Do
End If
hNext = GetWindow(hNext, GW_HWNDNEXT)
Loop
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sCmdLine As String
Dim lShellPID As Long
Dim hWind As Long
' otwórz Notatnik
sCmdLine = Environ$("WINDIR") & "\Notepad.exe"
lShellPID = Shell(sCmdLine, vbNormalFocus)
' pobierz uchwyt okna otwartego Shell'em
hWind = zbPIDtoHwnd(lShellPID)
If hWind = 0 Then Exit Sub
' tylko w celach poglądowych
SendMessage hWind, WM_SETTEXT, _
ByVal 0&, ByVal "Okno otwarte Shell'em"
SendMessage GetWindow(hWind, GW_CHILD), _
WM_SETTEXT, ByVal 0&, _
ByVal "Uchwyt okna = " & hWind
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
Synchroniczny Shell - wywołanie funkcji Shell w sposób synchroniczny.
' Metoda I
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal Handle As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
' uruchamia synchronicznie Shell'a (czeka na zakończenie procesu)
' • sCmdLine - linia polecenia,
' • lAppWinStyle - styl okna w którym jest uruchomiony Shell, - przyjmuje wartości: vbHide, vbNormalFocus, vbMinimizedFocus, vbMaximizedFocus, vbNormalNoFocus, vbMinimizeNoFocus
' • fScreenUpdate - czy w trakcie działania Shell'a ekran ma być odświeżany,
Private Sub zbShellSynchroWin( _
sCmdLine As String, _
lAppWinStyle As Long, _
fScreenUpdate As Boolean)
Dim lShellID As Long
Dim hProc As Long
Dim lRetWait As Long
Const MY_TIME_WAIT As Long = 100
lShellID = Shell(sCmdLine, lAppWinStyle)
If lShellID <> 0 Then
hProc = OpenProcess(SYNCHRONIZE, True, lShellID)
If fScreenUpdate = False Then
lRetWait = WaitForSingleObject(hProc, INFINITE)
Else
Do
' sprawdzaj co MY_TIME_WAIT milisekund
lRetWait = WaitForSingleObject(hProc, MY_TIME_WAIT)
DoEvents
Loop Until lRetWait = 0
End If
CloseHandle hProc
End If
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sCmdLine As String
' otwórz Notatnik
sCmdLine = Environ$("WINDIR") & "\Notepad.exe"
' uruchom Shell'a
Call zbShellSynchroWin(sCmdLine, vbNormalFocus, True)
' i czekaj na zakończenie
MsgBox "Shell zakończony"
End Sub
' Metoda II
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal Handle As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
ByRef lpExitCode As Long) As Long
' Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Sub ShellSynchro_2( _
ByVal sCmdLine As String, _
ByVal lAppWinStyle As Long)
Dim lShellID As Long
Dim hProc As Long
Dim lRet As Long
lShellID = Shell(sCmdLine, lAppWinStyle)
hProc = OpenProcess( _
PROCESS_QUERY_INFORMATION, _
0&, lShellID)
Do
' pobierz do zmiennej lRet status procesu
GetExitCodeProcess hProc, lRet
DoEvents
' Sleep 100&
Loop While lRet = STILL_ACTIVE
CloseHandle hProc
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sCmdLine As String
' otwórz Notatnik
sCmdLine = Environ$("WINDIR") & "\Notepad.exe"
' uruchom Shell'a
Call ShellSynchro_2(sCmdLine, vbNormalFocus)
' i czekaj na zakończenie
MsgBox "Shell zakończony"
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.3 Synchroniczny Shell - uruchomiemie pliku wsadowego (*.bat) w sposób synchroniczny.
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccessas As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal Handle As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Const INFINITE = &HFFFF
Private Const SYNCHRONIZE = &H100000
' uruchamia synchronicznie Shell'a (czeka na zakończenie procesu)
' • sCmdLine - linia polecenia,
' • lAppWinStyle - styl okna w którym jest uruchomiony Shell,- przyjmuje wartości: vbHide, vbNormalFocus, vbMinimizedFocus, vbMaximizedFocus, vbNormalNoFocus, vbMinimizeNoFocus
' • fClose - czy okno linii poleceń ma zostać zamknięte po zakończeniu programu,
' • fScreenUpdate - czy w trakcie działania Shell'a ekran ma być odświeżany,
Private Sub zbShellSynchroDOS( _
sCmdLine As String, _
lAppWinStyle As Long, _
fClose As Boolean, _
fScreenUpdate As Boolean)
Dim lShellID As Long
Dim hProc As Long
Dim lRetWait As Long
Const MY_TIME_WAIT As Long = 100
If fClose = True Then
lShellID = Shell(Environ$("COMSPEC") & _
" /c " & sCmdLine, lAppWinStyle)
Else
lShellID = Shell(Environ$("COMSPEC") & _
" /k " & sCmdLine, lAppWinStyle)
End If
If lShellID <> 0 Then
hProc = OpenProcess(SYNCHRONIZE, True, lShellID)
If fScreenUpdate = False Then
lRetWait = WaitForSingleObject(hProc, INFINITE)
Else
Do
' sprawdzaj co MY_TIME_WAIT milisekund
lRetWait = WaitForSingleObject(hProc, MY_TIME_WAIT)
DoEvents
Loop Until lRetWait = 0
End If
CloseHandle hProc
End If
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim ff As Integer
Dim sBat As String
Dim sTmpFile As String
Const MY_CMD_LINE As String = _
"CHOICE /n/c:t/t:t,5 Klawisz T przerywa proces, " & _
"po 5 sek program MS-DOS zostanie zakonczony:"
' przygotuj plik wsadowy
sTmpFile = Environ$("TEMP") & "\~tmp.bat"
If Dir(sTmpFile) <> "" Then Kill sTmpFile
sBat = "@ECHO OFF" & vbNewLine & _
"ECHO." & vbNewLine & _
"ECHO +" & String(70, "=") & "+" & vbNewLine & _
"ECHO +" & Space(20) & _
"Uruchomiono program wsadowy:" & _
Space(22) & "+" & vbNewLine & _
"ECHO +" & String(70, "=") & "+" & vbNewLine & _
"ECHO." & vbNewLine & MY_CMD_LINE & vbNewLine & _
"ECHO." & vbNewLine & _
"ECHO +" & String(70, "=") & "+" & vbNewLine & _
"ECHO +" & Space(22) & _
"KONIEC PROGRAMU WSADOWEGO" & _
Space(23) & "+" & vbNewLine & _
"ECHO +" & String(70, "_") & "+" & vbNewLine & _
"ECHO +" & Space(22) & _
"PO ZAMKNIECIU OKNA MS-DOS" & _
Space(23) & "+" & vbNewLine & _
"ECHO +" & Space(7) & _
"TEN SAM PROGRAM ZOSTANIE URUCHOMIONY" & _
" W SPOSOB NIEWIDOCZNY" & _
Space(6) & "+" & vbNewLine & _
"ECHO +" & String(70, "=") & "+"
' zapisz przykładowy plik *.bat
ff = FreeFile
Open sTmpFile For Binary Access Write As #ff
Put #ff, , sBat
Close #ff
' 1. uruchom plik wsadowy w oknie DOS w sposób widoczny, z odświeżaniem i zamknij po zakończeniu
zbShellSynchroDOS sTmpFile, vbNormalFocus, False, True
If Dir(sTmpFile) <> "" Then Kill sTmpFile
DoEvents
' 2. wykonaj komendę MY_CMD_LINE z linii poleceń z odświeżaniem, w sposób niewidoczny
DoCmd.Hourglass True
zbShellSynchroDOS MY_CMD_LINE, vbHide, True, True
DoEvents
DoCmd.Hourglass False
MsgBox "Zakończono działanie programu wsadowego: " & _
vbNewLine & MY_CMD_LINE
' 3. wykonaj polecenie DIR w sposób widoczny, bez odświeżania
zbShellSynchroDOS "DIR C:\ /b/-s/On/A-d", _
vbNormalFocus, False, False
DoEvents
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.4 Jak odczytać tekst z okna poleceń MS-DOS (konsoli) ?
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Declare Function CreatePipe Lib "kernel32" _
(phReadPipe As Long, _
phWritePipe As Long, _
lpPipeAttributes As SECURITY_ATTRIBUTES, _
ByVal nSize As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" _
(ByVal hNamedPipe As Long, _
lpBuffer As Any, _
ByVal nBufferSize As Long, _
lpBytesRead As Long, _
lpTotalBytesAvail As Long, _
lpBytesLeftThisMessage As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
ByRef lpExitCode As Long) As Long
Private Const STILL_ACTIVE = &H103
Private Declare Function CreateProcess Lib "kernel32" _
Alias "CreateProcessA" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As SECURITY_ATTRIBUTES, _
lpThreadAttributes As SECURITY_ATTRIBUTES, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const STARTF_USESTDHANDLES = &H100
Private Const STARTF_USESHOWWINDOW = &H1
Private Const SW_HIDE = &H0
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Function zbReadConsole(sCmdLine As String) As String
Dim pi As PROCESS_INFORMATION
Dim si As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES
Dim hWrite As Long
Dim hRead As Long
Dim lExitProc As Long
Dim lTotalBytes As Long
Dim sTextOut As String
Dim sTemp As String
Dim lRet As Long
lExitProc = -1
sa.nLength = Len(sa)
sa.bInheritHandle = True
sa.lpSecurityDescriptor = 0&
lRet = CreatePipe(hRead, hWrite, sa, 0&)
If lRet = 0 Then
MsgBox zbLastDllErrorDescr( _
Err.LastDllError, "CreatePipe (...)")
Exit Function
End If
si.cb = Len(si)
si.dwFlags = STARTF_USESHOWWINDOW Or _
STARTF_USESTDHANDLES
si.hStdOutput = hWrite
si.wShowWindow = SW_HIDE
si.hStdError = hWrite
lRet = CreateProcess(vbNullString, sCmdLine, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, si, pi)
If lRet <> 1 Then
MsgBox zbLastDllErrorDescr( _
Err.LastDllError, "CreateProcess (...)")
Exit Function
End If
Do
GetExitCodeProcess pi.hProcess, lExitProc
DoEvents
lRet = PeekNamedPipe(hRead, 0&, 0&, 0&, lTotalBytes, 0&)
If (lRet <> 0) And (lTotalBytes <> 0) Then
sTemp = String$(lTotalBytes, vbNullChar)
ReadFile hRead, sTemp, lTotalBytes, lTotalBytes, 0&
sTextOut = sTextOut & Left$(sTemp, lTotalBytes)
End If
Loop Until (lTotalBytes = 0) And (lExitProc <> STILL_ACTIVE)
CloseHandle pi.hProcess
CloseHandle pi.hThread
CloseHandle hRead
CloseHandle hWrite
zbReadConsole = sTextOut
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sRet As String
Dim sPath As String
Dim sCmdLine As String
Dim lRet As Long
' pobierz ścieżkę bieżącej bazy
sPath = CurrentDb.Name
sPath = Left$(sPath, Len(sPath) - Len(Dir$(sPath)))
' listuj pliki w folderze bazy z uwględnieniem podfolderów
sCmdLine = Environ$("COMSPEC") & " /c dir " & sPath & " /b/s"
sRet = zbReadConsole(sCmdLine)
' konwertuj tekst z IBM-852 na Windows 1250
sRet = zbCP1ToCP2(sRet, _
MY_CP_IBM_852, _
MY_CP_WINDOWS)
Debug.Print String(100, "=")
Debug.Print " Odczyt komendy linii polecenia: "; sCmdLine
Debug.Print String(100, "=")
If Len(sRet) > 0 Then
Debug.Print sRet
Else
Debug.Print " <<= ERROR =>>"
End If
Debug.Print String(100, "=")
Debug.Print
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.5 Jak za pomocą komendy DIR wylistować wszystkie pliki na dysku ?
Nie jest to zbyt dobry pomysł by w ten sposób uzyskać listę plików. A dlaczego ?
Zobacz temat: Jak wylistować pliki w folderze głównym i podfolderach oraz ... ?
' • Metoda I - bezpośredni odczyt wyniku komendy DIR z okna poleceń
' wywołuje synchronicznie w oknie konsoli (DOS) polecenie DIR i odczytuje z konsoli tekst i konwertuje go na strone kodową Win 1250.
' Następnie tekst dzielony jest w/m znaków vbNewLine na poszczególne scieżki, które są zapisywane jako rekord w tabeli "MY_TBL_DIR2CONSOLE" w polu "MY_FLD_PATH".
' • sFolderName - folder główny, który będzie przeszukiwany,
' • sMask - maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?"
' • iAttryb - dla wartości -1 listowane są wszystkie pliki, dla innych wartości iAttryb zapisywany jest jedynie plik mający ustawione szukane atrybuty,
' • fSubFolders - flaga określająca, czy przeszukiwać podfoldery
Public Sub zbDirFromConsole(ByVal sFolderName As String, _
sMask As String, _
Optional iAttryb As Integer = -1, _
Optional fSubFolders As Boolean = False)
On Error GoTo ErrHandler
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sCmdLine As String
Dim iFileAttryb As Integer
Dim sRet As String
Dim aFiles() As String
Dim i As Long
Dim j As Long
If Right$(sFolderName, 1) <> "\" Then
sFolderName = sFolderName & "\"
End If
' wywołaj polecenie DIR w oknie poleceń
sCmdLine = Environ$("COMSPEC") & _
" /c Dir " & """" & sFolderName & _
sMask & """" & " /A /B " & _
IIf(fSubFolders, "/S", "")
' pobierz tekst z konsoli
sRet = zbReadConsole(sCmdLine)
' konwertuj tekst ze strony kodowej IBM-852 na Windows 1250
sRet = zbCP1ToCP2(sRet, _
MY_CP_IBM_852, _
MY_CP_WINDOWS)
' rozdziel tekst w/m vbNewLine na poszczególne ścieżki
If zbSplit(sRet, aFiles(), vbNewLine) = 0 Then Exit Sub
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset( _
MY_TBL_DIR2CONSOLE, , _
dbAppendOnly)
' zabezpieczenie przed ciągami zerowej długości na końcu,
' (prawdopodobnie tylko 1 element)
For i = UBound(aFiles) To LBound(aFiles) Step -1
If Len(aFiles(i)) = 0 Then
j = j + 1
Else
Exit For
End If
Next
With rst
For i = LBound(aFiles) To UBound(aFiles) - j
' Dir przy braku przełącznika /S zwraca tylko nazwy pliku
If Not fSubFolders Then
aFiles(i) = sFolderName & aFiles(i)
End If
' wyłącz obsługę błędów, zapisane zostaną
' wtedy pliki powodujące błędy
On Error Resume Next
' nie zawsze można pobrać atrybuty pliku,
' błędy odczytanej ścieżki
iFileAttryb = GetAttr(aFiles(i))
If Not ((iFileAttryb And vbDirectory) = vbDirectory) Or _
(Err.Number <> 0) Then
' listuj wszystkie pliki
If iAttryb = -1 Then
.AddNew
.Fields(MY_FLD_PATH) = aFiles(i)
.Update
Else
' listuj tylko pliki z atrybutem(-ami) - iAttryb
If (iFileAttryb And iAttryb) = iAttryb Then
.AddNew
.Fields(MY_FLD_PATH) = aFiles(i)
.Update
End If
End If
End If
Next
End With
rst.Close
Set rst = Nothing
Set dbs = Nothing
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & _
" , Procedura: zbDirFromConsole()" & _
vbNewLine & Err.Description
GoTo ExitHere
End Sub
' • Metoda II - przekierowanie strumienia DIR do pliku tymczasowego
' wywołuje synchronicznie w oknie konsoli (DOS) polecenie DIR i przekierowuje strumień do tymczasowego pliku. Plik ten po zakończeniu Shell'a jest wczytywany linia po linii, które konwertowane są na stronę kodową Win 1250
' Każda linia (pełna scieżka) zapisywana jest jako rekord w tabeli "MY_TBL_DIR2TEXT" w polu ".Fields(MY_FLD_PATH)".
' • sFolderName - folder główny który bedzie przeszukiwany,
' • sMask - maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?"
' • iAttryb - dla wartości -1 listowane są wszystkie pliki, dla innych wartości iAttryb zapisywany jest jedynie plik mający ustawione szukane atrybuty,
' • fSubFolders - flaga określająca, czy przeszukiwać podfoldery
Public Sub zbDirToFile(sFolderName As String, _
sMask As String, _
Optional iAttryb As Integer = -1, _
Optional fSubFolders As Boolean = False)
On Error GoTo ErrHandler
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim sCmdLine As String
Dim iFileAttryb As Integer
Dim sBuffer As String
Dim sTmpFile As String
Dim ff As Integer
' pobierz nazwę pliku tymczasowego
sTmpFile = Environ$("TEMP") & "\~" & _
CStr(CLng(Now() * 10000)) & ".tmp"
If Len(Dir(sTmpFile)) > 0 Then Kill sTmpFile
' wywołaj polecenie DIR i przekieruj strumień
' do pliku tymczasowego sTmpFile
sCmdLine = Environ$("COMSPEC") & " /c Dir " & """" & _
IIf(Right$(sFolderName, 1) = "\", sFolderName, _
sFolderName & "\") & _
sMask & """" & " /A /B " & _
IIf(fSubFolders, "/S", "") & " > " & sTmpFile
' uruchom synchronicznie Shell'a
Call ShellSynchro_2(sCmdLine, vbHidden)
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset( _
MY_TBL_DIR2TEXT, , _
dbAppendOnly)
ff = FreeFile
Open sTmpFile For Input As #ff
Do While Not EOF(ff)
Line Input #ff, sBuffer
' konwertuj tekst w buforze ze strony kodowej
' IBM-852 na Windows 1250
sBuffer = zbCP1ToCP2(sBuffer, _
MY_CP_IBM_852, _
MY_CP_WINDOWS)
' Dir przy braku przełącznika /S
' zwraca tylko nazwy pliku
If Not fSubFolders Then
sBuffer = sFolderName & sBuffer
End If
With rst
' wyłącz obsługę błędów, zapisane zostaną wtedy
' pliki powodujące błędy
On Error Resume Next
' nie zawsze można pobrać atrybuty pliku,
' błędy odczytanej ścieżki
iFileAttryb = GetAttr(sBuffer)
If Not ((iFileAttryb And vbDirectory) = _
vbDirectory) Or _
(Err.Number <> 0) Then
' listuj wszystkie pliki
If iAttryb = -1 Then
.AddNew
.Fields(MY_FLD_PATH) = sBuffer
.Update
Else
' listuj tylko pliki z atrybutem(-ami) - iAttryb
If (iFileAttryb And iAttryb) = iAttryb Then
.AddNew
.Fields(MY_FLD_PATH) = sBuffer
.Update
End If
End If
End If
End With
Loop
Close #ff
rst.Close
Set rst = Nothing
Set dbs = Nothing
' skasuj rekord z tymczasowym plikiem
CurrentDb.Execute "Delete " & MY_FLD_PATH & " FROM " _
& MY_TBL_DIR2TEXT & _
" WHERE " & MY_FLD_PATH & "='" & sTmpFile & "';"
ExitHere:
If Len(Dir(sTmpFile)) > 0 Then Kill sTmpFile
Exit Sub
ErrHandler:
MsgBox "Błąd nr: " & Err.Number & _
" , Procedura: zbDirToFile()" & _
vbNewLine & Err.Description
Resume ExitHere
End Sub
ΔΔΔ | | | | |
|
| |
