Running out of memory when adding logos to reports
 

I am running Excel 2000 on XP. I have scripts that pull data from a
database and turn them into a number of reports. Each report is
supposed to have our logo and the client's logo. I have the logos on
a sheet in the excel book.

After each sheet is formatted I call a routine to put the logos on.
(see code below)

A single run of formatting creates something in the neighborhood of
160 sheets in 47 books. If I remove adding the logos everything works
fine. Infact I reran the formating so many times that I was opening
"Book 423" withought error. If the adding logos in included the
process gets through about 35 sheets and then I get an error on a line
that says "cannot set the PrintTitleColumns field" and points to the
line :"ActiveSheet.PageSetup.PrintTitleColumns = """ Obviousely this
line is NOT the problem.

Here is how I am adding the logos. Is there a better way? Am I
missing something in here?

Sub addLogo(lastcol As Integer)

Dim left As Integer
Dim top As Integer
Dim height As Integer
Dim width As Integer
Dim hscale As Double
Dim vscale As Double
Dim fscale As Double

Sheets("Logos").Shapes("MyLogo").Copy
With Range(Cells(1, lastcol - 2), Cells(4, lastcol))
left = .left
top = .top
height = .height
width = .width
End With

Range(Cells(1, lastcol - 2), Cells(4, lastcol)).PasteSpecial
Selection.Name = "MyLogo"
vscale = width / ActiveSheet.Shapes.Range("MyLogo").width
hscale = height / ActiveSheet.Shapes.Range("MyLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("MyLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("MyLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("MyLogo").left = (left + width) -
ActiveSheet.Shapes.Range("MyLogo").width - 5
ActiveSheet.Shapes.Range("MyLogo").top = top

Sheets("Logos").Shapes("ClientLogo").Copy
With Range(Cells(1, 1), Cells(4, 3))
left = .left
top = .top
height = .height
width = .width
End With
Range(Cells(1, 1), Cells(4, 3)).PasteSpecial
Selection.Name = "ClientLogo"
vscale = width / ActiveSheet.Shapes.Range("ClientLogo").width
hscale = height / ActiveSheet.Shapes.Range("ClientLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("ClientLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("ClientLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("ClientLogo").left = left + 5
ActiveSheet.Shapes.Range("ClientLogo").top = top

End Sub

Running out of memory when adding logos to reports
 

Maybe a solution is to add the logo in the Worksheet_Activate event and
remove it in the Worksheet_Deactivate event.
So, there is only one logo at any one time.

RBS


wrote in message
oups.com...
I am running Excel 2000 on XP. I have scripts that pull data from a
database and turn them into a number of reports. Each report is
supposed to have our logo and the client's logo. I have the logos on
a sheet in the excel book.

After each sheet is formatted I call a routine to put the logos on.
(see code below)

A single run of formatting creates something in the neighborhood of
160 sheets in 47 books. If I remove adding the logos everything works
fine. Infact I reran the formating so many times that I was opening
"Book 423" withought error. If the adding logos in included the
process gets through about 35 sheets and then I get an error on a line
that says "cannot set the PrintTitleColumns field" and points to the
line :"ActiveSheet.PageSetup.PrintTitleColumns = """ Obviousely this
line is NOT the problem.

Here is how I am adding the logos. Is there a better way? Am I
missing something in here?

Sub addLogo(lastcol As Integer)

Dim left As Integer
Dim top As Integer
Dim height As Integer
Dim width As Integer
Dim hscale As Double
Dim vscale As Double
Dim fscale As Double

Sheets("Logos").Shapes("MyLogo").Copy
With Range(Cells(1, lastcol - 2), Cells(4, lastcol))
left = .left
top = .top
height = .height
width = .width
End With

Range(Cells(1, lastcol - 2), Cells(4, lastcol)).PasteSpecial
Selection.Name = "MyLogo"
vscale = width / ActiveSheet.Shapes.Range("MyLogo").width
hscale = height / ActiveSheet.Shapes.Range("MyLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("MyLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("MyLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("MyLogo").left = (left + width) -
ActiveSheet.Shapes.Range("MyLogo").width - 5
ActiveSheet.Shapes.Range("MyLogo").top = top

Sheets("Logos").Shapes("ClientLogo").Copy
With Range(Cells(1, 1), Cells(4, 3))
left = .left
top = .top
height = .height
width = .width
End With
Range(Cells(1, 1), Cells(4, 3)).PasteSpecial
Selection.Name = "ClientLogo"
vscale = width / ActiveSheet.Shapes.Range("ClientLogo").width
hscale = height / ActiveSheet.Shapes.Range("ClientLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("ClientLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("ClientLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("ClientLogo").left = left + 5
ActiveSheet.Shapes.Range("ClientLogo").top = top

End Sub

Running out of memory when adding logos to reports
 

Some things to try/note...

1. Use CopyPicture instead of Copy
2. Use Paste instead of PasteSpecial
3. Have the original logos already sized so the code doesn't have to do it.
4. Don't use variables with names that Excel already uses...
"width,height,left, right"
5. The size/placement dimensions are in points (Long not Integer).
6. If you have to size them use what's there...
(who cares if the size differs slightly)
With ActiveSheet.Shapes(1)
.Width = ActiveSheet.Range(xx).Width
.Left = ActiveSheet.Range(xx).Left
End With
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
I am running Excel 2000 on XP. I have scripts that pull data from a
database and turn them into a number of reports. Each report is
supposed to have our logo and the client's logo. I have the logos on
a sheet in the excel book.

After each sheet is formatted I call a routine to put the logos on.
(see code below)

A single run of formatting creates something in the neighborhood of
160 sheets in 47 books. If I remove adding the logos everything works
fine. Infact I reran the formating so many times that I was opening
"Book 423" withought error. If the adding logos in included the
process gets through about 35 sheets and then I get an error on a line
that says "cannot set the PrintTitleColumns field" and points to the
line :"ActiveSheet.PageSetup.PrintTitleColumns = """ Obviousely this
line is NOT the problem.

Here is how I am adding the logos. Is there a better way? Am I
missing something in here?

Sub addLogo(lastcol As Integer)

Dim left As Integer
Dim top As Integer
Dim height As Integer
Dim width As Integer
Dim hscale As Double
Dim vscale As Double
Dim fscale As Double

Sheets("Logos").Shapes("MyLogo").Copy
With Range(Cells(1, lastcol - 2), Cells(4, lastcol))
left = .left
top = .top
height = .height
width = .width
End With

Range(Cells(1, lastcol - 2), Cells(4, lastcol)).PasteSpecial
Selection.Name = "MyLogo"
vscale = width / ActiveSheet.Shapes.Range("MyLogo").width
hscale = height / ActiveSheet.Shapes.Range("MyLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("MyLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("MyLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("MyLogo").left = (left + width) -
ActiveSheet.Shapes.Range("MyLogo").width - 5
ActiveSheet.Shapes.Range("MyLogo").top = top

Sheets("Logos").Shapes("ClientLogo").Copy
With Range(Cells(1, 1), Cells(4, 3))
left = .left
top = .top
height = .height
width = .width
End With
Range(Cells(1, 1), Cells(4, 3)).PasteSpecial
Selection.Name = "ClientLogo"
vscale = width / ActiveSheet.Shapes.Range("ClientLogo").width
hscale = height / ActiveSheet.Shapes.Range("ClientLogo").height

fscale = 1
If (hscale <= vscale And hscale < 1) Then
fscale = hscale
ElseIf (vscale < hscale And vscale < 1) Then
fscale = vscale
End If

ActiveSheet.Shapes.Range("ClientLogo").ScaleWidth fscale, msoFalse,
msoScaleFromBottomRight
ActiveSheet.Shapes.Range("ClientLogo").ScaleHeight fscale, msoFalse,
msoScaleFromTopLeft
ActiveSheet.Shapes.Range("ClientLogo").left = left + 5
ActiveSheet.Shapes.Range("ClientLogo").top = top

End Sub