Generating a drawing based on a cell Value (Repost Attempt)

[cool5abi]

I have an Excel workbook which places a picture in cell C5 based on a
drawing number in E56. Although my formula skills are pretty good, my
VBA
isn't. After much Googling the newsgroups I found the following code
(changed to suit my needs):

Sub test()
Dim s As String, i As Integer
s = "S:\Engineering\Drawings\Drawing Generator\Images"
ActiveSheet.Range("C5").Select
With Application.FileSearch
..NewSearch
..LookIn = s
..SearchSubFolders = False
..Filename = "*" & ActiveSheet.Range("E56") & ".EMF"
..MatchTextExactly = True
..Execute
For i = 1 To .FoundFiles.Count
ActiveSheet.DrawingObjects.Delete
ActiveSheet.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
End Sub

This works quite well...except for a couple nagging things that I can't
seem
to get a grasp of.

1. Our logo in B57 disappears everytime the above macro is executed. It

seems as if before the drawing is placed in C5, the screen refreshes.
The
only thing that I can see would be "ActiveSheet.DrawingObjects.Delete".
If
this is correct, how would I go about revising the code? I only want it
to
delete the picture in C5, but keep the logo in B57.

2. The macro is called "sheet10.test", I've made a hotkey (CTRL+d) to
run
the macro but would much rather have a button. Using the "Button"
command in
the Forms Toolbar, I made a button which works fine...once, then it
disappears. I think this is normal for the method I used to create the
button, but is there any way to keep the button on the screen for
additional
use, (i.e. generating a different drawing)?

Correcting the above two problems are of most importance. Soon after, I

would like to rename the macro "Generate Drawing" from "sheet10.test"
just
to keep things clean and simple. I would also like to create an error
message if the drawing does not exist in the folder it is searching in.

However, as mentioned above, items 1 and 2 are where I could use
immediate
assistance, any help would be greatly appreciated.


Many Thanks to a group which has already been alot of help!
Romy

 

[JLGWhiz]

You are correct. The line that deletes drawing objects takes away your logo.
The line does nothing more that clear the worksheet of other drawings so
that the one being added will be the only one in the drawing collection after
it is added. If you delete the line in the code, the drawing being added
will then become Shapes(2) instead of Shapes(1). Your logo will be Shapes(1).

Sub test()
Dim s As String, i As Integer
s = "S:\Engineering\Drawings\Drawing Generator\Images"
ActiveSheet.Range("C5").Select
With Application.FileSearch
...NewSearch
...LookIn = s
...SearchSubFolders = False
...Filename = "*" & ActiveSheet.Range("E56") & ".EMF"
...MatchTextExactly = True
...Execute
For i = 1 To .FoundFiles.Count

ActiveSheet.DrawingObjects.Delete 'You can delete this line and your logo
will stay on the sheet.

ActiveSheet.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
End Sub

As for the buttons, you get one attached macro per button.

 

[Tom Ogilvy]

Put this code in a general module (insert=>Module in the VBE) rather than the
sheet module which your descriptions indicates is its current location.

Sub Generate_Drawing()
Dim s As String, i As Integer, d as Object
s = "S:\Engineering\Drawings\Drawing Generator\Images" & _
Range("E56").Value & ".EMF"

if dir( s) = "" then exit sub
ActiveSheet.Range("C5").Select
for each d in Activesheet.DrawingObjects
if d.TopLeftCell.Address = "$C$5" then
d.Delete
end if
Next
ActiveSheet.Pictures.Insert s
End Sub
Put your button (from the forms toolbar) on the sheet and assign the macro.

 

[cool5abi]

You are correct. The line that deletes drawing objects takes away your logo.
The line does nothing more that clear the worksheet of other drawings so
that the one being added will be the only one in the drawing collection after
it is added. If you delete the line in the code, the drawing being added
will then become Shapes(2) instead of Shapes(1). Your logo will be Shapes(1).

Sub test()
Dim s As String, i As Integer
s = "S:\Engineering\Drawings\Drawing Generator\Images"
ActiveSheet.Range("C5").Select
With Application.FileSearch
..NewSearch
..LookIn = s
..SearchSubFolders = False
..Filename = "*" & ActiveSheet.Range("E56") & ".EMF"
..MatchTextExactly = True
..Execute
For i = 1 To .FoundFiles.Count

ActiveSheet.DrawingObjects.Delete 'You can delete this line and your logo
will stay on the sheet.

ActiveSheet.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
End Sub

As for the buttons, you get one attached macro per button.

Hi JLGWhiz,

Removing that line of code did work, sort of... Although the logo and
button don't disappear anymore, niether does the existing drawing. So
what ends up happening is the new drawing gets placed on top of the old
one. I need some code that will delete C5, but keep the other items
(logo and button). Thinking about this some more, would it be possible
to have the drawing change automatically when the drawing number in E56
changes? Therefore eleminating the button altogether?

