32Bit VB code needs converting to 64Bit code

Hi

I have a 32 bit spreadsheet created in an older version of excel that will not run under Office 2010 64bit.

I have tried including PtrSafe in the macro but it has not made any difference. Is there someone out there that can edit my code so that it will run under 64bit?

My Code:-

Option Explicit

Public Type BROWSEINFO

    hOwner As Long

    pidlRoot As Long

    pszDisplayName As String

    lpszTitle As String

    ulFlags As Long

    lpfn As Long

    lParam As Long

    iImage As Long

End Type

Public SelectedDir As String

Public StartPoint As String

Dim DirCounter As Integer

Dim currdir

Dim dirtopaste, dirok

Public SumDiskSpace As Double

Public FileCount As Integer

'32-bit API declarations

#If VBA7 Then

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr

#Else

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

#End If

Sub DisplayDirectoryDialogBox()

    Dim Msg As String

    FileCount = 0

    Msg = "Select a location containing the files you want to list."

    SelectedDir = GetDirectory(Msg)

    If SelectedDir = "" Then End

    With Application

        .StatusBar = "WAIT..."

        .ScreenUpdating = False

    End With

    SumDiskSpace = 0

    ' listfiles is the original code

  '  MsgBox Application.Caller

    If Application.Caller = "Files1" Then

     Call listfiles

    Else

     ' listfiles2 is modified using arrays to run faster in EXCEL97

    ' Call ListFiles2

     UserForm2.Show

    End If

    With Application

        .StatusBar = ""

        .ScreenUpdating = True

    End With

    If FileCount = 0 Then

     MsgBox "No files were returned."

    Else

     MsgBox "The list is complete.  " & Chr(13) & Chr(10) & _

           "Found " & FileCount & " files" & Chr(13) & Chr(10) & _

           "Occupying " & Int(SumDiskSpace / 100000) / 10 & " MB"

    End If

End Sub

Function GetDirectory(Optional Msg) As String

    Dim bInfo As BROWSEINFO

    Dim path As String

    Dim r As Long, x As Long, pos As Integer

'   Root folder = Desktop

    bInfo.pidlRoot = 0&

'   Title in the dialog

    If IsMissing(Msg) Then

        bInfo.lpszTitle = "Select a folder."

    Else: bInfo.lpszTitle = Msg

    End If

'   Type of directory to return

    bInfo.ulFlags = &H1

'   Display the dialog

    x = SHBrowseForFolder(bInfo)

'   Parse the result

    path = Space$(512)

    r = SHGetPathFromIDList(ByVal x, ByVal path)

    If r Then

        pos = InStr(path, Chr$(0))

        GetDirectory = Left(path, pos - 1)

    Else: GetDirectory = ""

    End If

End Function

'Enter files into worksheet

Sub listfiles()

    Dim c As Range

    ActiveSheet.UsedRange.Clear

    Set c = Range("A1")

    On Error GoTo 0

    StartPoint = SelectedDir

    If Dir(StartPoint, vbDirectory + vbHidden + vbSystem) = "" Then

        MsgBox "There are no entries in the directory " & StartPoint & "."

        Exit Sub

    End If

    On Error GoTo errorproc

    ReDim directs(2)

    If Right(StartPoint, 1) = "" Then

        directs(1) = StartPoint

    Else: directs(1) = StartPoint & ""

    End If

    directs(2) = ""

    DirCounter = 1

    Do While directs(DirCounter) <> ""

        currdir = directs(DirCounter)

        'dirtopaste = Dir(currdir, vbDirectory + vbHidden + vbSystem)

         'dirtopaste = Dir(currdir, vbDirectory)

         dirtopaste = Dir(currdir, vbHidden)

        Do While dirtopaste <> ""

            dirok = True

            If GetAttr(currdir & dirtopaste) = vbDirectory Then

            ' it's a directory so paste the text into the array

                If dirok Then

                    If InStr("..", dirtopaste) = 0 Then

                    ' ignore directories above the current position

                    ReDim Preserve directs(UBound(directs) + 1)

                    directs(UBound(directs) - 1) = currdir & dirtopaste & ""

                    End If

                End If

            Else   ' must be a file

                c.Value = currdir & dirtopaste

                If c.Row = 16384 Then

                    Set c = Cells(1, c.Column + 1)

                Else: Set c = c.Offset(1, 0)

                End If

            End If

            'dirtopaste = Dir(, vbDirectory + vbHidden + vbSystem)

            dirtopaste = Dir

        Loop

        DirCounter = DirCounter + 1

    Loop

    Exit Sub

errorproc: dirok = False

Resume Next

End Sub

'IGNORE THIS

Function CountDigits(s As String) As Integer

    Dim i

    For i = 1 To Len(s)

      If Mid(s, i, 1) Like "" Then

        CountDigits = CountDigits + 1

      End If

    Next i

  End Function

Sub Testlistfiles()

    StartPoint = "c:\aslush\freds hidden secret stuff"

    If Dir(StartPoint, vbDirectory + vbHidden + vbSystem) = "" Then

        MsgBox "There are no entries in the directory " & StartPoint & "."

        Exit Sub

    End If

    ' dirtopaste = Dir(StartPoint, vbHidden)

    ' dirtopaste = Dir(StartPoint, vbNormal)

    dirtopaste = Dir(StartPoint, vbDirectory + vbHidden + vbSystem)

     Do While dirtopaste <> ""

       MsgBox dirtopaste

            dirtopaste = Dir

     Loop

    Exit Sub

End Sub

Thanks

John

***Post moved by the moderator to the appropriate forum category.***