Getting data from a closed wbook
in [Programming]
|
Prev: Counting records with ADO
Next: Microsoft.Office.Interop.Excel myexcel = new EXCEL.Application()
From: Geoff K on 5 Oct 2009 18:05 Hi I have tested the sheet name finder and found it works too though I have a little concern about wbooks with wsheet linking formula such as =MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc.. But at the moment I am happy to run with it and time will tell if the anomalies were one offs. So, once again many thanks for your help. Geoff
From: RB Smissaert on 5 Oct 2009 19:12 Try this adapted code to handle sheets with faulty links. Not sure it will always work and maybe somebody who knows better about BIFF could come in here. Function GetWBSheetNames(sFullName As String, _ Optional bWorksheetsOnly As Boolean = False, _ Optional bSheetTypeAsString As Boolean = True) As Variant '-------------------------------------------------------------------- 'Returns a 1-based 2-D array 'showing the sheet names in column 1 of the array 'and the sheet type in column 2 of the array '0 = WorkSheet (dialog sheet will be 0 as well) '2 = ChartSheet 'if bWorksheetsOnly = True it will only look at worksheets 'if bSheetTypeAsString = True it will show the sheet type as a string '-------------------------------------------------------------------- Dim i As Long Dim aByt() As Byte Dim iTyp As Integer Dim lHnd As Long Dim lLen As Long Dim lPos1 As Long Dim lPos2 As Long Dim sTxt As String Dim sTyp As String Dim cRes As Collection Dim arr Dim lPosDots As Long Dim lPosChr1 As Long Const IDboundsheet = &H85 '133 Const BuffSize = &H400 '1024 If bFileExists(sFullName) = False Then Exit Function 'so no array returned End If Set cRes = New Collection ReDim aByt(0 To BuffSize) lLen = FileLen(sFullName) lHnd = FreeFile Open sFullName For Binary Access Read As lHnd Len = BuffSize Do lPos1 = lPos1 + BuffSize - 1 Get lHnd, lPos1, aByt lPos2 = InStrB(aByt, ChrB(IDboundsheet)) Loop While lPos2 = 0 And lPos1 < lLen Do While lPos2 > 0 lPos1 = lPos1 + lPos2 - 1 Get lHnd, lPos1, aByt sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10)) 'this is to handle a sheet with faulty links 'there probably are more situations to handle here '---------------------------------------------------------------- lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare) If lPosDots > 0 Then lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare) lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare) sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1) End If '---------------------------------------------------------------- iTyp = aByt(9) If bSheetTypeAsString = True Then 'iTyp > 2 is for the above faulty links '-------------------------------------- If iTyp = 0 Or iTyp > 2 Then sTyp = "WorkSheet" Else sTyp = "ChartSheet" End If If bWorksheetsOnly = True Then If iTyp = 0 Then cRes.Add Array(sTxt, sTyp), sTxt End If Else cRes.Add Array(sTxt, sTyp), sTxt End If Else If bWorksheetsOnly = True Then If iTyp = 0 Then cRes.Add Array(sTxt, iTyp), sTxt End If Else cRes.Add Array(sTxt, iTyp), sTxt End If End If If aByt(aByt(2) + 4) <> IDboundsheet Then lPos2 = 0 Else lPos2 = InStrB(4, aByt, ChrB(&H85)) End If Loop Close lHnd 'transfer the collection to an array '----------------------------------- ReDim arr(1 To cRes.Count, 1 To 2) For i = 1 To cRes.Count arr(i, 1) = cRes.Item(i)(0) arr(i, 2) = cRes.Item(i)(1) Next i GetWBSheetNames = arr End Function RBS "Geoff K" <GeoffK(a)discussions.microsoft.com> wrote in message news:A73FA8D4-7DC2-4A2D-A270-5DCE3C096BDC(a)microsoft.com... > Hi > I have tested the sheet name finder and found it works too though I have a > little concern about wbooks with wsheet linking formula such as > =MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc.. > But at the moment I am happy to run with it and time will tell if the > anomalies were one offs. > > So, once again many thanks for your help. > > Geoff
From: RB Smissaert on 6 Oct 2009 08:49 Found this code from Rob Bovey that gets the Workbook names with ADO and it doesn't fail when there are links to non-existing workbooks. It is slower than accessing the BIFF data, but a lot simpler and it does the job. Sub GetClosedSheetNames1(ByRef szFullName As String, _ aszSheetList() As String) 'Code written by Rob Bovey 05/13/05 'Requires reference to: 'Microsoft ActiveX Data Object X.X Library Dim bIsWorksheet As Boolean Dim objConnection As ADODB.Connection Dim rsData As ADODB.Recordset Dim lIndex As Long Dim szConnect As String Dim szSheetName As String If Right(szFullName, 3) <> "xls" Then ReDim aszSheetList(1) aszSheetList(1) = "" Exit Sub End If Erase aszSheetList() szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & szFullName & ";" & _ "Extended Properties=Excel 8.0;" Set objConnection = New ADODB.Connection objConnection.Open szConnect Set rsData = objConnection.OpenSchema(adSchemaTables) lIndex = 1 Do While Not rsData.EOF bIsWorksheet = False szSheetName = rsData.Fields("TABLE_NAME").Value If Right$(szSheetName, 1) = "$" Then ''' This is a simple sheet name. Remove the trailing "$" and continue. szSheetName = Left$(szSheetName, Len(szSheetName) - 1) bIsWorksheet = True ElseIf Right$(szSheetName, 2) = "$'" Then ''' This is a sheet name with spaces and/or special characters. ''' Remove the right "&'" characters. szSheetName = Left$(szSheetName, Len(szSheetName) - 2) ''' Remove the left single quote character. szSheetName = Right$(szSheetName, Len(szSheetName) - 1) ''' Embedded single quotes in the sheet name will be doubled up. ''' Replace any doubled single quotes with one single quote. szSheetName = Replace$(szSheetName, "''", "'") bIsWorksheet = True End If If bIsWorksheet Then ''' Load the processed sheet name into the array. ReDim Preserve aszSheetList(1 To lIndex) aszSheetList(lIndex) = szSheetName lIndex = lIndex + 1 End If rsData.MoveNext Loop rsData.Close Set rsData = Nothing objConnection.Close Set objConnection = Nothing End Sub Sub TestMethod1() Dim strArr() As String Dim i As Long GetClosedSheetNames1 "C:\Test.xls", strArr For i = LBound(strArr) To UBound(strArr) MsgBox strArr(i) Next i End Sub RBS "RB Smissaert" <bartsmissaert(a)blueyonder.co.uk> wrote in message news:uDJTWFhRKHA.4244(a)TK2MSFTNGP06.phx.gbl... > Try this adapted code to handle sheets with faulty links. > Not sure it will always work and maybe somebody who knows better > about BIFF could come in here. > > Function GetWBSheetNames(sFullName As String, _ > Optional bWorksheetsOnly As Boolean = False, _ > Optional bSheetTypeAsString As Boolean = True) As > Variant > > '-------------------------------------------------------------------- > 'Returns a 1-based 2-D array > 'showing the sheet names in column 1 of the array > 'and the sheet type in column 2 of the array > '0 = WorkSheet (dialog sheet will be 0 as well) > '2 = ChartSheet > 'if bWorksheetsOnly = True it will only look at worksheets > 'if bSheetTypeAsString = True it will show the sheet type as a string > '-------------------------------------------------------------------- > > Dim i As Long > Dim aByt() As Byte > Dim iTyp As Integer > Dim lHnd As Long > Dim lLen As Long > Dim lPos1 As Long > Dim lPos2 As Long > Dim sTxt As String > Dim sTyp As String > Dim cRes As Collection > Dim arr > Dim lPosDots As Long > Dim lPosChr1 As Long > > Const IDboundsheet = &H85 '133 > Const BuffSize = &H400 '1024 > > If bFileExists(sFullName) = False Then > Exit Function 'so no array returned > End If > > Set cRes = New Collection > ReDim aByt(0 To BuffSize) > > lLen = FileLen(sFullName) > lHnd = FreeFile > > Open sFullName For Binary Access Read As lHnd Len = BuffSize > > Do > lPos1 = lPos1 + BuffSize - 1 > Get lHnd, lPos1, aByt > lPos2 = InStrB(aByt, ChrB(IDboundsheet)) > Loop While lPos2 = 0 And lPos1 < lLen > > Do While lPos2 > 0 > lPos1 = lPos1 + lPos2 - 1 > Get lHnd, lPos1, aByt > sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10)) > > 'this is to handle a sheet with faulty links > 'there probably are more situations to handle here > '---------------------------------------------------------------- > lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare) > If lPosDots > 0 Then > lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare) > lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare) > sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1) > End If > '---------------------------------------------------------------- > > iTyp = aByt(9) > > If bSheetTypeAsString = True Then > 'iTyp > 2 is for the above faulty links > '-------------------------------------- > If iTyp = 0 Or iTyp > 2 Then > sTyp = "WorkSheet" > Else > sTyp = "ChartSheet" > End If > If bWorksheetsOnly = True Then > If iTyp = 0 Then > cRes.Add Array(sTxt, sTyp), sTxt > End If > Else > cRes.Add Array(sTxt, sTyp), sTxt > End If > Else > If bWorksheetsOnly = True Then > If iTyp = 0 Then > cRes.Add Array(sTxt, iTyp), sTxt > End If > Else > cRes.Add Array(sTxt, iTyp), sTxt > End If > End If > > If aByt(aByt(2) + 4) <> IDboundsheet Then > lPos2 = 0 > Else > lPos2 = InStrB(4, aByt, ChrB(&H85)) > End If > Loop > > Close lHnd > > 'transfer the collection to an array > '----------------------------------- > ReDim arr(1 To cRes.Count, 1 To 2) > > For i = 1 To cRes.Count > arr(i, 1) = cRes.Item(i)(0) > arr(i, 2) = cRes.Item(i)(1) > Next i > > GetWBSheetNames = arr > > End Function > > > RBS > > > "Geoff K" <GeoffK(a)discussions.microsoft.com> wrote in message > news:A73FA8D4-7DC2-4A2D-A270-5DCE3C096BDC(a)microsoft.com... >> Hi >> I have tested the sheet name finder and found it works too though I have >> a >> little concern about wbooks with wsheet linking formula such as >> =MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc.. >> But at the moment I am happy to run with it and time will tell if the >> anomalies were one offs. >> >> So, once again many thanks for your help. >> >> Geoff >
From: Geoff K on 6 Oct 2009 11:33
That seems to overcome the issues with links. I've thrown a lot my 'anomaly' wbs at it and it does the job so far. On to the next one.... Thank you. Geoff "RB Smissaert" wrote: > Found this code from Rob Bovey that gets the Workbook names with ADO and it > doesn't fail when there are links to non-existing workbooks. > It is slower than accessing the BIFF data, but a lot simpler and it does the > job. > > Sub GetClosedSheetNames1(ByRef szFullName As String, _ > aszSheetList() As String) > > 'Code written by Rob Bovey 05/13/05 > 'Requires reference to: > 'Microsoft ActiveX Data Object X.X Library > > Dim bIsWorksheet As Boolean > Dim objConnection As ADODB.Connection > Dim rsData As ADODB.Recordset > Dim lIndex As Long > Dim szConnect As String > Dim szSheetName As String > > If Right(szFullName, 3) <> "xls" Then > ReDim aszSheetList(1) > aszSheetList(1) = "" > Exit Sub > End If > > Erase aszSheetList() > szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ > "Data Source=" & szFullName & ";" & _ > "Extended Properties=Excel 8.0;" > > Set objConnection = New ADODB.Connection > objConnection.Open szConnect > Set rsData = objConnection.OpenSchema(adSchemaTables) > > lIndex = 1 > > Do While Not rsData.EOF > bIsWorksheet = False > szSheetName = rsData.Fields("TABLE_NAME").Value > If Right$(szSheetName, 1) = "$" Then > ''' This is a simple sheet name. Remove the trailing "$" and continue. > szSheetName = Left$(szSheetName, Len(szSheetName) - 1) > bIsWorksheet = True > ElseIf Right$(szSheetName, 2) = "$'" Then > ''' This is a sheet name with spaces and/or special characters. > ''' Remove the right "&'" characters. > szSheetName = Left$(szSheetName, Len(szSheetName) - 2) > ''' Remove the left single quote character. > szSheetName = Right$(szSheetName, Len(szSheetName) - 1) > ''' Embedded single quotes in the sheet name will be doubled up. > ''' Replace any doubled single quotes with one single quote. > szSheetName = Replace$(szSheetName, "''", "'") > bIsWorksheet = True > End If > If bIsWorksheet Then > ''' Load the processed sheet name into the array. > ReDim Preserve aszSheetList(1 To lIndex) > aszSheetList(lIndex) = szSheetName > lIndex = lIndex + 1 > End If > rsData.MoveNext > Loop > > rsData.Close > Set rsData = Nothing > objConnection.Close > Set objConnection = Nothing > > End Sub > > Sub TestMethod1() > > Dim strArr() As String > Dim i As Long > > GetClosedSheetNames1 "C:\Test.xls", strArr > > For i = LBound(strArr) To UBound(strArr) > MsgBox strArr(i) > Next i > > End Sub > > > RBS > > > > "RB Smissaert" <bartsmissaert(a)blueyonder.co.uk> wrote in message > news:uDJTWFhRKHA.4244(a)TK2MSFTNGP06.phx.gbl... > > Try this adapted code to handle sheets with faulty links. > > Not sure it will always work and maybe somebody who knows better > > about BIFF could come in here. > > > > Function GetWBSheetNames(sFullName As String, _ > > Optional bWorksheetsOnly As Boolean = False, _ > > Optional bSheetTypeAsString As Boolean = True) As > > Variant > > > > '-------------------------------------------------------------------- > > 'Returns a 1-based 2-D array > > 'showing the sheet names in column 1 of the array > > 'and the sheet type in column 2 of the array > > '0 = WorkSheet (dialog sheet will be 0 as well) > > '2 = ChartSheet > > 'if bWorksheetsOnly = True it will only look at worksheets > > 'if bSheetTypeAsString = True it will show the sheet type as a string > > '-------------------------------------------------------------------- > > > > Dim i As Long > > Dim aByt() As Byte > > Dim iTyp As Integer > > Dim lHnd As Long > > Dim lLen As Long > > Dim lPos1 As Long > > Dim lPos2 As Long > > Dim sTxt As String > > Dim sTyp As String > > Dim cRes As Collection > > Dim arr > > Dim lPosDots As Long > > Dim lPosChr1 As Long > > > > Const IDboundsheet = &H85 '133 > > Const BuffSize = &H400 '1024 > > > > If bFileExists(sFullName) = False Then > > Exit Function 'so no array returned > > End If > > > > Set cRes = New Collection > > ReDim aByt(0 To BuffSize) > > > > lLen = FileLen(sFullName) > > lHnd = FreeFile > > > > Open sFullName For Binary Access Read As lHnd Len = BuffSize > > > > Do > > lPos1 = lPos1 + BuffSize - 1 > > Get lHnd, lPos1, aByt > > lPos2 = InStrB(aByt, ChrB(IDboundsheet)) > > Loop While lPos2 = 0 And lPos1 < lLen > > > > Do While lPos2 > 0 > > lPos1 = lPos1 + lPos2 - 1 > > Get lHnd, lPos1, aByt > > sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10)) > > > > 'this is to handle a sheet with faulty links > > 'there probably are more situations to handle here > > '---------------------------------------------------------------- > > lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare) > > If lPosDots > 0 Then > > lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare) > > lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare) > > sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1) > > End If > > '---------------------------------------------------------------- > > > > iTyp = aByt(9) > > > > If bSheetTypeAsString = True Then > > 'iTyp > 2 is for the above faulty links > > '-------------------------------------- > > If iTyp = 0 Or iTyp > 2 Then > > sTyp = "WorkSheet" > > Else > > sTyp = "ChartSheet" > > End If > > If bWorksheetsOnly = True Then > > If iTyp = 0 Then > > cRes.Add Array(sTxt, sTyp), sTxt > > End If > > Else > > cRes.Add Array(sTxt, sTyp), sTxt > > End If > > Else > > If bWorksheetsOnly = True Then > > If iTyp = 0 Then > > cRes.Add Array(sTxt, iTyp), sTxt > > End If > > Else > > cRes.Add Array(sTxt, iTyp), sTxt > > End If > > End If > > > > If aByt(aByt(2) + 4) <> IDboundsheet Then > > lPos2 = 0 > > Else > > lPos2 = InStrB(4, aByt, ChrB(&H85)) > > End If > > Loop > > > > Close lHnd > > > > 'transfer the collection to an array > > '----------------------------------- > > ReDim arr(1 To cRes.Count, 1 To 2) > > > > For i = 1 To cRes.Count > > arr(i, 1) = cRes.Item(i)(0) > > arr(i, 2) = cRes.Item(i)(1) > > Next i > > > > GetWBSheetNames = arr > > > > End Function > > > > > > RBS > > > > > > "Geoff K" <GeoffK(a)discussions.microsoft.com> wrote in message > > news:A73FA8D4-7DC2-4A2D-A270-5DCE3C096BDC(a)microsoft.com... > >> Hi > >> I have tested the sheet name finder and found it works too though I have > >> a > >> little concern about wbooks with wsheet linking formula such as > >> =MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc.. > >> But at the moment I am happy to run with it and time will tell if the > >> anomalies were one offs. > >> > >> So, once again many thanks for your help. > >> > >> Geoff > > > > |