Thanks for the help!
Romy

 

[cool5abi]

Put this code in a general module (insert=>Module in the VBE) rather than the
sheet module which your descriptions indicates is its current location.

Sub Generate_Drawing()
Dim s As String, i As Integer, d as Object
s = "S:\Engineering\Drawings\Drawing Generator\Images" & _
Range("E56").Value & ".EMF"

if dir( s) = "" then exit sub
ActiveSheet.Range("C5").Select
for each d in Activesheet.DrawingObjects
if d.TopLeftCell.Address = "$C$5" then
d.Delete
end if
Next
ActiveSheet.Pictures.Insert s
End Sub
Put your button (from the forms toolbar) on the sheet and assign the macro.

Hi Tom,

I tried doing the above but couldn't get anything to work at all. I
deleted the code in the worksheet and added the module as specified.
However, the good news is I used part of your code and merged it into
my existing one.

Sub Generate_Drawing()
Dim s As String, i As Integer, d As Object
s = "S:\Engineering\Drawings\Drawing Generator\Images"
ActiveSheet.Range("C5").Select
For Each d In ActiveSheet.DrawingObjects
If d.TopLeftCell.Address = "$C$5" Then
d.Delete
End If
Next
With Application.FileSearch
..NewSearch
..LookIn = s
..SearchSubFolders = False
..Filename = "*" & ActiveSheet.Range("E56") & ".EMF"
..Execute
For i = 1 To .FoundFiles.Count
ActiveSheet.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
End Sub

This code allows me to delete any existing drawing I had and replace it
with the new one, while still keeping the logo and button. Although it
works, your code seems much more clean and sleek, not knowing anything
about VB, mine looks more cluttered and may have some things in it that
aren't neccessary, any idea if it can be cleaned up?

As mentioned in a previous post, is it possible to eliminate the button
completely and run the macro based on the value of E53 changing? I
tried the method as instructed in another post, but I must have added
or left some stuff out.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$C$3" Then

Would seem to do the trick, but how would I integrate this into my
code?


Thanks again,
Romy

 

[Ken Johnson]

I tried doing the above but couldn't get anything to work at all. I
deleted the code in the worksheet and added the module as specified.
However, the good news is I used part of your code and merged it into
my existing one.

Sub Generate_Drawing()
Dim s As String, i As Integer, d As Object
s = "S:\Engineering\Drawings\Drawing Generator\Images"
ActiveSheet.Range("C5").Select
For Each d In ActiveSheet.DrawingObjects
If d.TopLeftCell.Address = "$C$5" Then
d.Delete
End If
Next
With Application.FileSearch
.NewSearch
.LookIn = s
.SearchSubFolders = False
.Filename = "*" & ActiveSheet.Range("E56") & ".EMF"
.Execute
For i = 1 To .FoundFiles.Count
ActiveSheet.Pictures.Insert (.FoundFiles(i))
Exit For
Next i
End With
End Sub

This code allows me to delete any existing drawing I had and replace it
with the new one, while still keeping the logo and button. Although it
works, your code seems much more clean and sleek, not knowing anything
about VB, mine looks more cluttered and may have some things in it that
aren't neccessary, any idea if it can be cleaned up?

As mentioned in a previous post, is it possible to eliminate the button
completely and run the macro based on the value of E53 changing? I
tried the method as instructed in another post, but I must have added
or left some stuff out.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$C$3" Then

Would seem to do the trick, but how would I integrate this into my
code?

Thanks again,
Romy

Hi Romy,

Does E56 (or is it E53?) change because it is directly edited by the
user or does it contain a formula?

If it is E56 edited by the user then you could use...

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E56")) Is Nothing Then
Generate_Drawing
End If
End Sub

pasted into the worksheets code module (copy code>right click sheet
tab>select "View Code"> Paste the code)

I used Tom's version of Generate_Drawing in a standard code module.

If it is E56 with a formula that recalculates to a new value then
instead of the above code you could use...

Private Sub Worksheet_Calculate()
Generate_Drawing
End Sub

If you use the SelectionChange event you would have to add code to
disable events at the start then enable events at the end to avoid the
code being repeatedly re-fired by the selection change it contains.

Ken Johnson

 

[cool5abi]

Hi Ken, I used your second piece of code and it worked perfectly! The
spreadsheet is so much more functional with just this little change.
Many thanks as you and the other posters have allowed me to finally
finish my project, couldn't have done it without you!


Thanks,
Romy

 

[Ken Johnson]

Hi Ken, I used your second piece of code and it worked perfectly! The
spreadsheet is so much more functional with just this little change.
Many thanks as you and the other posters have allowed me to finally
finish my project, couldn't have done it without you!


Thanks,
Romy

Hi Romy,

It's great to hear you've got it working.
Thanks for the feedback.

Ken Johnson