'Folder functions for MapBasic

'MB_Resources open source library

'by Bill Thoen <bthoen@gisnet.com>

'GISnet

'1401 Walnut St., Suite C

'Boulder, Colorado 80302 USA

'http://gisnet.com

'This code is distributed under the terms of the Lesser GNU General

'Public License. You must agree to the conditions set forth in

'lgpl.txt to use any of this code with your own applications.

'Fused into one MB file, Jacques Paris 2006

'======================================================================

include "mapbasic.def"

define MAX_PATH 260

define INVALID_HANDLE_VALUE -1

Type SECURITY_ATTRIBUTES

    nLength As Integer

    lpSecurityDescriptor As Integer

    bInheritHandle As Integer

End Type

Type FILETIME

    dwLowDateTime As integer

    dwHighDateTime As integer

End Type

Type WIN32_FIND_DATA

    dwFileAttributes As integer

    ftCreationTime As FILETIME

    ftLastAccessTime As FILETIME

    ftLastWriteTime As FILETIME

    nFileSizeHigh As integer

    nFileSizeLow As integer

    dwReserved0 As integer

    dwReserved1 As integer

    cFileName As String * MAX_PATH

    cAlternate As String * 14

End Type

declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA"

    (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Integer

declare function GetLogicalDriveStrings lib "kernel32" alias "GetLogicalDriveStringsA"

    (Byval nBufferLength as integer, sBuffer() as integer)as integer

Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"

    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As integer

Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA"

    (ByVal hFindFile As integer, lpFindFileData As WIN32_FIND_DATA) As integer

Declare Function FindClose Lib "kernel32" Alias "FindClose"

    (ByVal hFindFile As Integer) As Integer

declare function GetDir (byval sPath as string, sList() as string) as logical

declare sub GetFilenames ( byval sPath as string, byval sFilespec as string, sList() as string)

declare sub listdrives(s_drive() as string)

declare sub StringToArray (byval sStr as string, sList() as string, byval sToken as string)

declare sub movedown

declare sub moveup

declare sub main

dim a_dir(), s_add as string

'======================================================================

function GetDir (

    byval sPath as string, 'Full drive\directory path

    sList() as string) 'Array to receive list of directory names

       as logical

'Returns a list of file names in folder sPath that represent folders themselves.

'----------------------------------------------------------------------

dim hFindFile, nStatus as integer

dim f as WIN32_FIND_DATA

dim i, j as integer

dim sDirPath as string

getdir=1

redim sList(0)

sDirPath = sPath

if right$ (sDirPath, 1) <> "\" then

sDirPath = sDirPath + "\"

end if

hFindFile = FindFirstFile (sDirPath+"*.*", f)

if hFindFile = INVALID_HANDLE_VALUE then

nStatus = FindClose (hFindFile)

note "Path not found."

getdir=0

exit sub

end if

do

if (f.dwFileAttributes \ 16) mod 2 = 1 then

if f.cFilename <> "." and f.cFilename <> ".." then

j = j + 1

redim sList(j)

sList(j) = f.cFilename

end if

end if

nStatus = FindNextFile (hFindFile, f)

loop while nStatus = 1

nStatus = FindClose (hFindFile)

end function

'======================================================================

sub GetFileNames (

byval sPath as string, 'Full directory path

byval sFilespec as string, 'A file specification (e.g. *.TAB)

sList() as string) 'Array to receive list of file names

'----------------------------------------------------------------------

dim hFindFile, nStatus as integer

dim f as WIN32_FIND_DATA

dim i as integer

hFindFile = FindFirstFile (sPath + sFilespec, f)

if hFindFile <> INVALID_HANDLE_VALUE then

 do

  if (f.dwFileAttributes \ 16) mod 2 = 0 then

    i = i + 1

    redim sList(i)

    sList(i) = f.cFilename

  end if

  nStatus = FindNextFile (hFindFile, f)

 loop while nStatus = 1

end if

nStatus = FindClose (hFindFile)

end sub

'======================================================================

sub listdrives(s_drive() as string)

'======================================================================

'Calls Windows API GetLogicalDriveStrings() to return the system drive

'strings in an array (e.g. a:\, b:\, etc.). However the API function returns

'this as a single string with null byte delimiters, and MapInfo can't

'handle strings with null bytes in them. Instead we pass an array of

'integers and parse the bytes into a MapInfo semi-colon delimited

'string. The WinAPI declaration must be modifed as well, but this

'works because strings and integer arrays are mapped into the same

'memory space on the stack.

'

'Note that strings are one byte per character, while integers contain

'4 bytes each.

'----------------------------------------------------------------------

dim nCount, nStatus as integer

dim sBuffer as string

dim sChar() as integer

dim i, n as integer

nCount = 128

redim sChar(nCount)

nCount = GetLogicalDriveStrings (nCount*4, sChar)

sBuffer = ""

for i = 1 to nCount\4

'Convert 4 bytes of integer into 4 bytes of string.

'Note that byte order for integers is reversed from byte-order of strings.

n = (sChar(i) \ 256^0) mod 256

if n = 0 then n = asc(";") end if

sBuffer = sBuffer + chr$(n)

n = (sChar(i) \ 256^1) mod 256

if n = 0 then n = asc(";") end if

sBuffer = sBuffer + chr$(n)

n = (sChar(i) \ 256^2) mod 256

if n = 0 then n = asc(";") end if

sBuffer = sBuffer + chr$(n)

n = (sChar(i) \ 256^3) mod 256

if n = 0 then n = asc(";") end if

sBuffer = sBuffer + chr$(n)

next

call stringtoarray(sBuffer,s_drive(),";")

end sub 

'======================================================================

sub StringToArray (byval sStr as string, sList() as string, byval sToken as string)

'======================================================================

dim i, j, p0, p1 as smallint

j = len(sToken)

p0 = 1

p1 = instr(p0, sStr, sToken)

do while p1 > 0

i = i + 1

redim sList(i)

sList(i) = mid$(sStr, p0, p1-p0)

p0 = p1 + j

p1 = instr (p0, sStr, sToken)

loop

'get the last element

if p0 < len(sStr) then

i = i + 1

redim sList(i)

sList(i) = mid$(sStr, p0, Len(sStr)-p0+1)

end if

end sub

'======================================================================

sub moveup

'======================================================================

end sub

'======================================================================

sub movedown

'======================================================================

dim i_ret as integer

dim i_d as smallint

i_d=readcontrolvalue(6543)

if right$(s_add,1)<>"\" then s_add=s_add+"\" end if

s_add=s_add+a_dir(i_d)

note s_add

i_ret= getdir(s_add,a_dir)

if ubound(a_dir)=0 then

    alter control 6544 disable

    exit sub

end if

alter control 6543 title from variable a_dir

alter control 6542 title "Add into "+s_add

end sub

'======================================================================

sub main

'======================================================================

Dim Security As SECURITY_ATTRIBUTES

dim a_dri(), a, nu_dir as string

dim i_dir, i_dri as smallint

dim i_ret as logical

s_add=""

call listdrives(a_dri())

boucle1:

dialog title "Add Directory Into"

control groupbox title "Select Drive" position 5,5 width 145 height 40

control popupmenu title from variable a_dri into i_dri position 20,20

control okbutton

control cancelbutton

if not commandinfo(1) then exit sub end if

s_add=a_dri(i_dri)

i_ret= getdir(s_add,a_dir)

if not i_ret then goto boucle1 end if

a="Add into "+s_add

dialog title "Add Directory Into"

  control statictext title a position 5,5 width 140 height 30 ID 6542

  control button title "Move down" calling movedown ID 6544 position 5,40

  control button title "Move up" calling moveup ID 6545 disable position 100,40

  control groupbox title "Select Directory" position 5,55 width 145 height 40

  control popupmenu title from variable a_dir into i_dir position 20,70 ID 6543

  control okbutton title "Create"

  control cancelbutton

if not commandinfo(1) then exit sub end if

nu_dir=""

boucle2:

dialog title "Add Directory Into"

  control groupbox title "New Directory Name" position 5,5 width 145 height 40

  control edittext width 120 position 20,20 value nu_dir into nu_dir

  control okbutton

  control cancelbutton

if not commandinfo(1) then exit sub end if

if right$(s_add,1)<>"\" then s_add=s_add+"\" end if

s_add=s_add+nu_dir

i_ret=createdirectory(s_add, security)

if i_ret > 0 then

    note "New directory created as "+chr$(10)+chr$(10)+s_add

exit sub

end if

note "Unacceptable file name. Correct it please"

goto boucle2

end sub