Automation Errors

[Chance1234]

Hi

Im havingt trouble with the followng code throwing up a few automation problems here and there, i know theres a way round this using late binding or something but not sure how to implement this

Public Sub PsubCreatEGraphs(chkd(), chkid)

Dim i As Integer
Dim wrkapp As Excel.Application
Dim Wrkbknew As Workbook
Dim WrkShtNew As Worksheet

Dim sTrsQl As String
Dim rst As Recordset
Dim IntCo As Integer
Dim LpC As Integer


Dim ChtNew As Chart


Dim strb, strc As String



On Error GoTo ErrTrap

'-------------------Excel Add----------------

Set wrkapp = CreateObject("Excel.application&quot
Set Wrkbknew = wrkapp.Workbooks.Add

'Wrkbknew.Application.Visible = True

'----------****************** LOOP ***************************

LpC = 1
i = 1

Do Until LpC = UBound(chkd) + 1
Set WrkShtNew = Wrkbknew.Worksheets.Add
WrkShtNew.Name = chkd(LpC)

'--****-----Call Functions for SQL
sTrsQl = pfunWhAtSqL(chkd(LpC), chkid)
IntCo = pfunWhAtcolumns(chkd(LpC))
'--****----------------------------

'---** Connect TO Data **------------------
psubUserConnect
Set rst = objUserConnection.Execute(sTrsQl)

'--**POPULATE NEW SHEET WITH DATA FROM RST **____________
Do Until rst.EOF = True

Wrkbknew.Sheets(chkd(LpC)).Cells(i, 1) = rst.Fields(2)
Wrkbknew.Sheets(chkd(LpC)).Cells(i, 2) = 0 + rst.Fields(IntCo)

i = i + 1

rst.MoveNext
Loop
'------------------

'**** CREATE CHART ****----------------


If i > 1 Then

Set ChtNew = Wrkbknew.Charts.Add

strb = "B1:B" & i
strc = "!R1C1:R " & i & "C1"

With ChtNew
.ChartType = xlColumnClustered
.SetSourceData Source:=Sheets(chkd(LpC)).Range(strb), PlotBy:=xlColumns
.Location WHERE:=xlLocationAsObject, Name:=chkd(LpC)
End With

End If

'----********** Clear Up
Set WrkShtNew = Nothing
Set ChtNew = Nothing

sTrsQl = ""
IntCo = 0
strb = ""
strc = ""
i = 1
psubUserDisconnect

'=--------Loop counter increase

LpC = LpC + 1

Loop




Wrkbknew.SaveAs FileName:="C:\temp\tst1.xls"
Wrkbknew.Close


Set WrkShtNew = Nothing
Set ChtNew = Nothing

sTrsQl = ""
IntCo = 0
strb = ""
strc = ""
psubUserDisconnect



Set wrkapp = Nothing
Set Wrkbknew = Nothing

Exit Sub

ErrTrap:

Select Case Err.Number
Case 1044
Resume Next
Case Else
MsgBox Err.Description
End Select



End Sub

 

[SkipVought]

Hi, Chance1234,

Well, tell us what you are trying to do and where the problem(s) is/are occuring and what kind of error message(s) you are getting.

Enquiring minds need to know! ;-) Skip,
metzgsk@voughtaircraft.com

 

[Chance1234]

Hi ,

Ive got a bnit furhter with this, basicly the code create a excel workbook with a series of charts. that is all created through the loop, the code run fines first time. when i try and run it again , i get message such as global method of sheet or chart failed runtiem error 1044.

Now i thing this is to do with the excel instance not clearing as it still appears in the task manager when the code has run, to make life more complicated there is acutally two module s where im calling excel below.

Public Function pfunCreatEGraphs(chkd(), ChkId) As String
Dim i As Integer
Dim WrkApp As Excel.Application
Dim Wrkbknew As Workbook
Dim WrkShtNew As Worksheet

Dim sTrsQl As String
Dim rst As Recordset
Dim IntCo As Integer
Dim LpC As Integer


Dim ChtNew As Chart


Dim strb, strc As String



On Error GoTo ErrTrap

'-------------------Excel Add----------------

