Tekst informacyjny o polityce Cookies Close   
    
 
         
• Strona główna
• 1. Linki
• 3. Kontakt: e-Mail
 
         
• 1. Baza danych
• 2. Tabele i kwerendy
• 3. Formularze
• 4. Raporty
• 5. Moduły i makra
• 6. Obsługa błędów
 
    

II.   VBA 

    
• 1. Okna Accessa
• 2. Okna Formularzy
• 3.Okna Dialogowe
• 4. Tekst
• 5. Liczby
• 6. Pliki
• 7. Inne
 
    

III.   API 

    
• 1. Ogólnie o API
• 2. Funkcje API
• 3. System
• 4. Praca z oknami
• 5. Okna dialogowe
• 6. API - Inne
 
         
• 1. Bitmapy 24 Bit
• 2. GDI i HDC
• 3. Kody kreskowe
• 4. Formant Image
• 5. FreeImage.dll
 
    

V.   Inne 

    
• 1. Shell i MsDOS
• 2. Kontrolki
• 3. ६ԼҚ ਸ
• 4. Unikod

 
Odwiedzin:

Logo AccessFAQ• 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

 ΔΔΔ