View Full Version : test
emelem
11-06-2011, 06:40 PM
Public Function OpenExcelAddWorkbook(strFullFileName As String, _
strWorkbookName As String, _
strQueryName As String, _
Optional blnClose As Boolean) As Boolean
On Error GoTo Err_Proc
emelem
11-06-2011, 06:40 PM
If Len(strFullFileName) = 0 Then
MsgBox "Missing filename.", vbCritical + vbOKOnly, "Error"
Exit Function
End If
If Len(strWorkbookName) = 0 Then
MsgBox "Missing sheet name.", vbCritical + vbOKOnly, "Error"
Exit Function
End If
If Len(strQueryName) = 0 Then
MsgBox "Missing query name or SQL string.", vbCritical + vbOKOnly, "Error"
Exit Function
End If
emelem
11-06-2011, 06:41 PM
Dim objApp As Object
Dim intSR As Integer
Dim dbs As DAO.Database
Dim rsRecords As DAO.Recordset
Dim strMsg As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim i As Long
Dim strHeading As String
Dim blnWorksheetExists As Boolean
Dim blnSpreadsheetExists As Boolean
Set dbs = CurrentDb
Set rsRecords = dbs.OpenRecordset(strQueryName)
If rsRecords.EOF And rsRecords.BOF Then
MsgBox "Query or SQL returned no records.", vbCritical + vbOKOnly, "Error"
Exit Function
End If
emelem
11-06-2011, 06:42 PM
Set objApp = CreateObject("Excel.Application")
objApp.UserControl = True
blnSpreadsheetExists = MyFileExists(strFullFileName)
If blnSpreadsheetExists Then
objApp.Workbooks.Open strFullFileName
Else
objApp.Workbooks.Add
End If
objApp.DisplayAlerts = True
objApp.ActiveWorkbook.Worksheets(strWorkbookName).Activate
If blnWorksheetExists = True Then
MsgBox "Workbook " & strWorkbookName & " exists!" & _
vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
Exit Function
Else
objApp.ActiveWorkbook.Worksheets.Add.Name = "" & strWorkbookName & ""
End If
With objApp.Worksheets("" & strWorkbookName & "")
lngMaxCol = rsRecords.Fields.Count
If rsRecords.RecordCount > 0 Then
rsRecords.MoveLast
rsRecords.MoveFirst
lngMaxRow = rsRecords.RecordCount
If lngMaxRow > 65536 Then
strMsg = Format(lngMaxRow, "#,##0") & " exceeds the maximum " & _
"of 65,536 rows that can be " & vbCrLf
If blnSpreadsheetExists Then
strMsg = strMsg & "exported directly...you will have " & _
"to manully export the " & vbCrLf & _
strMsg = strMsg & "into a spreadsheet."
MsgBox strMsg
emelem
11-06-2011, 06:43 PM
rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing
objApp.DisplayAlerts = False
objApp.Quit
DoCmd.OpenQuery strQueryName, acViewNormal, acReadOnly
MsgBox "Now use the File + Export manual method."
Exit Function
Else
strMsg = strMsg & "exported directly...switching to transfer."
MsgBox strMsg
rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing
objApp.DisplayAlerts = False
objApp.Quit
DoCmd.TransferSpreadsheet acExport, _ acSpreadsheetTypeExcel9, _
Powered by vBulletin® Version 4.2.5 Copyright © 2025 vBulletin Solutions Inc. All rights reserved.