1

このコードを Excel で実行すると、Left(,) 関数が配列を想定していると表示されます。String関数には が必要です。String変数は として宣言されていStringます。私はそこにオペレーターを置きまし$たが、それでも私はがらくたをします。何が起こっているのでしょうか？

FWIW これは、SolidWorks で実行すると問題なく実行されます。

また、それを渡すユーザーフォームから呼び出されていStringます。

#If VBA7 Then
    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

#Else
    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 BROWSEINFO) _
    As Long
#End If
Public Type BROWSEINFO
#If VBA7 Then
    hOwner As LongPtr
    pidlRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As LongPtr
    lParam As LongPtr
    iImage As Long

#Else
    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 If
End Type

Private bInfo As BROWSEINFO
Function GetDirectory(Optional Msg As String = "Select a folder.") As String
    Dim path As String
    Dim x As Long, pos As Integer
    'dim
    bInfo.pidlRoot = 0&     '   Root folder = Desktop
    bInfo.lpszTitle = Msg   '   Dialog title
    bInfo.ulFlags = &H1     '   Type of directory to return


    x = SHBrowseForFolder(bInfo)

    path = Space$(512)
    If SHGetPathFromIDList(ByVal x, ByVal path) Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, (pos - 1))
    End If
End Function
4

1 に答える 1

0

以下のコードを試してみてください。動作します

Option Explicit

 '32-bit API declarations
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 BrowseInfo) _
As Long

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

Function GetDirectory(Optional msg) As String
    On Error Resume Next
    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 = "Please select the folder of the excel files to copy."
    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

Sub CombineFiles()
    Dim path            As String
    Dim FileName        As String
    Dim LastCell        As Range
    Dim Wkb             As Workbook
    Dim WS              As Worksheet
    Dim ThisWB          As String

    ThisWB = ThisWorkbook.Name
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    path = GetDirectory
    FileName = Dir(path & "\*.xls", vbNormal)
    Do Until FileName = ""
        If FileName <> ThisWB Then
            Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
            For Each WS In Wkb.Worksheets
                Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
                If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
                Else
                    WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                End If
            Next WS
            Wkb.Close False
        End If
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    Set Wkb = Nothing
    Set LastCell = Nothing
End Sub
于 2015-10-29T03:31:41.427 に答える