Tweet
Code:
' UNICODE_DIRS.bas
' Show the a directory list of a folder containing files with names
' containing non-ASCII chararacters in the file name.
' Reference: http://www.powerbasic.com/support/pbforums/showthread.php?t=37530
' Shows listing of all files in $FOLDER_TO_TEST as retrieved by both the
' instrinic DIR$ function (which does not handle non-ASCII characters)
' and by the Unicode versions the WinAPI functions FindFirstFile() and FindNextFile()
' -------------------------------------------------------------------------------------
' 05-31-08
' COMPILERS: PB/CC 4.03 or PB/Win 8.03 (compiles "as is" with either)
' AUTHOR : Michael Mattias Racine WI
' COPYRIGHT: Placed in public domain by author 5/31/08
' THANKS TO: Keve Peel for suggestion to set Unicode-friendly font in display windows
' UPDATES: 06/04/08 Changed WIN32_FIND_DATA_W structure to make cAlternateFilename
' 28 instead of 14 characters in size, as discovered by others.
' --------------------------------------------------------------------------------------
#COMPILE EXE
#DIM ALL
#REGISTER NONE
#DEBUG ERROR ON
#TOOLS OFF
' ----------------------------------------------------------------
' #COMPILER statement can be handy, but since it is not
' supported until CC4 and WIN8, it has to be coded like
' this to work with earlier versions of compilers.
' Ditto #CONSOLE OFF
' Like, why bother?
' -----------------------------------------------------------------
#IF %DEF(%PB_WIN32)
#IF NOT (%PB_REVISION AND &hFF00) - &h800
#COMPILER PBWIN, PBCC
#ENDIF
#ELSE ' must be PB/CC
#IF NOT (%PB_REVISION AND &hFF00) - &h400
#COMPILER PBWIN, PBCC
' #CONSOLE OFF <<< Works but you'll regret it if you want to use the STDOUT
#ENDIF
#ENDIF
' ----------------------------------------
' PROGRAM EQUATES
$FOLDER_TO_TEST = "D:\Work" ' files "*.*" in this folder will be listed
$UNICODE_NULL = CHR$(0,0)
$NUL_W = $UNICODE_NULL
' ----------------------------------------
' For some functions we'll be using
#INCLUDE "WIN32API.INC"
' --------------------------------------
' MAKE STDOUT a Valid function on PB/WIN
' --------------------------------------
#IF %DEF(%PB_WIN32)
' For detection of existing console, I an using this #OPTION VERSION 5 function
' necessary on Win/XP
DECLARE FUNCTION GetConsoleWindow LIB "KERNEL32.DLL" ALIAS "GetConsoleWindow" () AS LONG
' If I have no console window, I know to AllocConsole before doing all the tests.
FUNCTION STDOUT (Z AS STRING) AS LONG
' returns TRUE (non-zero) on success
LOCAL hStdOut AS LONG, nCharsWritten AS LONG
LOCAL nStdHandle AS DWORD ' casting problems>
LOCAL w AS STRING
STATIC CSInitialized AS LONG, CS AS CRITICAL_SECTION
LOCAL iRET AS LONG, LE AS LONG
LOCAL hWndConsole AS LONG
' ------------------------
IF ISFALSE CSInitialized THEN
InitializeCriticalSection CS
CSInitialized = 1
' -------------------------------------------------------------------
'Just comment these lines out if running PB/Windows on Windows 9x/ME.
hWndConsole = GetConsoleWindow ()
IF ISFALSE hWndConsole THEN
ALLOCConsole
END IF
' === END OF LINES TO BE REMOVED IF RUNNING WIN/9X with PB/WINDOWS
END IF
nStdHandle = BITS???(%STD_OUTPUT_HANDLE) 'STD_OUTPUT_HANDLE defined in Win32API.INC as -11&
EntercriticalSection Cs
hStdOut = GetStdHandle (nStdHandle) ' per Win32API.INC wants DWORD param, returns DWORD
SELECT CASE AS LONG hStdOut
CASE %NULL, -1&
iRet = AllocConsole ' OK, it creates the first time
LE = GetLAstError
#IF 0
IF ISFALSE iRet THEN
MSGBOX "Could not create Console" & $CRLF & SystemErrorMessageText (LE)
ELSE
MSGBOX "Created Console"
END IF
#ENDIF
hStdOut = GetStdHandle (%STD_OUTPUT_HANDLE)
END SELECT
LeaveCriticalSection CS
w = Z & $CRLF
iRet = WriteFile(hStdOut, BYVAL STRPTR(W), LEN(W), nCharsWritten, BYVAL %NULL)
LE = GETLastError
FUNCTION = iRet ' true is good
END FUNCTION
#ENDIF
' ----------------------------------------------------
' CONSTANTS, STRUCTURES AND DECLARES REQUIRED TO USE
' UNICODE VERSION OF FINDFIRSTFILE/FINDNEXTFILE
' ----------------------------------------------------
%MAX_PATH_W = %MAX_PATH * 2
TYPE WIn32_FIND_DATA_W
dwFileAttributes AS DWORD
ftCreationTime AS FILETIME
ftLastAccessTime AS FILETIME
ftLastWriteTime AS FILETIME
nFileSizeHigh AS DWORD
nFileSizeLow AS DWORD
dwReserved0 AS DWORD
dwReserved1 AS DWORD
cFileName AS STRING * %MAX_PATH_W
' update 6/04/08
' delete:
' cAlternateFileName AS ASCIIZ * 14 ' <<<<< SEE NOTE ALSO SEE UPDATE NOTES
' add
cAlternateFileName AS STRING * 28
' === END update 6/04/08
END TYPE
' -------------------------------------------------------------------------------
' NOTE: "14" is the value for the ANSI version. I "think" this might have to be
' "28" for the unicode version. However, since we never read past the
' "cFileName" member if this structure in this program, it's moot.
' 6/04/08 Not moot at all. I was just lucky. It needs to be 28
' -------------------------------------------------------------------------------
DECLARE FUNCTION FindFirstFileW LIB "KERNEL32.DLL" ALIAS "FindFirstFileW" _
(BYVAL lpFileName AS DWORD, W32W AS WIN32_FIND_DATA_W) AS DWORD
DECLARE FUNCTION FindNextFileW LIB "KERNEL32.DLL" ALIAS "FindNextFileW" _
(BYVAL hFindFile AS DWORD, W32W AS WIN32_FIND_DATA_W) AS LONG
' ** FindClose is not ANSI/UNICODE sensitive can use the standard DECLARE in WIN32API.INC ***
' ----------------------
' PROGRAM ENTRY POINT
' ----------------------
FUNCTION PBMAIN() AS LONG
LOCAL sADirList () AS STRING , sWDirList() AS STRING
LOCAL I AS LONG
REDIM sADirList(0), sWDirList(0)
CALL GetAnsiDirList ($FOLDER_TO_TEST, sADirList ())
' OPTIONAL PROGRESS DISPLAYS (Waitkey$ only supported PB/CC)
' CALL DisplayFileList (sADirList())
' STDOUT "End of Ansi File list, any key"
' WAITKEY$
CALL GetUnicodeDirList ($FOLDER_TO_TEST, sWDirList())
' CALL DisplayFileList (sWDirList(), %TRUE)
' STDOUT "End of Unicode File list, any key"
' WAITKEY$
' FOR I = 1 TO UBOUND (swDirList,1)
' STDOUT USING$ ("A:'&' W:'&'", LSET$(sADirList(I), 30), ACODE$(sWDirList(I) & $NUL))
' NEXT
' STDOUT "End of Side-by-Size File list, any key"
' WAITKEY$
CALL DisplayArraysSideBySide (sADirList(), sWDirList())
'STDOUT "End of Demo, Any Key"
'WAITKEY$
END FUNCTION
' DIR$ does not return the "." and ".." entries; Findfirst/next file does.
FUNCTION GetAnsiDirList (Folder AS STRING, sA () AS STRING) AS LONG
LOCAL sF AS STRING, mask AS STRING
LOCAL nFile AS LONG
mask = Folder & "\*.*"
' --------------------------------------
' Do a count loop just to see how big
' we need to make our sa() array
' --------------------------------------
sf = DIR$(Mask, %SUBDIR)
WHILE LEN (sf)
INCR nFile
sf = DIR$
WEND
DIR$ CLOSE
' --------------------------
' resize array and fill it
' using the DIR$ function
' --------------------------
REDIM SA(nFile)
nFile = 0
sf = DIR$(Mask, %SUBDIR)
WHILE LEN (sf)
INCR nFile
sA(nFile) = sf
sf = DIR$
WEND
END FUNCTION
' -----------------------------------------------------
' Get Directory list as an array of Unicode strings
' using FindFirstFileW and FindNextFileW
' You will note I had to play with the NULL characters
' to get this to work correctly
' -----------------------------------------------------
FUNCTION GetUnicodeDirList (Folder AS STRING, sW () AS STRING) AS LONG
LOCAL W32W AS WIN32_FIND_DATA_W, hSearch AS LONG
LOCAL mask AS STRING, wMask AS STRING
LOCAL nFile AS LONG, bFound AS LONG
LOCAL nDot AS LONG
LOCAL wFile AS STRING
mask = folder & "\*.*" & $NUL ' add explicit null so it gets to uncode with double-null
wMask = UCODE$(Mask) ' convert to unicode
hSearch = FindFirstFileW (BYVAL STRPTR (wMask), W32W)
IF hSearch <> %INVALID_HANDLE_VALUE THEN
bFound = %TRUE
END IF
' ----------------
' count files
' ----------------
WHILE ISTRUE bFound
INCR nFile
bFound = FindNextFileW (hSearch, W32W)
WEND
FindClose hSearch
' ------------------------------------
' resize array and fill it with
' unicode file names returned
' by FindFirstFileW and FindNextFileW
' ------------------------------------
REDIM SW (nFile)
nDot = 0&
hSearch = FindFirstFileW (BYVAL STRPTR (wMask), W32W)
IF hSearch <> %INVALID_HANDLE_VALUE THEN
bFound = %TRUE
END IF
nFile = 0 ' reset
WHILE ISTRUE bFound
' get entire returned filename
wFile = W32W.cFileName
'get the portion of the filename up to the unicode terminator
wFile = EXTRACT$ (wFile, $UNICODE_NULL)
WFile = wFile & $NUL ' needs this extra null here.
' optional debug displays
'STDOUT USING$ ("Filename found LEN # ==> '&'", LEN(wFile), ACODE$(wFile))
'WAITKEY$
' Look for the "." entries whilst still in Unicode...
IF LEN(Wfile) > 1 THEN ' I was getting a null entry
IF ACODE$(LEFT$(WFile, 2) & $NUL) <> "." THEN
INCR nFile
sw (nFile) = wFile
ELSE
INCR nDot
END IF
ELSE
STDOUT "Got NUll Back getting Unicode file (should not happen)"
#IF %DEF (%PB_CC32)
WAITKEY$
#ELSE
SLEEP 2000
#ENDIF
END IF
bFound = FindNextFileW (hSearch, W32w)
WEND
FindClose hSearch
IF nDot THEN
REDIM PRESERVE sW (UBOUND (sw,1) - nDot)
END IF
END FUNCTION
FUNCTION DisplayFileList (sF() AS STRING, OPTIONAL BYVAL IsUnicode AS LONG) AS LONG
LOCAL i AS LONG
FOR I = 1 TO UBOUND (Sf,1)
IF ISTRUE IsUnicode THEN
STDOUT ACODE$(sf(i))
ELSE
STDOUT sf(i)
END IF
NEXT
END FUNCTION
' ----------------------------------------------------
' DECLARE the UNICODE versions of the window creation
' and management functions we use in this program
' ----------------------------------------------------
DECLARE FUNCTION CreateWindowExW LIB "USER32.DLL" ALIAS "CreateWindowExW" _
(BYVAL dwExStyle AS DWORD, BYVAL lpClassName AS DWORD, BYVAL lpWindowName AS DWORD, BYVAL dwStyle AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG, _
BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _
BYVAL hWndParent AS DWORD, BYVAL hMenu AS DWORD, BYVAL hInstance AS DWORD, lpParam AS ANY) AS DWORD
DECLARE FUNCTION SetWindowTextW LIB "USER32.DLL" ALIAS "SetWindowTextW" (BYVAL hWnd AS DWORD, BYVAL lpString AS DWORD) AS LONG
DECLARE FUNCTION SendMessageW LIB "USER32.DLL" ALIAS "SendMessageW" _
(BYVAL hWnd AS DWORD, BYVAL dwMsg AS DWORD, BYVAL wParam AS DWORD, _
BYVAL lParam AS LONG) AS LONG
' -----------------------------------------------------------------------------
' Create Windows to show the Directory lists.
' The Ansi window shows the names of the files as retrieved by DIR$ function
' The Unicode window shows the names of the files as retrieved by the
' Unicode versions of FindFirstFile and FindNextFile WinAPI functions
' ----------------------------------------------------------------------------
FUNCTION DisplayArraysSideBySide (sA() AS STRING, sw() AS STRING) AS LONG
LOCAL hWnd() AS LONG
LOCAL dwStyle AS DWORD, sWClass AS STRING, sWTitle AS STRING
LOCAL hParent AS LONG
LOCAL i AS LONG
LOCAL X AS LONG, Y AS LONG, cx AS LONG, Cy AS LONG
LOCAL sWindowText AS STRING
LOCAL hInst AS LONG
LOCAL hFont AS LONG
' ---------------------------------
' Stuff the same for both windows
' ---------------------------------
hInst = GetModuleHandle (BYVAL %NULL)
sWClass = "edit" & $NUL
swClass = UCODE$(swClass) ' we create BOTH windows as Unicode windows.
dwstyle = %WS_OVERLAPPEDWINDOW OR %ES_MULTILINE OR %WS_BORDER _
OR %WS_VISIBLE OR %WS_THICKFRAME OR %WS_SYSMENU
dwStyle = DWSTYLE OR %ES_WANTRETURN OR %ES_READONLY OR %WS_VSCROLL OR %WS_HSCROLL
hParent = %NULL
x = %CW_USEDEFAULT
y = %CW_USEDEFAULT
cx = %cW_USEDEFAULT
cy = %CW_USEDEFAULT
REDIM hWnd(1)
FOR I = 0 TO 1
sWindowText = ""
IF I = 0 THEN
swTitle = "ANSI Directory List" & $NUL
sa(0) = "ANSI LIST FROM DIR$" ' element zero not used when making list
sWindowText = JOIN$(sA(), $CRLF) & $NUL
sWindowText = UCODE$(sWindowText)
ELSE
swTitle = "Unicode Directory List" & $NUL
sW(0) = UCODE$ ("Unicode List from FindFirstFileW/FindNextFileW")
sWindowText = JOIN$(sW(), UCODE$($CRLF)) & $UNICODE_NULL
END IF
swTitle = UCODE$(sWTitle)
hWnd (i) = CreateWindowExW ( %NULL, STRPTR(swClass), STRPTR(swTitle), _
dwStyle, X, Y, Cx, Cy, hParent, %NULL, hInst, BYVAL %NULL)
' we need a Unicode font, create it the first time
IF I = 0 THEN
CALL CreateUnicodeFont (hWnd(i)) TO hFont
END IF
' set the font to be used in our window...
SendMessageW hWnd(i), %WM_SETFONT, hFont, %NULL
' set the text of the edit control
SetWindowTextW hWnd(I), BYVAL STRPTR(sWindowText)
' show the window
ShowWindow hWnd(i), %SW_SHOWNORMAL
NEXT
' -------------------------------------------
' Set up a message loop so windows will
' respond to move, scroll and Exit commands
' ------------------------------------------
LOCAL msg AS TagMsg
LOCAL iMsg AS LONG
DO
iMsg = GetMessage ( msg, %NULL, 0,0)
IF ISTRUE iMSg THEN
TranslateMessage msg
DispatchMessage msg
END IF
LOOP UNTIL ISFALSE ISwindow(hWnd(0)) AND ISFALSE IsWindow (hWnd(1))
' clean up
DeleteObject hFont
END FUNCTION
' -----------------------------------------------------------
' Create a UNICODE-friendly font to use in the display windows
' Returns: handle to a font; if NULL, function failed
' ------------------------------------------------------------
FUNCTION CreateUNicodeFont(BYVAL hWnd AS LONG) AS LONG
LOCAL nHeight AS LONG, nWidth AS LONG, nEscapement AS LONG, nOrientation AS LONG, _
fdwCharset AS LONG, _
fnWeight AS LONG, fdwItalic AS LONG, fdwUNderLine AS LONG, fdwStrikeOut AS LONG, _
fdwOutputPrecision AS LONG, _
fdwClipPrecision AS LONG, _
fdwQuality AS LONG, _
fdwPitchAndFamily AS LONG,_
lpszFace AS ASCIIZ * 48
LOCAL PointSizeHeight AS LONG, HDc AS LONG, hFont AS LONG
PointSizeHeight = 10
hDC = GetDc(hwnd)
nHeight = -MulDiv(PointSizeHeight, GetDeviceCaps(hDC, %LOGPIXELSY), 72)
nWidth = nHeight * .5 ' value is a guess. Looks OK.
nEscapement = 0
nOrientation = 0
fnWeight = %FW_NORMAL
fdwItalic = %FALSE
fdwUnderline = %FALSE
fdwStrikeout = %FALSE
fdwCharset = %ANSI_CHARSET ' %OEM_CHARSET works with either the same way,
fdwOutputPrecision = %OUT_DEFAULT_PRECIS
fdwClipPrecision = %CLIP_DEFAULT_PRECIS
fdwQuality = %DEFAULT_QUALITY
lpszFace = "Arial"
hFont = CreateFont(nHeight,_
nWidth, _
nEscapement,_
nOrientation,_
fnWeight,_
fdwItalic,_
fdwUnderline,_
fdwStrikeOut,_
fdwCharSet,_
fdwOutputPrecision,_
fdwClipPrecision,_
fdwQuality,_
fdwPitchAndFamily,_
lpszFace)
IF ISTRUE hDc THEN
ReleaseDc hWnd, hDc
END IF
FUNCTION = hFont
END FUNCTION
' ** END OF FILE UNICODE_DIRS.BAS ***
Comment