Office 2010 Compatabily Problem RRS feed

  • Question

  • Hi

    I have a spreadsheet with macros that I created in Excel 2007 64bit. When I upgraded to Excel 2010 my macros would not run and I received a message saying I had to include PtrSafe in the macro. I managed to get that done although I am not a visual basic user. The macros then worked. The problem I have is now when I send it to someone who has an earlier version of Excel the macros will not run for them.

    Is there some code that I can copy and paste into my macro so that they run in both Excel 2010 and also in earlier versions of Excel.

    Below is the code I am using in 2010.

    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
    Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

    Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
        Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

    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
         ' listfiles2 is modified using arrays to run faster in EXCEL97
        ' Call ListFiles2
        End If
        With Application
            .StatusBar = ""
            .ScreenUpdating = True
        End With
        If FileCount = 0 Then
         MsgBox "No files were returned."
         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
        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
            DirCounter = DirCounter + 1
        Exit Sub

    errorproc: dirok = False
    Resume Next
    End Sub

    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
        Exit Sub
    End Sub

    Thank You on advance

    John Calder

    Thursday, September 29, 2016 12:33 PM


  • Hi,

    Since the issue causes from the declaration of external procedures in a DLL,

    Please see Declare Statement, you could find:

    To ensure backwards compatibility with VBA version 6 and earlier use the following construct:

    #If Vba7 Then

    Declare PtrSafe Sub...


    Declare Sub...


    Friday, September 30, 2016 9:16 AM

All replies