Tweet
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