I have been trying to port the VB6 class at http://vb.mvps.org/samples/project.asp?id=DirDrill to PB9. The places where it will not compile are now lines 186 and 188. I will have trouble at line 191, too. (Those are my line numbers, not the original.) Also note that I commented out two FUNCTIONs using #IF 0 / #ENDIF.
How should I fix the 3 lines in question? Feel free to make other changes.
How should I fix the 3 lines in question? Feel free to make other changes.
Code:
#COMPILE DLL #DIM ALL %USEMACROS = 1 #INCLUDE "Win32API.inc" GLOBAL ghInstance AS DWORD CLASS CDirDrill INSTANCE m_Cancel AS LONG INSTANCE m_Pattern AS STRING INSTANCE m_Recurse AS LONG INSTANCE m_Folder AS STRING INSTANCE m_TotalFiles AS LONG INSTANCE m_TotalDirs AS LONG INSTANCE m_AttrMask AS LONG INTERFACE DirDrill AS EVENT INHERIT IUNKNOWN PROPERTY GET AttributeMask() AS LONG PROPERTY = m_AttrMask END PROPERTY PROPERTY SET AttributeMask(BYVAL NewMask AS LONG) ' Needed in order to find hidden/system files, or ' simply to narrow the search to specific attribs. m_AttrMask = NewMask END PROPERTY PROPERTY GET Folder() AS STRING PROPERTY = m_Folder END PROPERTY PROPERTY SET Folder(BYVAL NewValue AS STRING) IF ISFILE(NewValue) THEN m_Folder = NewValue END IF END PROPERTY PROPERTY GET Pattern() AS STRING PROPERTY = m_Pattern END PROPERTY PROPERTY SET Pattern(BYVAL NewValue AS STRING) ' Accept delimited list of filespecs, replacing all ' commas with semi-colons, and eliminating spaces. REPLACE "," WITH ";" IN NewValue m_Pattern = REMOVE$(NewValue,$SPC) END PROPERTY PROPERTY GET Recursive() AS LONG PROPERTY = m_Recurse END PROPERTY PROPERTY SET Recursive(BYVAL NewRecursive AS LONG) ' Flag indicates whether to recurse entire dirtree. m_Recurse = NewRecursive END PROPERTY METHOD BeginSearch(OPTIONAL BYVAL StartFolder AS STRING) ' Assign new path, if asked to. IF LEN(StartFolder) THEN Me.Folder = StartFolder END IF ' Reset counters, and start recursion. m_Cancel = %FALSE m_TotalFiles = 0 m_TotalDirs = 1 'always have a starting folder! CALL RecurseFolders(m_Folder) RAISEEVENT Done(m_TotalFiles, m_TotalDirs) ' Clear any outstanding locks held by Dir$() CALL DIR$("nul") END METHOD METHOD FileText(BYVAL filespec AS STRING) AS STRING DIM hFile AS LONG ON ERROR RESUME NEXT ' Return entire file contents as string, ignoring errors. hFile = FREEFILE OPEN filespec FOR INPUT AS #hFile METHOD = INPUT(LOF(hFile), #hFile) CLOSE #hFile END METHOD METHOD ExtractName(BYVAL SpecIn AS STRING, OPTIONAL BaseOnly AS LONG) AS STRING DIM nPos AS LONG DIM SpecOut AS STRING IF ISMISSING(BaseOnly) THEN BaseOnly=%FALSE ' Make sure we don't have a directory. IF NOT ISFILE(SpecIn) THEN ' Find last backslash, and keep what follows. nPos = INSTR(-1,SpecIn, "\") IF nPos < LEN(SpecIn) THEN SpecOut = MID$(SpecIn, nPos + 1) ELSE SpecOut = SpecIn END IF ' If user requested, remove the extension. ' Useful for appending a different extension. IF BaseOnly THEN nPos = INSTR(-1,SpecOut, ".") IF nPos < LEN(SpecOut) THEN SpecOut = LEFT$(SpecOut, nPos - 1) END IF END IF END IF ' Return SpecOut METHOD = SpecOut END METHOD METHOD ExtractPath(BYVAL SpecIn AS STRING) AS STRING DIM nPos AS LONG DIM SpecOut AS STRING ' Make sure we don't already have a directory. IF ISFILE(SpecIn) THEN SpecOut = Backslashed(SpecIn) ELSE ' Find last backslash, and keep what follows. nPos = INSTR(-1,SpecIn, "\") IF nPos THEN SpecOut = LEFT$(SpecIn, nPos) END IF END IF ' Return SpecOut METHOD = SpecOut END METHOD END INTERFACE END CLASS FUNCTION Backslashed(BYVAL SpecIn AS STRING) AS STRING ' Make sure path ends with backslash. IF ISFILE(SpecIn) THEN IF RIGHT(SpecIn, 1) <> "\" THEN SpecIn = SpecIn & "\" END IF END IF Backslashed = SpecIn END FUNCTION #IF 0 FUNCTION GETATTR(BYVAL PathName AS STRING) AS LONG 'Const INVALID_FILE_ATTRIBUTES As Long = -1& ' Use API to retrieve file attributes, because VBA.GetAttr ' chokes on files that have attributes not used by the time ' VB5/6 were released. :-( GETATTR = GetFileAttributes(PathName) END FUNCTION #ENDIF #IF 0 FUNCTION IsDirectory(BYVAL PathName AS STRING) AS Boolean DIM Attr AS LONG ' Make sure we have a valid attribute to check. Attr = GETATTR(PathName) IF Attr <> INVALID_FILE_ATTRIBUTES THEN ' Check for presence of Directory attribute. IF (Attr AND vbDirectory) = vbDirectory THEN IsDirectory = True END IF END IF END FUNCTION #ENDIF %nIncrement = 100 SUB RecurseFolders(BYVAL StartPath AS STRING) DIM Dirs() AS STRING, Files() AS STRING 'Dim Patterns() As String '<= Use this with VB6 Split DIM Patterns AS VARIANT DIM nDirs AS LONG, nFiles AS LONG DIM FileName AS STRING DIM This AS STRING DIM i AS LONG ' Make sure there's a trailing backslash. StartPath = Backslashed(StartPath) ' Alert user that a new folder is being processed. RAISEEVENT NewFolder(StartPath, m_Cancel) IF ISFALSE m_Cancel THEN ' Build array of all directories under "here." REDIM Dirs(0 TO nIncrement - 1) AS STRING FileName = Dir(StartPath & "*.*", vbDirectory) DO WHILE LEN(FileName) This = StartPath & FileName IF IsDirectory(This) THEN ' Ignore dotted directory names IF LEFT$(FileName, 1) <> "." THEN IF nDirs > UBOUND(Dirs) THEN REDIM PRESERVE Dirs(0 TO UBOUND(Dirs) + nIncrement) AS STRING END IF Dirs(nDirs) = This nDirs = nDirs + 1 END IF END IF ' Continue... FileName = Dir() LOOP ' Build array of wildcard filespec patterns. Patterns = Split(m_Pattern, ";") ' Begin scanning for all files that match each spec. REDIM Files(0 TO nIncrement - 1) AS STRING FOR i = LBOUND(Patterns) TO UBOUND(Patterns) FileName = Dir(StartPath & Patterns(i), m_AttrMask) DO WHILE LEN(FileName) This = StartPath & FileName IF IsDirectory(This) = False THEN 'If (GetAttr(This) And m_AttrMask) Then IF nFiles > UBOUND(Files) THEN REDIM PRESERVE Files(0 TO UBOUND(Files) + nIncrement) AS STRING END IF Files(nFiles) = This nFiles = nFiles + 1 'End If END IF ' Continue... FileName = Dir() LOOP NEXT i END IF ' Increment counters m_TotalFiles = m_TotalFiles + nFiles m_TotalDirs = m_TotalDirs + nDirs ' Process each file in this directory. FOR i = 0 TO nFiles - 1 RAISEEVENT NewFile(Files(i), m_Cancel) IF m_Cancel THEN EXIT FOR NEXT i ' Process each directory found. IF (m_Recurse = True) THEN FOR i = 0 TO nDirs - 1 RecurseFolders Dirs(i) ' Bail if user cancelled in last procedure. IF m_Cancel THEN EXIT FOR NEXT i END IF END SUB '------------------------------------------------------------------------------- ' Main DLL entry point called by Windows... ' FUNCTION LIBMAIN (BYVAL hInstance AS LONG, _ BYVAL fwdReason AS LONG, _ BYVAL lpvReserved AS LONG) AS LONG SELECT CASE fwdReason CASE %DLL_PROCESS_ATTACH 'Indicates that the DLL is being loaded by another process (a DLL 'or EXE is loading the DLL). DLLs can use this opportunity to 'initialize any instance or global data, such as arrays. ghInstance = hInstance FUNCTION = 1 'success! 'FUNCTION = 0 'failure! This will prevent the EXE from running. CASE %DLL_PROCESS_DETACH 'Indicates that the DLL is being unloaded or detached from the 'calling application. DLLs can take this opportunity to clean 'up all resources for all threads attached and known to the DLL. FUNCTION = 1 'success! 'FUNCTION = 0 'failure! CASE %DLL_THREAD_ATTACH 'Indicates that the DLL is being loaded by a new thread in the 'calling application. DLLs can use this opportunity to 'initialize any thread local storage (TLS). FUNCTION = 1 'success! 'FUNCTION = 0 'failure! CASE %DLL_THREAD_DETACH 'Indicates that the thread is exiting cleanly. If the DLL has 'allocated any thread local storage, it should be released. FUNCTION = 1 'success! 'FUNCTION = 0 'failure! END SELECT END FUNCTION
Comment