کپی اطلاعات از یک فایل بسته و دارای پسورد (Closed password protectec Workbook)

[mortezataheri]

سلام دوستان:
من یک فایل مقصد دارم که میخوام اطلاعاتی رو از یک فایل سورس که بسته هم هست بخونه ، البته اینکارو با استفاده از یک ADO انجام میدم .



Sub TransferData()
Dim sourceFile As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

sourceFile = "S:\mr. taheri\Radio.xls"

GetData sourceFile, "dec.", "A2:k9", Sheets("Dec.").Range("a4"), False, False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Public Sub GetData(sourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
' http://www.rondebruin.nl/ado.htm

Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If

If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If

Else
MsgBox "No records returned from : " & sourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub

SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & sourceFile, _
vbExclamation, "Error"
On Error GoTo 0

End Sub

کد بالا کارشو بخوبی انجام میده اما وقتی برا Source Workbook پسورد میزارم دیگه ADO کار نمیکنه .

کد باز کردن پسورد رو هم دارم فقط دقیقا نمیدونم کجا قرار بدم تا خطا نده یکی دوبار جاشو عوض کردم جواب نداد

Sub Openfile ()
Workbooks.Open Filename:="S:\mr. taheri\Radio.xls, passworD:=123456"
End sub
یا
Workbooks.Open Filename:="S:\mr. taheri\Radio.xls, passworD:=123456"

ممنون میشم راهنمائیم کنین