ExcelBanter - Return Sheet Names from Closed Workbook

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)

"crispbd" wrote in message
...

Is there a way using ADO to return only the names of each sheet within a
closed workbook?

--
crispbd
------------------------------------------------------------------------
crispbd's Profile:
http://www.excelforum.com/member.php...o&userid=10880
View this thread: http://www.excelforum.com/showthread...hreadid=320174