Descecrator
Registered User.
- Local time
- Today, 17:05
- Joined
- Oct 18, 2005
- Messages
- 11
Dear people,
I'm working on a form where the attributes for a workbook can be given in and the workbook kan be copied inside an OLEBound-object. Now, when the save button is pressed, the workbook has to be saved as an excelfile. I've got the following code, but it doesn't work. Can anybody help me with this please
?
The code for the savemodule for excelobjects:
Option Compare Database
Function fExportCommaDelimitedFile(objSht As Object, _
strDestinationFile As String) _
As Boolean
Dim lngColCount As Long
Dim lngTotalColumns As Long
Dim lngTotalRows As Long
Dim lngRowCount As Long
Const conERR_GENERIC = vbObjectError + 2100
Dim NewObject As Object
On Error GoTo ErrHandler
'Activate Access instance
Call sAppActivate
'If the target file exists, confirm that it should be deleted
If Len(Dir(strDestinationFile)) > 0 Then
If MsgBox("Het opgegeven doelbestand " & vbCrLf & vbCrLf _
& strDestinationFile & vbCrLf & vbCrLf & " bestaat al." _
& vbCrLf & vbCrLf & "Wilt U het overschrijven?", _
vbQuestion + vbYesNo, "Bevestigen aub") = vbYes Then
Kill strDestinationFile
Else
Err.Raise conERR_GENERIC
End If
End If
'Create the xls file
' Open strDestinationFile For Output As #intFileNum
Set NewObject = CreateObject("Excel.Application")
NewObject.Open
With objSht
'Determine total number of columns
lngTotalColumns = .UsedRange.Columns.Count
'Determine total number of rows
lngTotalRows = .UsedRange.Rows.Count
'Initialize the progress meter
Call SysCmd(acSysCmdInitMeter, "Wegschrijven Excel Spreadsheet...", lngTotalRows)
'Go through all the rows
For lngRowCount = 1 To lngTotalRows
' Loop through each column
For lngColCount = 1 To lngTotalColumns
' Write current cell's text to file with quotation marks.
objSht.Cells(lngRowCount, lngColCount).Value.EditSelectAll
objSht.Cells(lngRowCount, lngColCount).Value.EditCopy
NewObject.Cells(lngRowCount, lngColCount).Value.EditPaste
' Check if cell is in last column.
If lngColCount = lngTotalColumns Then
'the end
NewObject.SaveAs strDestinationFile
End If
Next lngColCount
Call SysCmd(acSysCmdUpdateMeter, lngRowCount)
'No need to hog the CPU for large worksheets
DoEvents
Next lngRowCount
End With
fExportCommaDelimitedFile = True
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdRemoveMeter)
NewObject.Close
Exit Function
ErrHandler:
fExportCommaDelimitedFile = False
Resume ExitHere
End Function
Private Sub sAppActivate()
'Activate the Access instance
'
Dim strCaption As String
On Error Resume Next
strCaption = Application.CurrentDb.Properties("AppTitle")
If Err Then strCaption = "Microsoft Access"
AppActivate strCaption
End Sub
I'm working on a form where the attributes for a workbook can be given in and the workbook kan be copied inside an OLEBound-object. Now, when the save button is pressed, the workbook has to be saved as an excelfile. I've got the following code, but it doesn't work. Can anybody help me with this please
The code for the savemodule for excelobjects:
Option Compare Database
Function fExportCommaDelimitedFile(objSht As Object, _
strDestinationFile As String) _
As Boolean
Dim lngColCount As Long
Dim lngTotalColumns As Long
Dim lngTotalRows As Long
Dim lngRowCount As Long
Const conERR_GENERIC = vbObjectError + 2100
Dim NewObject As Object
On Error GoTo ErrHandler
'Activate Access instance
Call sAppActivate
'If the target file exists, confirm that it should be deleted
If Len(Dir(strDestinationFile)) > 0 Then
If MsgBox("Het opgegeven doelbestand " & vbCrLf & vbCrLf _
& strDestinationFile & vbCrLf & vbCrLf & " bestaat al." _
& vbCrLf & vbCrLf & "Wilt U het overschrijven?", _
vbQuestion + vbYesNo, "Bevestigen aub") = vbYes Then
Kill strDestinationFile
Else
Err.Raise conERR_GENERIC
End If
End If
'Create the xls file
' Open strDestinationFile For Output As #intFileNum
Set NewObject = CreateObject("Excel.Application")
NewObject.Open
With objSht
'Determine total number of columns
lngTotalColumns = .UsedRange.Columns.Count
'Determine total number of rows
lngTotalRows = .UsedRange.Rows.Count
'Initialize the progress meter
Call SysCmd(acSysCmdInitMeter, "Wegschrijven Excel Spreadsheet...", lngTotalRows)
'Go through all the rows
For lngRowCount = 1 To lngTotalRows
' Loop through each column
For lngColCount = 1 To lngTotalColumns
' Write current cell's text to file with quotation marks.
objSht.Cells(lngRowCount, lngColCount).Value.EditSelectAll
objSht.Cells(lngRowCount, lngColCount).Value.EditCopy
NewObject.Cells(lngRowCount, lngColCount).Value.EditPaste
' Check if cell is in last column.
If lngColCount = lngTotalColumns Then
'the end
NewObject.SaveAs strDestinationFile
End If
Next lngColCount
Call SysCmd(acSysCmdUpdateMeter, lngRowCount)
'No need to hog the CPU for large worksheets
DoEvents
Next lngRowCount
End With
fExportCommaDelimitedFile = True
ExitHere:
On Error Resume Next
Call SysCmd(acSysCmdRemoveMeter)
NewObject.Close
Exit Function
ErrHandler:
fExportCommaDelimitedFile = False
Resume ExitHere
End Function
Private Sub sAppActivate()
'Activate the Access instance
'
Dim strCaption As String
On Error Resume Next
strCaption = Application.CurrentDb.Properties("AppTitle")
If Err Then strCaption = "Microsoft Access"
AppActivate strCaption
End Sub