Excel 2016 - 隐藏模块中的编译错误

时间:2016-12-20 13:00:53

标签: excel vba excel-vba

我创建一个简单的报告excel,当用户选择文件夹时,它会合并xls文件。它完美地工作,直到我在不同的PC上测试,我得到了#34;在隐藏模块中编译错误"错误。以下是错误的屏幕截图。

enter image description here

以下是我从互联网上获得的MergeSheets模块代码。

Option Explicit
Public strPath As String
Public Type SELECTINFO
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

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As SELECTINFO) As Long
Function SelectFolder(Optional Msg) As String
Dim sInfo As SELECTINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
sInfo.pidlRoot = 0&

If IsMissing(Msg) Then
    sInfo.lpszTitle = "Select your folder."
Else
    sInfo.lpszTitle = Msg
End If

sInfo.ulFlags = &H1

x = SHBrowseForFolder(sInfo)

path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
    pos = InStr(path, Chr$(0))
    SelectFolder = Left(path, pos - 1)
Else
    SelectFolder = ""
End If
End Function

"Merging Part"
Sub MergeExcels()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

RowofCopySheet = 1 

ThisWB = ActiveWorkbook.Name

path = SelectFolder("Select a folder containing Excel files you want to merge")

Application.EnableEvents = False
Application.ScreenUpdating = False

Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
    If Not Filename = ThisWB Then
        Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
        Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
        Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
        CopyRng.Copy Dest
        Wkb.Close False
    End If

    Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Files Merged!"
End Sub

我找到了问题的根源,即32位和64位操作系统的不兼容性。我设法找到了解决方案,我需要将PtrSafe包含在我的声明部分中。在我加入" PtrSafe"如下所示,错误不再出现。

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


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

然而,当我执行代码时,我的Excel程序崩溃了。

虽然这个代码是为32位操作系统创建的,但是当我在64位版本的PC上进行开发时它正在运行。我甚至在第二台PC上尝试了相同的代码,也就是64位。然而,当我尝试第三台也是64位的PC时,错误出现了。

希望你能给出这个想法。感谢。

0 个答案:

没有答案