Set WrkApp = CreateObject("Excel.application&quot
Set Wrkbknew = WrkApp.Workbooks.Add

'Wrkbknew.Application.Visible = True

'----------****************** LOOP ***************************

LpC = 1
i = 1

Do Until LpC = UBound(chkd) + 1
Set WrkShtNew = Wrkbknew.Worksheets.Add
WrkShtNew.Name = chkd(LpC)

'--****-----Call Functions for SQL
sTrsQl = pfunWhAtSqL(chkd(LpC), ChkId)
IntCo = pfunWhAtcolumns(chkd(LpC))
'--****----------------------------

'---** Connect TO Data **------------------
psubUserConnect
Set rst = objUserConnection.Execute(sTrsQl)

'--**POPULATE NEW SHEET WITH DATA FROM RST **____________
Do Until rst.EOF = True

Wrkbknew.Sheets(chkd(LpC)).Cells(i, 1) = rst.Fields(2)
Wrkbknew.Sheets(chkd(LpC)).Cells(i, 2) = 0 + rst.Fields(IntCo)

i = i + 1

rst.MoveNext
Loop
'------------------

'**** CREATE CHART ****----------------


If i > 1 Then

Set ChtNew = Wrkbknew.Charts.Add

strb = "B1:B" & i
strc = "!R1C1:R " & i & "C1"

With ChtNew
.ChartType = xlColumnClustered
.SetSourceData Source:=Sheets(chkd(LpC)).Range(strb), PlotBy:=xlColumns
.Location WHERE:=xlLocationAsObject, Name:=chkd(LpC)
End With

End If

'----********** Clear Up
Set WrkShtNew = Nothing
Set ChtNew = Nothing

sTrsQl = ""
IntCo = 0
strb = ""
strc = ""
i = 1
psubUserDisconnect

'=--------Loop counter increase

LpC = LpC + 1

Loop


Dim FilNm As String
Dim rndIn As Integer

Randomize
rndIn = Int((6 * Rnd) + 1)


FilNm = "C:\temp\da" & rndIn & ".xls"



Wrkbknew.SaveAs FileName:=FilNm
Wrkbknew.Close


Set WrkShtNew = Nothing
Set ChtNew = Nothing

sTrsQl = ""
IntCo = 0
strb = ""
strc = ""
psubUserDisconnect


WrkApp.Quit

Set WrkApp = Nothing
Set Wrkbknew = Nothing

Debug.Print "closed"

pfunCreatEGraphs = FilNm

Exit Function

ErrTrap:
'----------------------------------------------
Select Case Err.Number
Case 1044
Resume Next
Case Else
MsgBox Err.Description
Resume Next

End Select



End Function


Public Function GetdatAfromExcel(pPf As Presentation, chkd(), flPath As String)
Dim WrkApp As Excel.Application
Dim Wrkbk As Workbook
Dim WrkSht As Worksheet
Dim ChtEx As Chart
Dim Pnew As Slide
Dim X, y As Integer
Set WrkApp = CreateObject("Excel.application&quot
Set Wrkbk = WrkApp.Workbooks.Open(flPath)

'MsgBox Wrkbk.Name

For Each WrkSht In Wrkbk.Worksheets

Do Until y = UBound(chkd) + 1
If WrkSht.Name = chkd Then

Dim a
Dim b As String

Set a = WrkSht.Cells.SpecialCells(xlCellTypeLastCell)
b = a.Address(ReferenceStyle:=xlR1C1)
b = Left(b, Len(b) - 1)
b = b & "1"
b = "R1C1:" & b


If WrkSht.ChartObjects.Count > 0 Then

For Each Var In WrkSht.ChartObjects



With WrkSht.ChartObjects(Var.Index).Chart
.HasLegend = False
.ChartArea.Border.LineStyle = 0
'-***************************

With .Axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Risk Allocation (Bp)"

End With

With .Axes(xlCategory)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
' .Height = 10000
With .Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With

.PlotArea.Interior.ColorIndex = xlNone
.PlotArea.Border.LineStyle = xlNone
.SeriesCollection(1).XValues = "='" & WrkSht.Name & "'!" & b & ""

' .GapWidth = 10
With .Axes(xlCategory)
.TickLabelSpacing = 1
.TickLabels.AutoScaleFont = False
With .TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
With .TickLabels
.Alignment = xlCenter
.Offset = 100
.Orientation = xlUpward
End With
End With


With .Axes(xlValue)
.MinimumScaleIsAuto = True
.MaximumScaleIsAuto = True
.MinorUnitIsAuto = True
.MajorUnit = 1
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone

.TickLabels.AutoScaleFont = False
With .TickLabels.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
End With

'-***************************
End With

WrkSht.ChartObjects(Var.Index).Height = 319
WrkSht.ChartObjects(Var.Index).Width = 692

'----****************
WrkSht.ChartObjects(Var.Index).Chart.ChartGroups(1).GapWidth = 50
WrkSht.ChartObjects(Var.Index).Chart.SeriesCollection(1).Interior.ColorIndex = 37

X = pPf.Slides.Count + 1

Set Pnew = pPf.Slides.Add(X, ppLayoutBlank)
Pnew.Shapes.AddTextbox(msoTextOrientationHorizontal, _
12, 18, 600, 36).TextFrame.TextRange.Text = WrkSht.Name



WrkSht.ChartObjects(Var.Index).CopyPicture

Pnew.Shapes.Paste
With Pnew.Shapes(2)
.Height = 319
.Width = 692
.Left = 41
.Top = 127

End With

Pnew.Name = WrkSht.Name


Next

End If
'
End If
y = y + 1

Loop

y = 1

Next




Wrkbk.Save
Wrkbk.Close
'

WrkApp.Application.Quit

Set Wrkbk = Nothing


End Function

 

[Chance1234]

ok running through it a bit mroe the second module is fine, but the first module doesnt seem to close excel


ive simplified module one here and it works but doesnt work full any ideas ?

Sub deletemetest()


Dim WrkApp As Excel.Application
Dim Wrkbknew As Workbook
Dim WrkShtNew As Worksheet

Dim IntCo As Integer
Dim LpC As Integer



'-------------------Excel Add----------------

Set WrkApp = CreateObject("Excel.application&quot
Set Wrkbknew = WrkApp.Workbooks.Add

'Wrkbknew.Application.Visible = True

'----------****************** LOOP ***************************

For LpC = 1 To 20
Set WrkShtNew = Wrkbknew.Worksheets.Add
WrkShtNew.Name = LpC
Next


Dim FilNm As String
Dim rndIn As Integer

Randomize
rndIn = Int((20 * Rnd) + 1)


FilNm = "C:\temp\da" & rndIn & ".xls"



Wrkbknew.SaveAs FileName:=FilNm
Wrkbknew.Close
WrkApp.Quit

End Sub