Adding shapes to worksheet

Hi,
I have the following code

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCells
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    Set p = Nothing

End Sub

This works just fine.  However, If I add more than one shape to a sheet, 
then subsequently delete a shape using the code below, other shapes on the 
same worksheet move a little.

Sub DeletePicture(TargetCells As Range)
Dim pict As Object
Dim t As Double
Dim l As Double

Application.ScreenUpdating = False
    ' determine positions
    With TargetCells
        t = .Top
        l = .Left
    End With

    For Each pict In ActiveSheet.Shapes
        On Error Resume Next
        pict.Select
        If Round(pict.Left, 2) = Round(l, 2) And Round(pict.Top, 2) = 
Round(t, 2) Then
            pict.Delete
        End If
    Next
   
   Application.ScreenUpdating = True
   
End Sub

Any suggestions to improve the code, so that each shape is "locked in place" 
when it is added ?

Thanks in advance.
0
Utf
11/26/2009 5:20:01 AM
excel.programming 6508 articles. 2 followers. Follow

4 Replies
535 Views

Similar Articles

[PageSpeed] 31

Try maximize your excel window and the spreadsheet inside of excel. 
Your code isn't moving anything so I think the actual window is
resizing.


-- 
joel
------------------------------------------------------------------------
joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=157392

