so I have been searching through this forum for quite a while now, and also on other sites, but I just could not find a way to solve this problem.
So the small problem I got is, that I have a very long Excel Spreadsheet, with many different ID's, or numbers whatever you want to call them. From these ID's I create a custom link, which needs them to direct to a specific image, that is then pasted into a specific cell in this spreadsheet. Note that I really need this code, hence the spreadsheet is about 9300 lines/rows long. The problem now is that not every id has an image attached to it, which means that some links do not work (no image there, but also no text basically an empty page). Is there a way I can just let the code run through it, so that it ignores the error 1004 which is generated, which basically is always telling me he could not find something and will stop at that point.
I am a big noob at VBA, so please when answering do not use to complicated language. I will paste the code below, however the link is confidential, so I will replace the link with "link" or something like that. I tried several On Error methods, but either the error came up again, or Excel crashed, but here is the working code without any modifications to remove this error. Thanks in advance for all the help.
Sub Test()
I = 0
For I = 5 To 9373
If Tabelle2.Cells(I, 9) = "bekannt" Then
Call GetShapeFromWeb("Part 1 of the link" & Tabelle2.Cells(I, 10).Value & "Part 2 of the link", Tabelle2.Cells(I, 13))
End If
Next I
End Sub
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
With rngTarget
With .Parent
.Pictures.Insert strShpUrl 'Error Occurs here
Set shp = .Shapes(.Shapes.count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Set shp = Nothing
End Sub
One last thing to notice, some of the words are german, due to me being german and working with german variables, or links, or spreadsheets. And I am using excel 2007. The Error occurs in the following row ".Pictures.Insert strShpUrl" because it can not find a picture to insert.
Thansk a lot.
Kind Regards
Chris
//EDIT
One Idea I might have, which I dont know if it is possible, but the page it is directed to, when a picture is not there it displays the following "Unable to find /part/of/thelink/"
Could one maybe use a code to see if this message is displayed, and maybe check for that? If so how would that work? :) Maybe it could be added to the if statement at the top which tests already for this sub task.
//EDIT
Anyone got some idea? :S Maybe what I posted above in the edit could work? :S Is it possible to check if a msgbox displays something but the other way around so if the msgbox does not equal the following do this. If that could work it would be great! :S Or maybe instead of trying the on error commands trying it with an if statement within the GetShapeFromWeb sub? Any help is greatly appreciated.
This should work. However you wrote that you tried several On Error Methods unsuccessfully ... what does this one for you?
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
Dim Er As Long: Er = 0
On Error GoTo gswError
With rngTarget
With .Parent
.Pictures.Insert strShpUrl
If Er <> 0 Then Exit Sub
Set shp = .Shapes(.Shapes.Count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Set shp = Nothing
Exit Sub
gswError:
Er = Err
Resume Next
End Sub
have you tried on the GetShapeFromWeb sub, placing the On Error statement this way:
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
Dim shp As Shape
On Error GoTo Err1 'inserting a picture from a blank link will cause an error... thus...
With rngTarget
With .Parent
.Pictures.Insert strShpUrl
Set shp = .Shapes(.Shapes.Count)
End With
shp.Left = .Left
shp.Top = .Top
End With
Err1: '...sidestep
Set shp = Nothing
End Sub
Related
Apologies another noob question. I have been tasked with writing a document within excel, the front cover has a lot of images on it and i have grouped these images together. As there is a risk that the user could move this group. I want to set it so each time that sheet is selected it moves back to its original location. I have looked over the web and i can't seem to find anything for a group of images.
I have tried this and it doesnt work at all. :(
Private Sub Worksheet_Activate()
Dim PicGroup As GroupShapes
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
So my group of images I have called HeaderGrp I have put this on Activate Worksheet in VBA and i want this to always move or fix to cells A1.
I would also love this to fit to the page width and length if anyone knows how to do that.
Snapshot of what i would like: -
1) on sheet selection, image group moves to the correct location.
2) image group auto adjusts to page width and height.
Thank you in advance,
This works for me. Pictures appear to be treated as a type of Shape.
Private Sub Worksheet_Activate()
Dim p As Shape
With activesheet
Set p = .Shapes("Pics") 'name
p.Top = .Range("a1").Top
p.Left = .Range("a1").Left
End With
End Sub
This piece of code should get your grouped images:
Option Explicit
Private Sub Worksheet_Activate()
Dim shp As Shape
Dim PicGroup As GroupShapes
'loop through all your shapes
For Each shp In Me.Shapes
'if the shape is grouped then
'set your PicGroup variable
'and exit the loop
If shp.Type = msoGroup Then
Set PicGroup = shp.GroupItems
Exit For
End If
Next shp
With Range("A1")
PicGroup.Name = "HeaderGrp"
PicGroup.Visible = True
PicGroup.Top = .Top
PicGroup.Left = .Left
End With
End Sub
I would like to delete all the shapes from my sheet. They have the same ID.
I found two codes:
The first one:
Public Sub ActiveShapes()
Dim ShpObject As Variant
If TypeName(Application.Selection) = "Firestop" Then
Set ShpObject = Application.Selection
ShpObject.Delete
Else
Exit Sub
End If
End Sub
is not working. There are no errors, but also no reaction at all.
The second one:
Selecting a shape in Excel with VBA
Sub Firestopshapes()
ActiveSheet.Shapes("Firestop").Delete
End Sub
works, but remove only one by one element. In my event, all the elements have the "Firestop" ID. I would like to make them all deleted at once. How can I do that?
The issue is thet If TypeName(Application.Selection) = "Firestop" Then is never true. Have a look into the TypeName function does not return the name of the Application.Selection but instead it returs what type Application.Selection is. Here it probably returns Object because a shape is an object.
Actually names are unique. You cannot add 2 shapes with the same name. That is why ActiveSheet.Shapes("Firestop").Delete only deletes one shape.
There seems to be a bug that when you copy a named shape 2 shapes with the same name exist (which should not be possible). You can get around this by deleting that shape in a loop until you get an error (no shape with that name is left).
On Error Resume Next
Do
ActiveSheet.Shapes("Firestop").Delete
If Err.Number <> 0 Then Exit Do
Loop
On Error GoTo 0 'don't forget this statement after the loop
It is not recommended to use On Error Resume Next often. We recommend using it only when it is indispensable.
Sub test()
Dim shp As Shape
Dim Ws As Worksheet
Set Ws = ActiveSheet
For Each shp In Ws.Shapes
If shp.Name = "Firestop" Then
shp.Delete
End If
Next shp
End Sub
I am struggling to even figure out where to start here, so any push in the right direction will be of great help.
I have a map spreadsheet with many different rectangle objects that contain text. When I click on a Rectangle I want to run a macro and I want that macro to receive the text in the rectangle as a parameter. The goal is to get this to display a userform complete with a listbox table that would be custom created based off of the text in the rectangle. I know how to do the latter, but I'm blanking on how to get this property from a shape object. I figured it would be something like this?
Sub Rectangle205_Click()
facilityName = Me.Text
End Sub
or
Sub AMacro(By Ref Target)
facilityName = Target.Text
End Sub
I am pretty clueless on this one, so your help is appreciated.
You could use first code below to link every shapes in a specific sheet to the get_text code:
Sub apply_script()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
sh.OnAction = "get_text"
Next
End Sub
Then use this code to get the text of the shape:
Sub get_text()
MsgBox ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Caption
End Sub
Edit for rectangles only :
Sub apply_script()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.AutoShapeType = 1 Then
sh.OnAction = "get_text"
End If
Next
End Sub
Tried to make a macro that progressively inserts 3 images in Excel
One worksheet (pics) contains the URLs of images in Column A row 1-3
The other worksheet (outputs) is supposed to output the images horizontally.
Sub testinsertpix()
Dim i As Integer
Dim link As String
For i = 1 To 3
link = Worksheets("pics").Cells(i, "A").Value
Cells(1, i).Select
ActiveSheet.Pictures.Insert (link)
Next i
End Sub
It does insert the first image, but fails when the loop reaches the 2nd picture.
"Insert method of Pictures class failed"
Little help please?
Try:
Dim link as Variant
Then output the value and see where it's going wrong. My best guess is your URL isn't being read the way you'd expect.
I have a similar macro and I had the same error.
For me this helped: On error resume next
Sub INSERTPICTURES()
With Sheets("Condition_report")
Dim cella As Range
For Each cella In .Range("A1:A10000").Cells
If cella.Interior.ColorIndex = 3 Then
ActiveSheet.Shapes.AddPicture Filename:=cella, LinkToFile:=msoFalse, SaveWithDocument:=msoCTrue, Left:=cella.MergeArea.Left, Top:=cella.MergeArea.Top, Width:=cella.MergeArea.Width - 3, Height:=cella.MergeArea.Height
On Error Resume Next
End If
Next
End With
End Sub
I have added my macro to my toolbar and would like to put some sort of basic check on it. Instead of asking the user whether he wants to perform the macro, I would like to check the document for a certain image that is always in the documents the macro is used for. (other suggestions are welcome too)
ActiveSheet.Shapes.Range(Array("Picture -767")).Select
That's the code I use to select the image. I haven't been able to find out how to manage an image. What I'm trying to do is
If Image is found then
Part1
Part2
Else
MsgBox 'Macro is not intended for this document'
End if
All help is appreciated!
This should work:
Option Explicit
Sub PicTest()
Dim Shp As Shape
On Error GoTo ErrorExit
Set Shp = ActiveSheet.Shapes("Picture -767")
On Error GoTo 0
ActiveSheet.Shapes.Range(Array("Picture -767")).Select
Part1
Part2
Exit Sub
ErrorExit:
MsgBox "Macro is not intended for this sheet"
End Sub