I am able to remove hyperlink from auto shapes like callouts, arrow...
its working for images also.
only hyperlinks from organization chart is not goin....
if u see code given below... its not counting the hyperlinks in the organization chart.. i.e. they r not deleted...
Code:
MsgBox (wSheet.Hyperlinks.Count)
For i = wSheet.Hyperlinks.Count To 1 Step -1
If cancelPwd = True Then
Exit For
End If
If wSheet.Hyperlinks(i).Type <> 0 Then
wSheet.Hyperlinks(i).Delete
ObjExcel.Save
End If
Next i
You will need to select the shape itself in code and then remove the link from within the shape, it will not show up on the hyperlinks in the spreadsheet..
VB Code:
ActiveSheet.Shapes("Organization Chart").Select
Selection.ShapeRange.Item(1).Hyperlink.Delete 'Change to the item number or name
Danny
Never Think Impossible
If you find my answer helpful then please add to my reputation
Okay.. This is what I found out.. seems a bit overkill but it does do the job..
VB Code:
Dim Shp As ShapeRange
Dim IShp As Shape
Dim i As Integer
Dim j As Integer
For i = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(1).Select
Set Shp = Selection.ShapeRange
For j = 1 To Shp.DiagramNode.Diagram.Nodes.Count
Set IShp = Shp.DiagramNode.Diagram.Nodes(j).Shape
On Error Resume Next
If IShp.Hyperlink.Address <> "" Then
IShp.Hyperlink.Delete
End If
On Error GoTo 0
Next j
Next i
End Sub
Not tested on a shape without any subsequent shapes inside, so not sure what will happen, but this should remove the hyperlinks from all organisation charts on the spreadsheet.
Danny
Never Think Impossible
If you find my answer helpful then please add to my reputation
Are you using the exact code that I gave you as it seems to be turning the error trap off..
I have tested this on a spreadsheet with an organisation chart, two objects with a hyperlink, a block arrow again with a hyperlink and then to cells in the file with hyperlinks... post the exact code you are using..
Danny
Never Think Impossible
If you find my answer helpful then please add to my reputation
Dim objexcel As Excel.Application
Dim objworksheet As Excel.Worksheet
Dim objworkbook As Excel.Workbooks
Private Sub cmddelete_Click()
Set objexcel = CreateObject("Excel.Application")
objexcel.Workbooks.Open ("c:\Book1.xls")
objexcel.WindowState = xlMinimized
objexcel.WindowState = xlMaximized
Dim Shp As ShapeRange
Dim IShp As Shape
Dim i As Integer
Dim j As Integer
On Error GoTo ResNextShp
For j = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(j).Select
Set Shp = Selection.ShapeRange
If Shp.HasDiagramNode = msoTrue Then
For i = 1 To Shp.DiagramNode.Diagram.Nodes.Count
Set IShp = Shp.DiagramNode.Diagram.Nodes(i).Shape
If IShp.Hyperlink.Address <> "" Then
IShp.Hyperlink.Delete
End If
Next i
Else
Set IShp = ActiveSheet.Shapes(j)
If IShp.Hyperlink.Address <> "" Then IShp.Hyperlink.Delete
End If
Next j
Debug.Print ActiveSheet.Hyperlinks.Count
i = 0
For i = ActiveSheet.Hyperlinks.Count To 1 Step -1
ActiveSheet.Hyperlinks(i).Delete
Next i
Exit Sub
The organization chart works with shape nodes, shapes within an existing shape.. The code will remove hyperlinks from the shapes inside the organization chart, if there is a hyperlink on the organization chart itself then it will be best to include it at the end of the first loop..
Change the If..Else..End If statement so that it will refer to the organization chart as an object straight after removing any links from it's nodes..
VB Code:
Dim objexcel As Excel.Application
Dim objworksheet As Excel.Worksheet
Dim objworkbook As Excel.Workbooks
Private Sub cmddelete_Click()
Set objexcel = CreateObject("Excel.Application")
objexcel.Workbooks.Open ("c:\Book1.xls")
objexcel.WindowState = xlMinimized
objexcel.WindowState = xlMaximized
Dim Shp As Excel.ShapeRange
Dim IShp As Excel.Shape
Dim i As Integer
Dim j As Integer
On Error GoTo ResNextShp
For j = 1 To objexcel.ActiveSheet.Shapes.Count
objexcel.ActiveSheet.Shapes(j).Select
Set Shp = Selection.ShapeRange
If Shp.HasDiagramNode = msoTrue Then
For i = 1 To Shp.DiagramNode.Diagram.Nodes.Count
Set IShp = Shp.DiagramNode.Diagram.Nodes(i).Shape
If IShp.Hyperlink.Address <> "" Then IShp.Hyperlink.Delete
Next i
End If
Set IShp = objexcel.ActiveSheet.Shapes(j)
If IShp.Hyperlink.Address <> "" Then IShp.Hyperlink.Delete
Next j
i = 0
For i = objexcel.ActiveSheet.Hyperlinks.Count To 1 Step -1
objexcel.ActiveSheet.Hyperlinks(i).Delete
Next i
Exit Sub
ResNextShp:
Resume Next
End Sub
This can also be re-coded to remove from all sheets by inserting a couple more lines as a loop around the worksheets, if you want that as well then let me know.
Danny
Never Think Impossible
If you find my answer helpful then please add to my reputation
Unfotunately I had to leave office early yesterday. I have had a look at the process and it does not remove the link from the Organisation Chart itself, but why would the actual chart have a link anyway? Do the individual names in the chart have the links??
I will have to look into this a bit more as even the recorded macro method does work..
I cannot use vb6 at work, only have .Net and office.
Danny
Never Think Impossible
If you find my answer helpful then please add to my reputation
ActiveSheet.Hyperlinks.Count always returns ZERO for me in Excel '97 and 2003. There are TWO working hyperlinks on the sheet. You might start a new thread asking how to detect hyperlinks.
Sub Macro1()
' Select a cell and run this macro
' If more than one cell is selected, only the upper left cell is tested
Dim i As Integer
i = InStr(Selection.Formula, "HYPERLINK")
If i > 0 Then MsgBox "This is probably a HYPERLINK cell"
End Sub
You have more patience and time than I do. He ought to break out the smallest piece of code that doesn't work. I just don't have time to scrounge through a bunch of uncommented code looking for subtle operational problems.
I don't think the piece of code I highlighted in my last post will work. (???)
Reply With Quote
Originally Posted by Webtest
