Sub GetSheetNames()
Dim objConn As Object
Dim objCat As Object
Dim tbl As Object
Dim iRow As Long
Dim sWorkbook As String
Dim sConnString As String
Dim sTableName As String
Dim cLength As Integer
Dim iTestPos As Integer
Dim iStartpos As Integer
sWorkbook = "c:\myTest\bob.xls"
sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sWorkbook & ";" & _
"Extended Properties=Excel 8.0;"
Set objConn = CreateObject("ADODB.Connection")
objConn.Open sConnString
Set objCat = CreateObject("ADOX.Catalog")
Set objCat.ActiveConnection = objConn
iRow = 1
For Each tbl In objCat.Tables
sTableName = tbl.Name
cLength = Len(sTableName)
iTestPos = 0
iStartpos = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(sTableName, 1) = "'" And Right(sTableName, 1) = "'" Then
iTestPos = 1
iStartpos = 2
End If
'Worksheet names always end in the "$" character
If Mid$(sTableName, cLength - iTestPos, 1) = "$" Then
Cells(iRow, 1) = Mid$(sTableName, iStartpos, cLength - _
(iStartpos + iTestPos))
iRow = iRow + 1
End If
Next tbl
objConn.Close
Set objCat = Nothing
Set objConn = Nothing
End Sub
or Jamie Collins' version using OpenSchema
Public Function GetWSNames( _
ByVal WBPath As String _
) As Variant
Dim adCn As Object
Dim adRs As Object
Dim asSheets() As String
Dim nShtNum As Long
Dim nRows As Long
Dim nRowCounter As Long
Dim sSheet As String
Dim sOSheet As String
Dim sChar1 As String
Dim sChar2 As String
Const INDICATOR_SHEET As String = "$"
Const INDICATOR_SPACES As String = "'"
Set adCn = CreateObject("ADODB.Connection")
With adCn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB" & _
".4.0;Data Source=" & WBPath & ";Extended " & _
"Properties='Excel 8.0;HDR=Yes'"
.CursorLocation = 3
.Open
End With
Set adRs = adCn.OpenSchema(20)
With adRs
nRows = .RecordCount
Dim strMsg As String
For nRowCounter = 0 To nRows - 1
sOSheet = !TABLE_NAME
strMsg = "[" & sOSheet & "]"
sSheet = !TABLE_NAME
sChar1 = vbNullString
sChar2 = vbNullString
On Error Resume Next
sChar1 = Mid$(sSheet, Len(sSheet), 1)
sChar2 = Mid$(sSheet, Len(sSheet) - 1, 1)
On Error GoTo 0
Select Case sChar1
Case INDICATOR_SHEET
sSheet = Left$(sSheet, Len(sSheet) - 1)
Case INDICATOR_SPACES
If sChar2 = INDICATOR_SHEET Then
sSheet = Mid$(sSheet, 2, Len(sSheet) - 3)
End If
Case Else
sSheet = vbNullString
End Select
If Len(sSheet) > 0 Then
ReDim Preserve asSheets(nShtNum)
' Un-escape
asSheets(nShtNum) = Replace(sSheet, _
INDICATOR_SPACES & INDICATOR_SPACES, _
INDICATOR_SPACES)
strMsg = strMsg & "=[" & sSheet & "]"
nShtNum = nShtNum + 1
End If
.MoveNext
Next
.Close
End With
adCn.Close
GetWSNames = asSheets
End Function
--
HTH
RP
(remove nothere from the email address if mailing direct)
