none
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
        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

    Thank You on advance

    John Calder

    Thursday, September 29, 2016 12:33 PM

Answers

  • 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...

    #Else

    Declare Sub...

    #EndIf

    Friday, September 30, 2016 9:16 AM
    Moderator

All replies