I have a VBA code in Visio that will change the color of the shape if said shape is hyperlinked. Right now, I run it by using a simple command button. I want the macro to run when a change occurs in the worksheet. I know in excel if I wanted to do that I would simply place my code in the Workbook_Change sub, but in Visio I am lost.
Here is my current code:
Private Sub CommandButton1_Click()
Dim Sh As Visio.shape
Dim Link As Hyperlink
For Each Sh In Visio.ActivePage.Shapes '<~ loop through the shapes collection
For Each Link In Sh.Hyperlinks '<~ loop through the links collection
If Not Link.Address = "" Then '<~ check for a blank address
Sh.Cells("Fillbkgnd").Formula = "RGB(255,102,0)"
Sh.Cells("Fillforegnd").Formula = "RGB(255, 102, 0)" '<~ apply a color to the shape
End If
Next Link
Next Sh
End Sub
Any ideas?
#JonFournier I have revisted this and here is my code that lives in ThisDocument:
Public WithEvents Pg As Visio.Page
Private Sub Pg_CellChanged(ByVal Cell As IVCell)
Set Pg = Pages("Page-1")
If Cell.Section = visSectionHyperlink Then
Dim Sh As Visio.shape
Dim Link As Hyperlink
For Each Sh In Visio.ActivePage.Shapes '<~ loop through the shapes collection
For Each Link In Sh.Hyperlinks '<~ loop through the links collection
If Not Link.Address = "" Then '<~ check for a blank address
Sh.Cells("Fillbkgnd").Formula = "RGB(255,102,0)"
Sh.Cells("Fillforegnd").Formula = "RGB(255, 102, 0)" '<~ apply a color to the shape
End If
Next Link
Next Sh
Else
End If
End Sub
The code that I put inside works perfectly fine when paired with a command button, but I would like it to work when the shape is changed. What else should I add to the code to "instantiate the object" or to get it to run the way I need it to. I can't seem to get anything to work. Appreciate the help.
Again, I am sorry this is appearing as an answer, my work firewalls will not allow me to comment for some reason.
You can catch the CellChanged event on the Page object, and check if the changed cell is in the hyperlink shapesheet section.
In a class module:
Public Withevents Pg as Visio.Page
Private Sub Pg_CellChanged(ByVal Cell as IVCell)
If Cell.Section = visSectionHyperlink Then
' call your code here
End If
End Sub
You would need to instantiate the object and keep it alive to monitor your active page, but this is the general gist of something that would work for you, I think.
This would also live happily in ThisDocument, if you'd prefer that.
Related
At this link, the official documentation says of the Slide.Name property says:
If you copy a slide from one presentation to another, the slide loses the name it had in the first presentation and is automatically assigned a new name in the second presentation.
I can see the rationale for this. However, I am now trying to implement a procedure which guarantees unique names. Specifically, in the first presentation, I run this code:
Dim last As Long: last = GetLastSlideNumber("LastSection")
Dim i As Integer
For i = 1 To last
With ActivePresentation.Slides(i)
Dim newName As String: newName = "new" & i
.Name = newName
End With
Next
which names all the slides in this presentation as new1, new2, etc. Then, I run similar code in the other one to name the slides as old1, old2, etc.
Now, I have guaranteed that the names are unique. Is there any way I can leverage off this to copy slides over without losing the slide name?
Try maybe do it trough the event class
' AppEvents class module
Option Explicit
Public WithEvents App As Application
Private Sub App_PresentationNewSlide(ByVal Sld As Slide)
Sld.Parent.Slides(Sld.SlideIndex).Name = "MyuniqueSlideName#Number"
End Sub
Then you call from Module1
' Module 1
Option Explicit
Public pApp As AppEvents
Sub GetAppClass()
Set pApp = New AppEvents
Set pApp.App = Application
End Sub
After that, every time you add new slide the App_PresentationNewSlide will occur.
I need a button in a PowerPoint slide that when I click it, it will, 1) run a macro and 2) hyperlink to another slide within the same presentation.
I can only see a way to do one or the other, not both at the same time.
My macro code is:
Sub question1_real()
Dim oSh As Shape
Dim oSl As Slide
Dim lScore As Long
' By doing it this way it's easy to change to a different slide if you
' need to later for some reason:
Set oSl = ActivePresentation.Slides(18)
' Change this if your shape is named something else:
Set oSh = oSl.Shapes("TextBox 2")
With oSh
' Make sure it's not blank to start with:
If Len(.TextFrame.TextRange.Text) = 0 Then
.TextFrame.TextRange.Text = "1"
End If
lScore = CLng(.TextFrame.TextRange.Text)
lScore = lScore + 1
.TextFrame.TextRange.Text = CStr(lScore)
End With
End Sub
My VBA skills are zero. The above code is borrowed from someone. I used the Insert Action option in PowerPoint to get it to work.
Assuming that you've given a shape a Run Macro action setting and chosen the subroutine you've posted above, you can add this function to the VBA project:
Sub JumpTo(lSlideIndex As Long)
SlideShowWindows(1).View.GoToSlide (lSlideIndex)
End Sub
Then wherever you want to jump to another slide, call it like so:
Call JumpTo(42) ' or whatever slide you want to jump to
or just
JumpTo 42
It's more convenient to have this in a Function if you need to use it more than once in the presentation. If it's strictly a one-shot, you can just paste this into your existing code:
SlideShowWindows(1).View.GoToSlide (42)
Is there a way to runtime copy image from worksheet to userform image control?
I got a shape on a worksheet containing image. And when I select --> copy (ctrl + C) this shape, go to the UserForm1 design --> image1 properties I can do ctrl + v in the picture property of image1 and the image is pasted from clipboard to image1 control.
How can I achieve this using VBA in runtime?
I tried UserForm1.Image1.Picture = ActiveSheet.Shapes("Picture 1").Picture
And many similar bot none of them work
I usually get "Object doesn't support this property or method" or "Type mismatch"
Some time ago I was looking for a solution of the same problem. Did not find a solution, but I found a great workaround:
Make a separate form with plenty of pictures in it. Name it user_form_pics.
Then call the following on your form:
Me.Image1.Picture = user_form_pics.img_name11.Picture
This is how to use it in the constructor:
Private Sub UserForm_Initialize()
Me.Image1.Picture = user_form_pics.img_name11.Picture
End Sub
It works! Now your form has the picture of the user_form_pics.img_name11
Edit:
In case that you need to save Chart to picture, the procedure is the following:
Option Explicit
Public Sub TestMe()
Dim chtChart As Chart
Dim strPath As String
Set chtChart = ActiveSheet.ChartObjects(1).Chart
strPath = ThisWorkbook.Path & "\myChart.bmp"
chtChart.Export (strPath)
UserForm1.Show vbModeless
UserForm1.Image1.Picture = LoadPicture(strPath)
End Sub
I have added a rectangle shape to a spreadsheet. I now wish to use a macro on event RectangleA_Click(). I know the shape's name is RectangleA as I have the below sub:
Sub f()
Dim Shape As Shape
For Each Shape In ActiveSheet.Shapes
Debug.Print Shape.Name
Next
End Sub
I have written the code:
Private Sub RectangleA_Click()
MsgBox "hello"
End Sub
In the relevant sheet object space in the editor. On clicking the shape the subroutine is not called.
I am aware that I can assign this using right click> assign macro, but would prefer to avoid this as it seems like an unnecessary step. I'm also aware that there are Active X controls which automatically assign the macro, again I would prefer to avoid this if possible.
Something like this may work:
Sub AssignMacroToShape()
Set shpTemp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1680#, 594#, 120#, 74.25)
shpTemp.OnAction = ActiveWorkbook.Name & "!Macro Name"
End Sub
But it will be much easier just to right click > Assign Macro.
This above code is useful if you need to create the shape then assign a macro to it after creation.
You can look into the OnAction event to get the answer to specifics if this doesn't help.
Platform : MS Excel 2007(MS Visual Basic 6.0)
I have a few excel file with different textboxes in them.
All the textboxes were name. E.g TxTbox_AAAA, TxtBox_BBBB
Most of them have similar number of Textboxes with same name.
I also required to update the content inside the textboxes. But like i said... some excel file doesn't contain the textboxes.
E.g aaa.xls and bbb.xls have TexTbox_AAAA, TextBox_BBBB
and ccc.xls only have TexTbox_AAAA
my script is something like this
xlApp.ActiveSheet.TextBoxes("TextBox_AAAA").Text = TxtAAAA
xlApp.ActiveSheet.TextBoxes("TextBox_BBBB").Text = TxtBBBB
but if i run, it will encounter run-time error '1004':
Unable to get the TextBoxes property of the Worksheet class
which i suspect it is due to the excel doesn't have this textbox named "TextBox_BBBB"
so how do i put a check before xlApp.ActiveSheet.TextBoxes("TextBox_BBBB").Text = TxtBBBB
to check if this worksheet/activesheet doesn't contain TextBoxes("TextBox_BBBB"), it will not execute this step?
Since a TextBox is a Shape, here is one way to tell if a specific TextBox is on the activesheet:
Public Function IsItThere(sIn As String) As Boolean
IsItThere = False
If ActiveSheet.Shapes.Count = 0 Then Exit Function
For Each s In ActiveSheet.Shapes
If s.Name = sIn Then
IsItThere = True
Exit Function
End If
Next s
End Function
Not sure but try this:
Dim ws as Worksheet
Dim shp as Shape
Set ws = Activesheet '~~> change to suit
For Each shp in ws.Shapes
If shp.Name = "Textbox_Name" Then
'~~> your code here
End If
Next
Hope this helps
Thanks L42 and Gary's Student
I got it.. i should put
For Each s In xlApp.ActiveSheet.Shapes
instead of
For Each s In ActiveSheet.Shapes
only
Thanks for the help!!! =)