Recordset Arbeitsmappe schreibgeschützt
Andi
Exceldateien lese ich mit Hilfe von ADO / Jet Engine aus.
Eine schreibgeschützte Arbeitsmappe kann ich nicht lesen. Ist es mit dieser Methode überhaupt möglich schreibgeschützte Arbeitsmappen auszulessen?
Benötige prinzipiel nur einen Data Reader und keinen Data Set.
Wo muß das Kennwort "Schutz Arbeitsmappe" als Parameter übergeben werden? (Nicht verwechseln mit Schreibschutz). Oder verwende ich die falsche Methode Data Set?
THX
Andi
Function ADOExcel(ByRef ExcelPath As String, ByRef Tabelle As String, Optional Countrows As _
Long = 500) As Variant
Dim rs As New ADODB.Recordset
Dim arrADO() As Variant
Dim arrEXC() As Variant
Dim n As Long, m As Long, k As Long, i As Long, Max As Long
On Error Resume Next
Set rs = ExcelTable(ExcelPath, Tabelle)
rs.MoveFirst
If Err.Number 0 Then
Erase arrADO
ADOExcel = arrADO
Exit Function
End If
On Error GoTo 0
rs.MoveFirst
Erase arrADO
arrADO = rs.GetRows(Countrows)
arrEXC = TransposeArray(arrADO)
Erase arrADO
arrADO = arrEXC
Erase arrEXC
ReDim arrEXC(1 To UBound(arrADO) + 1, 1 To UBound(arrADO, 2) + 1)
For m = LBound(arrADO) To UBound(arrADO)
For n = LBound(arrADO, 2) To UBound(arrADO, 2)
arrEXC(m + 1, n + 1) = arrADO(m, n)
Next
Next
Erase arrADO
ReDim arrADO(1 To UBound(arrEXC) + 1, 1 To UBound(arrEXC, 2))
rs.MoveFirst
For m = LBound(arrEXC) To UBound(arrEXC) + 1
For n = LBound(arrEXC, 2) To UBound(arrEXC, 2)
If m = 1 Then
For i = 0 To rs.Fields.Count - 1
arrADO(m, i + 1) = rs.Fields(i).Name
Next
Else
arrADO(m, n) = arrEXC(m - 1, n)
End If
Next
Next
rs.Close
ADOExcel = arrADO
End Function
Function ExcelTable(ByRef ExcelPath As String, ByRef Tabelle As String) As ADODB.Recordset
Dim excelfile As New ADOX.Catalog
Dim cn As New ADODB.Connection
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Tabelle & "$]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & "Data Source=" & _
ExcelPath & ";" ' & "HDR=No" & ";" & "IMEX=1" & ";"
Call cn.Open(Con)
'ADOX Anzahl Tabellen
Set excelfile.ActiveConnection = cn
'MsgBox excelFile.Tables.Count
AnzahlTab = 0
For i = 0 To excelfile.Tables.Count - 1
If Right(excelfile.Tables(i).Name, 1) = "$" Then
AnzahlTab = AnzahlTab + 1
End If
Next
If Not AnzahlTab = 0 Then
Set ExcelTable = New ADODB.Recordset
ExcelTable.Open SQL, Con, adOpenKeyset, adLockOptimistic
cn.Close
End If
End Function
Function TransposeArray(v As Variant) As Variant
Dim x, y, Xupper, Yupper As Long
Dim tempArray() As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For x = 0 To Xupper
For y = 0 To Yupper
tempArray(x, y) = v(y, x)
Next
Next
TransposeArray = tempArray
End Function