I want to call a random color between 8 different colors and display it in a label as its backcolor in Visual Basic. How can I display the colors without repeating a color that has been called out on a specific label?
For example, if color red is called out and displayed in labelA1, how can I make sure that color red won't be called out and displayed in labelB1, labelC1 or labelD1 but can be called out in labelA13 or labelB16?
Below is a picture to help understand the example above.
Use this code to make a list of colors then knock them off the list every time one is used.
Private Function RandomizeLabelColors() As Integer
Randomize()
Dim listOfColors As List(Of Color) = {Color.Red, Color.Blue, Color.Green, Color.Orange}.ToList
Dim labels As List(Of Label) = {Label1, Label2, Label3, Label4, Label5, Label6, Label7, Label8,
Label9, Label10, Label11, Label12, Label13, Label14, Label15, Label16}.ToList
Dim i As Integer = 0
Do Until listOfColors.Count = 0
Dim targetIndex As Integer = Int(Rnd() * listOfColors.Count)
labels(i).BackColor = listOfColors(targetIndex)
labels(i + 4).BackColor = listOfColors(targetIndex)
labels(i + 8).BackColor = listOfColors(targetIndex)
labels(i + 12).BackColor = listOfColors(targetIndex)
listOfColors.RemoveAt(targetIndex)
i += 1
Loop
Return 0
End Function
I have my labels in a 4x4 grid.
-Mg
I have a folder called
App.Path & "\Images"
Inside of it I have 5 Images and in my Form I have also 5 Pictureboxes. Now my question is, How can I display them all one PictureBox per Image at a time? heres is my code so far
Picture1.Picture = LoadPicture("Path")
Heres what I've done so far
Dim c As Control
Dim ImageLink As String
With vs1
For Each c In Form1
For i = 1 To .Rows - 1
If Len(ImageLink) > 0 Then ImageLink = ImageLink
Debug.Print c.Picture
Debug.Print .TextMatrix(i, .ColIndex("Image"))
MsgBox .TextMatrix(i, .ColIndex("Image"))
c.Picture = LoadPicture("C:\Users\paul\Desktop\Gondola Monitoring System\Image\" & .TextMatrix(i, .ColIndex("Image")))
Next
Next
End With
Form1.Show
I try to write the filename in flexgrid and call it in each control.
TYSM for help
Picture1.Picture = LoadPicture(App.Path & "\Images\file1.jpg")
Picture2.Picture = LoadPicture(App.Path & "\Images\file2.jpg")
Picture3.Picture = LoadPicture(App.Path & "\Images\file3.jpg")
Picture4.Picture = LoadPicture(App.Path & "\Images\file4.jpg")
Picture5.Picture = LoadPicture(App.Path & "\Images\file5.jpg")
If this doesn't provide you with what you need, please provide more details on your requirements.
EDIT
Your code isn't going to work. You are looping over all the controls, which will include any buttons, labels, etc, in addition to your picture controls, and for each control you are looping through all the rows of your grid. One better approach would be to define the picture controls as an array (starting index from 1 to match your grid for loop), then the for index is used so that the grid rows and picture indexes match. Something like this:
With vs1
For i = 1 To .Rows - 1
Picture1(i).Picture = LoadPicture("C:\Users\paul\Desktop\Gondola Monitoring System\Image\" & .TextMatrix(i, .ColIndex("Image")))
Next
End With
I have a form on Sheet 1 with multiple cells, (B7:L7, B11:L11, and B13:L13) and 3-4 different pictures on a separate sheet (Sheet 2). I'm trying to have a different picture called for each of those cells depending on their value (i.e., if the cells =2, they should show one of the pictures from the other sheet, if the cells =3, they should show a different picture, etc.).
I've tried this 100 different ways and keep striking out so any input would be greatly appreciated!!
Edit:Including Code-
Like I said, I've done this about a 100 different ways. This is my most recent attempt. While probably way more clunky than necessary, it works great for one cell, I'm just not sure how to edit it to make it work for the entire range (other than copy and pasting for each cell individually). I'd also like to add in something to center it in the cell, but haven't had luck with that either.
Sub InsertPicture()
Dim PicCell As Range
Set PicCell = Range("B7")
If PicCell = 2 Then
Worksheets("Sheet2").Activate
ActiveSheet.Shapes.Range(Array("Picture2")).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("B7").Select
Sheets("Sheet1").Pictures.Paste
ElseIf PicCell = 3 Then
Worksheets("Sheet2").Activate
ActiveSheet.Shapes.Range(Array("Picture3")).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("B7").Select
Sheets("Sheet1").Pictures.Paste
ElseIf PicCell = 4 Then
Worksheets("Sheet2").Activate
ActiveSheet.Shapes.Range(Array("Picture4")).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("B7").Select
Sheets("Sheet1").Pictures.Paste
ElseIf PicCell = 5 Then
Worksheets("Sheet2").Activate
ActiveSheet.Shapes.Range(Array("Picture5")).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("B7").Select
Sheets("Sheet1").Pictures.Paste
ElseIf PicCell = 6 Then
Worksheets("Sheet2").Activate
ActiveSheet.Shapes.Range(Array("Picture6")).Select
Selection.Copy
Worksheets("Sheet1").Activate
Range("B7").Select
Sheets("Sheet1").Pictures.Paste
Else: MsgBox ("No picture at this time")
End If
Let's start with this and see if we're getting close to what you're looking for.
My Sheet1 looks like this:
Sheet2 just has the images like this:
Code: (simplified and improved but no error checking)
Sub InsertPicture()
Dim PicSht As Worksheet
Set PicSht = Worksheets("Sheet2")
Dim mySheet As Worksheet
Set mySheet = Worksheets("Sheet1")
Dim cell As Range
For Each cell In mySheet.Range("B7:L7")
Select Case cell
Case 2 To 6
PicSht.Shapes("Picture" & cell.Value).Copy
cell.Select
mySheet.Pictures.Paste
Case Else
MsgBox ("No picture at this time")
End Select
Next cell
End Sub
Results on Sheet1:
I have many power point slides and each slide has many lines but all those lines are in the same objects. I want now to add some animation including appears for each line with click.
How I can partition the lines in each slide such that every line will be in its own object
Note, I am using powerpoint 2010
Thanks,
AA
This isn't perfect; you'll need to add more code to pick up ALL of the formatting from the original text, but it's a start. Click within the text box you want to modify, then run the TEST sub. Once it's adjusted to your taste, it's a fairly simple matter to extend it to act on every text box in the entire presentation (though not tables, charts, smartart, stuff like that)
Sub Test()
TextBoxToLines ActiveWindow.Selection.ShapeRange(1)
End Sub
Sub TextBoxToLines(oSh As Shape)
Dim oSl As Slide
Dim oNewShape As Shape
Dim oRng As TextRange
Dim x As Long
With oSh
Set oSl = .Parent
With .TextFrame.TextRange
For x = 1 To .Paragraphs.Count
Set oRng = .Paragraphs(x)
Set oNewShape = oSl.Shapes.AddTextbox(msoTextOrientationHorizontal, _
oRng.BoundLeft, oRng.BoundTop, oRng.BoundWidth, oRng.BoundHeight)
With oNewShape
.TextFrame.AutoSize = ppAutoSizeNone
.Left = oRng.BoundLeft
.Top = oRng.BoundTop
.Width = oSh.Width
.Height = oSh.Height
With .TextFrame.TextRange
.Text = oRng.Text
.Font.Name = oRng.Font.Name
.Font.Size = oRng.Font.Size
' etc ... pick up any other font formatting you need
' from oRng, which represents the current paragraph of
' the original text
' Bullets, tabs, etc.
End With
End With
Next
End With
End With
oSh.Delete
End Sub
I am trying to use VBA to automate the Change Picture function when you right click a Shape in Excel/Word/Powerpoint.
However, I am not able to find any reference, can you assist?
So far as I know you can't change the source of a picture, you need to delete the old one and insert a new one
Here's a start
strPic ="Picture Name"
Set shp = ws.Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
ws.Shapes(strPic).Delete
Set shp = ws.Shapes.AddPicture("Y:\our\Picture\Path\And\File.Name", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
shp.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
shp.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
You can change the source of a picture using the UserPicture method as applied to a rectangle shape. However, you will need to resize the rectangle accordingly if you wish to maintain the picture's original aspect ratio, as the picture will take the dimensions of the rectangle.
As an example:
ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
'change picture without change image size
Sub change_picture()
strPic = "Picture 1"
Set shp = Worksheets(1).Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
Worksheets(1).Shapes(strPic).Delete
Set shp = Worksheets(1).Shapes.AddPicture("d:\pic\1.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
End Sub
what I do is lay both images on top of eachother, and assign the macro below to both images. Obviously i've named the images "lighton" and "lightoff", so make sure you change that to your images.
Sub lightonoff()
If ActiveSheet.Shapes.Range(Array("lighton")).Visible = False Then
ActiveSheet.Shapes.Range(Array("lighton")).Visible = True
Else
ActiveSheet.Shapes.Range(Array("lighton")).Visible = False
End If
End Sub
What I've done in the past is create several image controls on the form and lay them on top of each other. Then you programmatically set all images .visible = false except the one you want to show.
In Word 2010 VBA it helps to change the .visible option for that picture element you want to change.
set the .visible to false
change the picture
set the .visilbe to true
that worked for me.
I tried to imitate the original function of 'Change Picture' with VBA in PowerPoinT(PPT)
The code below tries to recover following properties of the original picture:
- .Left, .Top, .Width, .Height
- zOrder
- Shape Name
- HyperLink/ Action Settings
- Animation Effects
Option Explicit
Sub ChangePicture()
Dim sld As Slide
Dim pic As Shape, shp As Shape
Dim x As Single, y As Single, w As Single, h As Single
Dim PrevName As String
Dim z As Long
Dim actions As ActionSettings
Dim HasAnim As Boolean
Dim PictureFile As String
Dim i As Long
On Error GoTo ErrExit:
If ActiveWindow.Selection.Type <> ppSelectionShapes Then MsgBox "Select a picture first": Exit Sub
Set pic = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
'Open FileDialog
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Picture File", "*.emf;*.jpg;*.png;*.gif;*.bmp"
.InitialFileName = ActivePresentation.Path & "\"
If .Show Then PictureFile = .SelectedItems(1) Else Exit Sub
End With
'save some properties of the original picture
x = pic.Left
y = pic.Top
w = pic.Width
h = pic.Height
PrevName = pic.Name
z = pic.ZOrderPosition
Set actions = pic.ActionSettings 'Hyperlink and action settings
Set sld = pic.Parent
If Not sld.TimeLine.MainSequence.FindFirstAnimationFor(pic) Is Nothing Then
pic.PickupAnimation 'animation effect <- only supported in ver 2010 above
HasAnim = True
End If
'insert new picture on the slide
Set shp = sld.Shapes.AddPicture(PictureFile, False, True, x, y)
'recover original property
With shp
.Name = "Copied_ " & PrevName
.LockAspectRatio = False
.Width = w
.Height = h
If HasAnim Then .ApplyAnimation 'recover animation effects
'recover shape order
.ZOrder msoSendToBack
While .ZOrderPosition < z
.ZOrder msoBringForward
Wend
'recover actions
For i = 1 To actions.Count
.ActionSettings(i).action = actions(i).action
.ActionSettings(i).Run = actions(i).Run
.ActionSettings(i).Hyperlink.Address = actions(i).Hyperlink.Address
.ActionSettings(i).Hyperlink.SubAddress = actions(i).Hyperlink.SubAddress
Next i
End With
'delete the old one
pic.Delete
shp.Name = Mid(shp.Name, 8) 'recover name
ErrExit:
Set shp = Nothing
Set pic = Nothing
Set sld = Nothing
End Sub
How to use:
I suggest you to add this macro into the Quick Access Toolbar list.
(Goto Option or Right-click on the Ribbon menu))
First, select a Picture on the slide which you want to change.
Then, if the FileDialog window opens, choose a new picture.
It's done. By using this method, you can bypass the 'Bing Search and One-Drive Window' in ver 2016 when you want to change a picture.
In the code, there might(or should) be some mistakes or something missing.
I'd appreciate it if somebody or any moderator correct those errors in the code.
But mostly, I found that it works fine.
Also, I admit that there are still more properties of the original shape to recover - like the line property of the shape, transparency, pictureformat and so on.
I think this can be a beginning for people who want to duplicate those TOO MANY properties of a shape.
I hope this is helpful to somebody.
i use this code :
Sub changePic(oshp As shape)
Dim osld As Slide
Set osld = oshp.Parent
osld.Shapes("ltkGambar").Fill.UserPicture (ActivePresentation.Path & "\" & oshp.Name & ".png")
End Sub
I'm working in Excel and VBA. I can't overlay images because I have multiple sheets of a variable number and each sheet has the images, so the file would get huge if, say 20 sheets had all 5 images I want to animate.
So I used a combination of these tricks listed here:
1) I inserted an RECTANGLE shape at the location and size I wanted:
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1024#, 512#, 186#, 130#).Select
Selection.Name = "SCOTS_WIZARD"
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture "G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 1.jpg"
.TextureTile = msoFalse
End With
2) Now to animate (change) the picture, I only need to change the Shape.Fill.UserPicture:
ActiveSheet.Shapes("SCOTS_WIZARD").Fill.UserPicture _
"G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 2.jpg"
So I've accomplished my goal of only having 1 picture per sheet (not 5 as in my animation) and duplicating the sheet only duplicates the active picture, so the animation continues seamlessly with the next picture.
![Please find attached code.
First create a shape in PPT and run the code]1