[url=&quot;http://www.thecodecage.com&quot;]Microsoft Office Help[/url]

0
joel
11/26/2009 9:06:58 AM
No need to Select your pictures. Here's a different approach -

Sub DeletePicture2(TargetCells As Range)
Dim pic As Picture

For Each pic In ActiveSheet.Pictures
    If Not Intersect(TargetCells, pic.TopLeftCell) Is Nothing Then
        pic.Delete
    End If
Next

End Sub

If You want to delete all shapes whose topLeftCell is in the target change 
'As Picture' to As Shape' and 'ActiveSheet.Pictures' to 'ActiveSheet.Shapes'

Regards,
Peter T


"Gary B" <GaryB@discussions.microsoft.com> wrote in message 
news:7B8D6CEB-07F6-4301-A4D2-043B46F8ECD6@microsoft.com...
> Hi,
> I have the following code
>
> Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
> ' inserts a picture and resizes it to fit the TargetCells range
> Dim p As Object, t As Double, l As Double, w As Double, h As Double
>    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
>    If Dir(PictureFileName) = "" Then Exit Sub
>    ' import picture
>    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
>    ' determine positions
>    With TargetCells
>        t = .Top
>        l = .Left
>        w = .Offset(0, .Columns.Count).Left - .Left
>        h = .Offset(.Rows.Count, 0).Top - .Top
>    End With
>    ' position picture
>    With p
>        .Top = t
>        .Left = l
>        .Width = w
>        .Height = h
>    End With
>    Set p = Nothing
>
> End Sub
>
> This works just fine.  However, If I add more than one shape to a sheet,
> then subsequently delete a shape using the code below, other shapes on the
> same worksheet move a little.
>
> Sub DeletePicture(TargetCells As Range)
> Dim pict As Object
> Dim t As Double
> Dim l As Double
>
> Application.ScreenUpdating = False
>    ' determine positions
>    With TargetCells
>        t = .Top
>        l = .Left
>    End With
>
>    For Each pict In ActiveSheet.Shapes
>        On Error Resume Next
>        pict.Select
>        If Round(pict.Left, 2) = Round(l, 2) And Round(pict.Top, 2) =
> Round(t, 2) Then
>            pict.Delete
>        End If
>    Next
>
>   Application.ScreenUpdating = True
>
> End Sub
>
> Any suggestions to improve the code, so that each shape is "locked in 
> place"
> when it is added ?
>
> Thanks in advance. 


0
Peter
11/26/2009 9:26:11 AM
Thanks for that.

Your code did not delete my shape, but I did remove my line that was 
selecting the shape before deletion.  That has worked a treat - simply don't 
select the shape.

Your guidance was most helpful.


"Peter T" wrote:

> No need to Select your pictures. Here's a different approach -
> 
> Sub DeletePicture2(TargetCells As Range)
> Dim pic As Picture
> 
> For Each pic In ActiveSheet.Pictures
>     If Not Intersect(TargetCells, pic.TopLeftCell) Is Nothing Then
>         pic.Delete
>     End If
> Next
> 
> End Sub
> 
> If You want to delete all shapes whose topLeftCell is in the target change 
> 'As Picture' to As Shape' and 'ActiveSheet.Pictures' to 'ActiveSheet.Shapes'
> 
> Regards,
> Peter T
> 
> 
> "Gary B" <GaryB@discussions.microsoft.com> wrote in message 
> news:7B8D6CEB-07F6-4301-A4D2-043B46F8ECD6@microsoft.com...
> > Hi,
> > I have the following code
> >
> > Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
> > ' inserts a picture and resizes it to fit the TargetCells range
> > Dim p As Object, t As Double, l As Double, w As Double, h As Double
> >    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
> >    If Dir(PictureFileName) = "" Then Exit Sub
> >    ' import picture
> >    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
> >    ' determine positions
> >    With TargetCells
> >        t = .Top
> >        l = .Left
> >        w = .Offset(0, .Columns.Count).Left - .Left
> >        h = .Offset(.Rows.Count, 0).Top - .Top
> >    End With
> >    ' position picture
> >    With p
> >        .Top = t
> >        .Left = l
> >        .Width = w
> >        .Height = h
> >    End With
> >    Set p = Nothing
> >
> > End Sub
> >
> > This works just fine.  However, If I add more than one shape to a sheet,
> > then subsequently delete a shape using the code below, other shapes on the
> > same worksheet move a little.
> >
> > Sub DeletePicture(TargetCells As Range)
> > Dim pict As Object
> > Dim t As Double
> > Dim l As Double
> >
> > Application.ScreenUpdating = False
> >    ' determine positions
> >    With TargetCells
> >        t = .Top
> >        l = .Left
> >    End With
> >
> >    For Each pict In ActiveSheet.Shapes
> >        On Error Resume Next
> >        pict.Select
> >        If Round(pict.Left, 2) = Round(l, 2) And Round(pict.Top, 2) =
> > Round(t, 2) Then
> >            pict.Delete
> >        End If
> >    Next
> >
> >   Application.ScreenUpdating = True
> >
> > End Sub
> >
> > Any suggestions to improve the code, so that each shape is "locked in 
> > place"
> > when it is added ?
> >
> > Thanks in advance. 
> 
> 
> .
> 
0
Utf
12/8/2009 1:51:01 AM
I just tested the code as posted and it should delete any or all Pictures 
whose topLeftCell is within the target range "TargetCells". Not sure why it 
doesn't for you, no matter, glad you got it working for your needs.

Regards,
Peter T

"Gary B" <GaryB@discussions.microsoft.com> wrote in message 
news:D25DF480-6CEA-43D3-91C9-DF9BA05C0855@microsoft.com...
> Thanks for that.
>
> Your code did not delete my shape, but I did remove my line that was
> selecting the shape before deletion.  That has worked a treat - simply 
> don't
> select the shape.
>
> Your guidance was most helpful.
>
>
> "Peter T" wrote:
>
>> No need to Select your pictures. Here's a different approach -
>>
>> Sub DeletePicture2(TargetCells As Range)
>> Dim pic As Picture
>>
>> For Each pic In ActiveSheet.Pictures
>>     If Not Intersect(TargetCells, pic.TopLeftCell) Is Nothing Then
>>         pic.Delete
>>     End If
>> Next
>>
>> End Sub
>>
>> If You want to delete all shapes whose topLeftCell is in the target 
>> change
>> 'As Picture' to As Shape' and 'ActiveSheet.Pictures' to 
>> 'ActiveSheet.Shapes'
>>
>> Regards,
>> Peter T
>>
>>
>> "Gary B" <GaryB@discussions.microsoft.com> wrote in message
>> news:7B8D6CEB-07F6-4301-A4D2-043B46F8ECD6@microsoft.com...
>> > Hi,
>> > I have the following code
>> >
>> > Sub InsertPictureInRange(PictureFileName As String, TargetCells As 
>> > Range)
>> > ' inserts a picture and resizes it to fit the TargetCells range
>> > Dim p As Object, t As Double, l As Double, w As Double, h As Double
>> >    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
>> >    If Dir(PictureFileName) = "" Then Exit Sub
>> >    ' import picture
>> >    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
>> >    ' determine positions
>> >    With TargetCells
>> >        t = .Top
>> >        l = .Left
>> >        w = .Offset(0, .Columns.Count).Left - .Left
>> >        h = .Offset(.Rows.Count, 0).Top - .Top
>> >    End With
>> >    ' position picture
>> >    With p
>> >        .Top = t
>> >        .Left = l
>> >        .Width = w
>> >        .Height = h
>> >    End With
>> >    Set p = Nothing
>> >
>> > End Sub
>> >
>> > This works just fine.  However, If I add more than one shape to a 
>> > sheet,
>> > then subsequently delete a shape using the code below, other shapes on 
>> > the
>> > same worksheet move a little.
>> >
>> > Sub DeletePicture(TargetCells As Range)
>> > Dim pict As Object
>> > Dim t As Double
>> > Dim l As Double
>> >
>> > Application.ScreenUpdating = False
>> >    ' determine positions
>> >    With TargetCells
>> >        t = .Top
>> >        l = .Left
>> >    End With
>> >
>> >    For Each pict In ActiveSheet.Shapes
>> >        On Error Resume Next
>> >        pict.Select
>> >        If Round(pict.Left, 2) = Round(l, 2) And Round(pict.Top, 2) =
>> > Round(t, 2) Then
>> >            pict.Delete
>> >        End If
>> >    Next
>> >
>> >   Application.ScreenUpdating = True
>> >
>> > End Sub
>> >
>> > Any suggestions to improve the code, so that each shape is "locked in
>> > place"
>> > when it is added ?
>> >
>> > Thanks in advance.
>>
>>
>> .
>> 


0
Peter
12/8/2009 7:54:24 AM
Reply:

Similar Artilces:

changing the depth of 3d shapes
In Ecel 2003 the 3D shapes provided for the shape to appear smaller at the far end, creating a more true 3D effect. In 2007 it would seem this ability is no longer available, or is it? If not, it's a step backward (in my humble opinion) Zagrijs Venter ...

Adding hyperlinks with parameters
Hey everybody I have a batch file which needs to be run from an excel sheet with a parameter, like this: c:\1.bat myParameter But when i try to run the Hyperlink, the Excel shows an error message saying it can't open the specified file (probably because the is a space between the file and the parameter) is there any known way to run the link from the excel? On Mar 2, 12:45=A0pm, Pasha <pavel_v...@mailto.mod.gov.il> wrote: > Hey everybody > I have a batch file which needs to be run from an excel sheet with a > parameter, like this: > c:\1.bat myParameter > But when i ...

Adding Blank Rows after the last Detail of the Report
Hi All, I've used this code from Dwayne: Private Sub Report_Page() Dim intNumLines As Integer Dim intLineNumber As Integer Dim intTopMargin As Integer Dim ctl As Control Dim intLineHeight As Integer intNumLines = 12 intTopMargin = Me.Section(3).Height intLineHeight = Me.Section(0).Height For Each ctl In Me.Section(0).Controls For intLineNumber = 0 To intNumLines - 1 Me.Line (ctl.Left, intTopMargin + _ (intLineNumber * intLineHeight)) - _ Step(ctl.Width, intLineHeight), , B Next Next End Sub My report needs to print blank rows (at least...

401 times out on sending worksheet mssg to headquarters
Doing a 401 and backdating to beginning of year to get these records from store db (the store db was originally QS2000 and upgrade to 2.0 was done; 101 sync with HQ was done as well and both were successful); the test database connection on both server and client are successful, and 401 without backdating processes OK but the backdated 401 hangs at the end, after uploading store data to HQ is successful, then Sending Worksheet message to headquarters is the task that hangs and times out after an hour; upload bandwidth isn't the best, this may be the reason? Is there a KB or section...

SumIf across multiple worksheets
I have 13 worksheets I want to sum quarterly. The formula I've been trying is: =SUMIF(A5:A36,"136982",'Apr 4:Jun 27'!G5:G36) but I get a #Value! error message. In column A I have contract numbers. In column G is the crew size. I want to sum all the crew size based on specific contract numbers. Any help is appreciated :) In each of the other worksheet, are the contact numbers also in column A? best wishes -- Bernard Liengme Microsoft Excel MVP http://people.stfx.ca/bliengme "Alberta Rose" <AlbertaRose@discussions.microsoft.com>...

Pictures are sent to stores within worksheet 250
I think it would be a good idea that item pictures are sent to the stores within the 250 worksheet (In a HQ enviroment) The procedure would be: Place the picture in the pictures folder in the hq directory Create the item in hq and assign the picture to the item Create a 250 worksheet containing the item The item is then created in the remote store database and the picture is placed in the pictures folder in the store operations directory at the remote store You can then share the pictures directory at the remote store and map a drive on all the tills to that folder and assign the net...

Sum up statistical results from 12 worksheets
I have 12 worksheets of certain data, that is one worksheet for every month of the year (i.e. Jan-Dec). In each worksheet/month I have already calculated the following functions/formulae: SUM MIN MAX AVERAGE STDEV Data above the AVERAGE (e.g. =COUNTIF(W5:W64,">"&W68)) Data below the AVERAGE (e.g. =ABS(COUNTIF(W5:W64,">"&W68)-COUNTIF(W5:W64,">0")) So, I now have this 13th spreadsheet that lists the results from the 12 worksheets/months. For example: Row C1:N1 Jan Feb Mar .... Dec lists the individual results from SUM Row C2:N2 Jan Feb Mar .....

outlook vcard, ad integration user properties
my boss is trying to get hix fax# in his vcard. he is using his address from the global address list I have modified his profile in active directory users and computers: I go into AD users and computers, double click on his user, go to the telephones tab, and enter his fax #. but when I did this his fax # is still not being pulled up in his outlook vcard. Does anyone know where outlook is trying to get this field from / how i can get this field into his vcard? thx ...

Is there an "Execute" worksheet function?
Is there a way I can get Excel to "execute" an expression that is stored in a cell as a test string? Say C4 contains "3+4". Can I put some expression in C5 that will execute that expression and result in "7"? I tried =calculate(C4) and a few other things, but no joy. in the absence of putting = in front of c4, try this =LEFT(C4,FIND("+",C4)-1)+RIGHT(C4,LEN(C4)-FIND("+",C4)) -- Don Guillett Excel MVP SalesAid Software dguillett1@austin.rr.com "LurfysMa" <invalid@invalid.invalid> wrote in message news:o5fn83thi0g5tivf55abvhv...

ADDING A NUMBER
how do i add a number to a range of cells? I need to add 11.27 to a number of different cells each with a different number in them Put 11.27 in an empty cell, format it the same way as the numbers you want to add to, copy it, then select the numbers you want to add to and do edit>paste special and select add. -- Regards, Peo Sjoblom "Helpme" <Helpme@discussions.microsoft.com> wrote in message news:6D51344A-78E6-4377-B292-FC6C16FF6BA2@microsoft.com... > how do i add a number to a range of cells? I need to add 11.27 to a > number > of different cells e...

adding new records
I am totally new to CRM, so I hope this is really easy question: This concerns permissions.. I have a "sales" group, and with one of those people i need to be able to let them add new records on behalf of other "sales" people. Is there like a standard permission setting for it? (obviously every "sales" person can add new records if they select them selfs as the owner) thanks, Michal. Hi, By default the person who creates the record will be the owner. After record creation the person could reassign the record (manually) to another user. If all rec...

When adding attachments...
....in Outlook the following errors comes up: "Out of memory or system resources, please close some programs and try again" Quotas are fine. I have deinstalled/reinstalled Office, cleaned 'temp' areas, and many other tidbits. Any other ideas? Thanks. This might help as i had this problem with Outlook 98. Is the file you are trying to copy to attach nested in sub folders? if so try and copy the attachment to a root drive like c:\ Ignore previous email. wrong spellin if the attachment is nested in sub folders(this means you have to open different folders to get to ...

Picture Disappears When Added To Contact In Outlook 2003
Can someone help please. When I try to attach a picture to a contact in outlook 2003 immediately I double click the picture to be attached it disappears out of the outlook contact along with the placement holder in the form. Only when I right click the mouse and go remove picture do I get the placement holder back. I have looked at all the help menus but they offer no clues. Thanks TS ...

create a new worksheet when a cell has a date entered
I am trying to create a new worksheet when a cell has a date entered into it For instant in Worksheet 1 you type into cell B11 a date I would like to automaticly create a new worksheet and call it that date entered to B11 Then if I type a Date into cell B12 a new worksheet would be created and named the date entered into B12 and so on Is this out of the question See response in your other post. "Zane" wrote: > I am trying to create a new worksheet when a cell has a date entered > into it > > For instant in Worksheet 1 you type into cell B11 a date > I would l...

Adding ActiveX to dialog with wrapper
When I add an ActiveX object to a dialog using the dialog editor - right click - insert activeX object, the help on the resulting activex selection tool states that a wrapper will not be added by using this method. If you need a wrapper, it suggests using the class view. This is using Visual Studio 2005. I'm having some problems with this on an existing project. To make sure I understand the process, I created a new MFC project, added a dialog, created a class for that dialog and added a Flexgrid object using the right click method in the dialog. I then added a variable for the flexgrid...

Using xlsm worksheets on different computers
So I just creaed the greatest spreadsheet ever with lots of Visual Basic and Macro buttons that makes it a dream for the user to use. A startup macro opens at the Menu page, lots of hyperlinks to various worksheets, lots of macro buttons, tabs hidden, VB password protected, hidden worksheets, an expiry date on the workbook which inhibits further use after a certain date etc.... You get the idea. I digitally signed it and installed it on the computer where it will be used. At the end of each week this monthly file is emailed to a number of managers, and I soon realised the frui...

Adding alternate columns
I work on a schedule where I record ticket count and ticket sales for each show, listed chronologically. Column A = week ending date Column B = # Tickets sold for April 5 show Column C = Ticket Revenue for April 5 show Column D = # Tickets sold for April 9 show Column E = Ticket Revenue for April 9 show Column F = # Tickets sold for April 12 show Column G = Ticket Revenue for April 12 show Column H = Total # Tickets sold for all shows Column I = Total Ticket Revenue for all shows In the Totals columns, the Total Tickets formula is "+B4+D4+F4", and the Total Revenue f...

Adding fields from a different query
I have a form built based on a main query. How do I add more fields on that form that come from a different query? Anne A couple possibilities... Change your first query to include the extra fields. Use your second query to "feed" a form, then embed that form as a subform on your main form. Good luck! Regards Jeff Boyce Microsoft Access MVP -- Disclaimer: This author may have received products and services mentioned in this post. Mention and/or description of a product or service herein does not constitute endorsement thereof. Any code or pseudoco...

Adding more than three Conditions to 'Conditional Formatting'
Can i add more than three conditions to the conditional formatting presets using code? Regards [Riz] -- Rizitsu ------------------------------------------------------------------------ Rizitsu's Profile: http://www.excelforum.com/member.php?action=getinfo&userid=15840 View this thread: http://www.excelforum.com/showthread.php?threadid=320382 Riz, as you have found out, only 3 conditions with conditional formatting. But yes you can use some code to get more than 3, try this it will change the cell color in column A when you put in one ,two, three, or four, right click on the she...

linking multiple worksheets
I know this is possible because we have a document at work that does this -- just can't figure out how: I have multilple worksheets in a workbook and I want to merge the data on to one worksheet so that the numbers add up and so that the summary page is linked to each worksheet -- changes are made in individual worksheets. I can see the cell formula, but know there is a quicker way to do this than typing in formulas for each cell. All of the worksheets are identical. Thanks. ------------------------------------------------ ~~ Message posted from http://www.ExcelTip.com/ ~~ View and ...

Insert Comments on a Protected Worksheet
hi - I have a worksheet with areas that are locked, and a range B5:H23 that is not locked. Protection has been applied to the sheet. The user is allowed to SELECT unlocked cells. My problem is that I want to be able to INSERT COMMENTS in the unlocked range. I can't seem to do this while protection is ON. (Comments can only be added when Protection is OFF) What am I missing? thanks in advance -- cinnie When setting sheet protection allow users to "Edit Objects"........down near bottom of list. Then you can Insert Comments in unlocked cells. Gord ...

Delimiter for adding Appointment in Entourage
Version: 2008 Operating System: Mac OS X 10.5 (Leopard) Processor: Power PC Email Client: Exchange What's the delimiter that Entourage uses if I want to add an appointment and the subject needs to be parsed by the Exchange server? <br><br>In Outlook, the hash/pound key (#) is used as delimiter. How about in Entourage 2008? <br><br>Basically, if I add an entry in a group calendar Out-Of-Office with the subject: #User1# On-Leave <br><br>in Outlook, this entry appears in the group calendar Out-Of-Office and also in User1's personal calendar. <...

Adding Terms & Conditions to the Quote Form
We have a client that would like to add their Terms & Conditions (T&C) text to the bottom of their GP Quotes. I've read that static text boxes in Report Designer can only be 80 characters, so that won't work as the T&C text is approximately 4-5 pages long. Does anyone have any suggestions on how to add this significant amount of text to a GP form? Thank you in advance. Scott No can do Scott - Report Writer is just not capable of this. The best solution is to purchase Accountable Software's Forms Printer - www.accountable.com. Frank Hamelly MCP-GP, MCT, MVP East...

Downloaded payees automatically added to payee list
Please tell me that in Money 2006, Microsoft has finally fixed the bug where the payees in my downloaded transactions are automatically added to my payee list (this despite the fact that I've checked off the option "Confirm new payees"). This alone would be worth the upgrade. On the subject of 2006, does anyone know if Microsoft added the cookie jar concept to accounts? The cookie jar allows you to squirrel money away within an account. TIA greg.block@gmail.com wrote: >Please tell me that in Money 2006, Microsoft has finally fixed the bug >where the payees in my downlo...

AD Monitoring
Is there a listing somewhere of what all components in AD should be minitored, thresholds, etc...we are evaluating a monitoring solution and need this information to take a decision on the product to use Hello Sameer, For performance start here: http://technet.microsoft.com/en-us/library/cc961943.aspx Also see: http://technet.microsoft.com/en-us/library/bb727046.aspx Use the included links from: http://technet.microsoft.com/en-us/library/cc739728(WS.10).aspx Best regards Meinolf Weber Disclaimer: This posting is provided "AS IS" with no warranties, and c...