Transfer Spreadsheet

[Martin]

Hello,

I have some coded (posted below) that transfers into Excel a number of
queries. This works fine however the spreadsheet I am transfering to needs
to be password protected (open only, not to write to). When the Excel file
is password protected Access quite rightly states it cannot transfer to the
file.

My question is, is there anyway to bypass this? i suppose what i need to do
is get Access to let Excel know the password and continue in the usual way.
As you will see from the code it does this process for each item in a list,
sometimes this list can contain 100's of names so it would work to open each
file physically.

If anyone has any suggestions then please let me know. Please!!

Here is the code:

For Each vItem In Me.Name.ItemsSelected
ubName = Me.Name.ItemData(vItem)

SourceFile = "c:\Temp\AD Pack.xls"
DestinationFile = "c:\temp\" & Me.ubName & ".xls"
FileCopy SourceFile, DestinationFile

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Report
01", DestinationFile, True
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Report
01_1", DestinationFile, True

Me.intProgress = Me.intProgress + 1
Me.Repaint
Next

Many thanks,

Martin

 

[Chris]

I believe that to do what you want, you will have to run this process from
Excel and not Access. Instead of exporting from Access, write a procedure in
Excel to import the data. The Excel newsgroup should be able to provide
assitance with specifics of how to accomplish what you need.

 

[pietlinden]

Hello,

I have some coded (posted below) that transfers into Excel a number of
queries.  This works fine however the spreadsheet I am transfering to needs
to be password protected (open only, not to write to).  When the Excel file
is password protected Access quite rightly states it cannot transfer to the
file.

My question is, is there anyway to bypass this?  i suppose what i need to do
is get Access to let Excel know the password and continue in the usual way.  
As you will see from the code it does this process for each item in a list,
sometimes this list can contain 100's of names so it would work to open each
file physically.  

If anyone has any suggestions then please let me know.  Please!!

Here is the code:

For Each vItem In Me.Name.ItemsSelected
      ubName = Me.Name.ItemData(vItem)

        SourceFile = "c:\Temp\AD Pack.xls"
        DestinationFile = "c:\temp\" & Me.ubName & ".xls"
        FileCopy SourceFile, DestinationFile

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Report
01", DestinationFile, True
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Report
01_1", DestinationFile, True

      Me.intProgress = Me.intProgress + 1
      Me.Repaint
   Next

Many thanks,

Martin

You can use ADO to do this and then open the Excel file and pass the
password to the file when you open it...

What follows is code I tweaked from here:
http://www.mvps.org/access/modules/mdl0035.htm


Sub sCopyRSToNamedRange()
'Copy records to a named range
'on an existing worksheet on a
'workbook
'
Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet
Dim db As Database
Dim rs As Recordset
Const conMAX_ROWS = 20000
Const conSHT_NAME = "SomeSheet"
Const conWKB_NAME = "c:\temp\book1.xls"
Const conRANGE = "RangeForRS"

Set db = CurrentDb
Set objXL = New Excel.Application
Set rs = db.OpenRecordset("Customers", dbOpenSnapshot)
With objXL
.Visible = True
'pass the password to open the file in your code. But then make
sure you don't allow the user to see the code!
Set objWkb = .Workbooks.Open(conWKB_NAME, False, False, ,
"MYPASSWORD", , , , , True)
'Set objWkb = .Workbooks.Open(conWKB_NAME)
On Error Resume Next
Set objSht = objWkb.Worksheets(conSHT_NAME)
If Not Err.Number = 0 Then
Set objSht = objWkb.Worksheets.Add
objSht.Name = conSHT_NAME
End If
Err.Clear
On Error GoTo 0
objSht.Range(conRANGE).CopyFromRecordset rs
End With
Set objSht = Nothing
Set objWkb = Nothing
Set objXL = Nothing
Set rs = Nothing
Set db = Nothing
End Sub
'************* Code End *****************