Option Explicit
Private Const xlColumns = 2
Private Const xlColumnStacked = 52
Dim objGraph As Graph.Chart
Function IsNothing(Obj As Object) As Boolean
On Error Resume Next
IsNothing = True
Obj.Name = Obj.Name 'Works even if Object doesn't have a name property
If Err.Number = 91 Then IsNothing = True
End Function
Function IsExcelRunning() As Boolean
Dim xlApp As Excel.Application
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
IsExcelRunning = (Err.Number = 0)
Set xlApp = Nothing
Err.Clear
End Function
Private Function GetExcel() As Excel.Application
On Error Resume Next
Set GetExcel = GetObject(, "excel.application")
If Err.Number <> 0 Then Set GetExcel = New Excel.Application
End Function
Function OpenXLChange()
Dim db As DAO.Database
Dim RS As DAO.Recordset
Dim SQL, PATH As String
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim ExcelRunning As Boolean
Dim objGraph As Object
Set objGraph = frmForm1_Excel.OLE1.object ' I included a chart
ExcelRunning = IsExcelRunning()
If ExcelRunning = False Then
Set xlApp = CreateObject("Excel.application")
Else
Set xlApp = GetExcel
End If
If IsNothing(xlApp) Then Set xlApp = New Excel.Application
PATH = "C:\"
Set xlBook = xlApp.Workbooks.Open(PATH & MyXl & ".xls")
xlBook.Application.Visible = False
xlApp.ScreenUpdating = False
If frmForm1_Excel.ChkChart = vbChecked Then
With xlApp.Sheets.Add(After:=Sheets(1))
xlApp.Sheets(2).Name = "Graf"
End With
End If
xlApp.Sheets(1).Select
With xlApp.Workbooks(1).BuiltinDocumentProperties
.Item("Author").Value = "AuthorName"
.Item("Manager").Value = "ManagerName"
.Item("Title").Value = "TitleText"
.Item("Company").Value = "TheCompany"
.Item("Subject").Value = "SubjectText"
.Item("Comments").Value = "Comments"
End With
xlApp.ActiveSheet.PageSetup.PrintArea = ""
With xlApp.ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = "TestText"
.RightHeader = "&""Arial,Regular""&8 Sidan &P av &N"
.LeftFooter = "&""Arial,Regular""&8 TestNr2/&F/TestNr4/&D"
.CenterFooter = ""
.RightFooter = "&""Times New Roman,Normal""&3Automatic Created"
.LeftMargin = xlApp.Application.InchesToPoints(0)
.RightMargin = xlApp.Application.InchesToPoints(0)
.TopMargin = xlApp.Application.InchesToPoints(0.984251969)
.BottomMargin = xlApp.Application.InchesToPoints(0.984251969)
.HeaderMargin = xlApp.Application.InchesToPoints(0.5)
.FooterMargin = xlApp.Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With
xlApp.Range("A1:S1").Select
With xlApp.Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
xlApp.Cells.Select
With xlApp.Selection.Font
.Name = "MS Sans Serif"
.Size = 8.5
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
With xlApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
With xlApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThin
.ColorIndex = 15
End With
With xlApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
With xlApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
With xlApp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
xlApp.Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.MergeCells = False
End With
xlApp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
xlApp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With xlApp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With xlApp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
xlApp.Columns("D:E").Select
xlApp.Selection.NumberFormat = "yyyy-mm-dd"
xlApp.Columns("H:S").Select
xlApp.Selection.AutoFilter
xlApp.Cells.Select
xlApp.Cells.EntireColumn.AutoFit
xlApp.ActiveWindow.View = xlPageBreakPreview
xlApp.ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
xlApp.ActiveWindow.View = xlNormalView
xlApp.Range("A1").Select
SQL = "Mys SQL statement"
Set db = OpenDatabase(GetTmpPath & "TestMDB.MDB", False, True, ";pwd=******")
Set RS = db.OpenRecordset(SQL, dbOpenDynaset)
While Not RS.EOF
With xlApp.Range("A" & RS.AbsolutePosition + 2).AddComment
.Visible = False
.Text Text:=RTrim(RS.FIELDS("Name").Value) & Chr(10) & _
"Faxnr: " & RTrim(RS.FIELDS("FaxNumber"))
.Shape.ScaleWidth 1.63, False
.Shape.ScaleHeight 1.38, False
End With
RS.MoveNext
Wend
RS.Close
If frmForm1_Excel.ChkChart = vbChecked Then
xlApp.Sheets("Graf").Select
objGraph.ChartArea.Copy
xlApp.Cells.Select
xlApp.ActiveSheet.Paste
xlApp.ActiveSheet.Shapes("Object 1").Select ' Here is the copied chart
xlApp.Selection.ShapeRange.ScaleWidth 0.88, False
With xlApp.ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = "TestText"
.RightHeader = "&""Arial,Regular""&8 Sidan &P av &N"
.LeftFooter = "&""Arial,Regular""&8 TestNr2/&F/TestNr4/&D"
.CenterFooter = ""
.RightFooter = "&""Times New Roman,Normal""&3Automatic Created"
.LeftMargin = xlApp.Application.InchesToPoints(0)
.RightMargin = xlApp.Application.InchesToPoints(0)
.TopMargin = xlApp.Application.InchesToPoints(0.984251969)
.BottomMargin = xlApp.Application.InchesToPoints(0.984251969)
.HeaderMargin = xlApp.Application.InchesToPoints(0.5)
.FooterMargin = xlApp.Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With
Set objGraph = Nothing
End If
xlBook.Save
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Set db = Nothing
Set RS = Nothing
End Function
