So I'm trying to make my form fit to all monitors. Some have different display resolution and scale.
I can resize my form to fit to the display but all properties of its contents don't adjust to that new size.
What I want is if the form is scaled to fit to the display, the controls on the Form should adjust as well. Specifically properties like Left, Top, Width, Height, and so one, on every control.
The size could be scaled down or up.
It's possible to iterate through all of the controls on the form (mostly) programmatically, rather than having to explicitly adjust each control. You may have to put in some exceptions for some types of controls (such as timers, which I've put in the example), but generally you can use something like:
Option Explicit
Private Type ControlInfo_type
Left As Single
Top As Single
Width As Single
Height As Single
FontSize As Single
End Type
Dim ControlInfos() As ControlInfo_type
Private Sub Form_Load()
Dim ThisControl As Control
ReDim Preserve ControlInfos(0 To 0)
ControlInfos(0).Width = Me.Width
ControlInfos(0).Height = Me.Height
For Each ThisControl In Me.Controls
ReDim Preserve ControlInfos(0 To UBound(ControlInfos) + 1)
On Error Resume Next ' hack to bypass controls with no size or position properties
With ControlInfos(UBound(ControlInfos))
.Left = ThisControl.Left
.Top = ThisControl.Top
.Width = ThisControl.Width
.Height = ThisControl.Height
.FontSize = ThisControl.FontSize
End With
On Error GoTo 0
Next
End Sub
Private Sub Form_Resize()
Dim ThisControl As Control, HorizRatio As Single, VertRatio As Single, Iter As Integer
If Me.WindowState = vbMinimized Then Exit Sub
HorizRatio = Me.Width / ControlInfos(0).Width
VertRatio = Me.Height / ControlInfos(0).Height
Iter = 0
For Each ThisControl In Me.Controls
Iter = Iter + 1
On Error Resume Next ' hack to bypass controls
With ThisControl
.Left = ControlInfos(Iter).Left * HorizRatio
.Top = ControlInfos(Iter).Top * VertRatio
.Width = ControlInfos(Iter).Width * HorizRatio
.Height = ControlInfos(Iter).Height * VertRatio
.FontSize = ControlInfos(Iter).FontSize * HorizRatio
End With
On Error GoTo 0
Next
End Sub
I tested this with the default form with a CommandButton, Frame, Timer, and TextBox, and it seemed to work OK. You'll probably want to tune the limits on the minimum and maximum sizes for appearance, and my handling of the font is very crude; this could be optimized also. But perhaps this could be a starting point.
This code depends upon the controls iterating the same way each time, which could conceivably break. One way around this would be to use a Collection or other data structure with the name of the control as a key; when iterating in the .Resize event, each control would be looked up by name. Additional structure will be necessary if any of the controls are themselves arrays, and even more if controls are loaded or unloaded dynamically.
I am having issues with inserting a picture in portrait mode using VBA. If the picture is in landscape mode, then the picture is inserted into the associated shape in column B. However, if the picture is in portrait, then the picture is offset 25 columns to column AA. Any help is greatly appreciated!
Sub cmdInsert1_Click()
Dim myPicture As String, MyObj As Object
Range("b5").Select
myPicture = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp; *.tif),*.gif; *.jpg; *.bmp; *.tif", , "Select Picture to Import")
If myPicture = "False" Then Exit Sub
Set MyObj = ActiveSheet.Shapes.AddPicture(myPicture, False, True, Range("B5").Left, Range("B5").Top, -1, -1)
With MyObj
.Height = 293
.Locked = False
End With
Set MyObj = Nothing
End Sub
Windows "remembers" the orientation of the picture, so what is in the Top Left corner of your screen may not actually be the Top Left corner of the picture. You will need to check the .Rotation property of your picture. If it's rotated (ie, not 0), you will need to adjust your code accordingly. For example:
If myObj.Rotation = 0 Or myObj.Rotation = 180 Then
.Height = 293
Else
.Width = 293
End If
Edit: Forgot to account for it merely being upside down
I'm bringing in a shape via code to be a logo at the bottom of a report, but it ends up being handled differently from the normal way Excel handles shapes. My shape disappears if the source (or indeed destination) file is moved - it's handled as though it's a link, so doesn't show, whereas, if I'm using normal "Insert tab ==>Picture" it just keeps the picture visible no matter what.
This is the code I'm using, can anyone see why it's doing it the way it is?
ActiveSheet.Pictures.Insert(MyFileAndPath).Select
Set MyLogo = Selection
'Format the size and position
With MyLogo
.ShapeRange.ScaleHeight 1#, True, msoScaleFromTopLeft
.ShapeRange.ScaleWidth 1#, True, msoScaleFromTopLeft
xWidth = .ShapeRange.Width
xHeight = .ShapeRange.Height
xRatio = xWidth / xHeight
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = 285
.ShapeRange.Height = 285 / xRatio
.ShapeRange.Left = shtCover.Range("LogoBotRight").Left + shtCover.Range("LogoBotRight").Width - MyLogo.ShapeRange.Width
.ShapeRange.Top = shtCover.Range("LogoBotRight").Top + shtCover.Range("LogoBotRight").Height - MyLogo.ShapeRange.Height
End With
Replace:
ActiveSheet.Pictures.Insert(MyFileAndPath).Select
Set MyLogo = Selection
with:
ActiveSheet.Shapes.AddPicture MyFileAndPath, msoFalse, msoTrue, 100, 100, 70, 70
Set MyLogo = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
When I try to google it for 3 days, I found that there is only 1 picture/image available in 1 picbox. My goal is to display multiple images, and they cannot overlap. If they overlap, there a red colour should be shown.
I'm using VB6. I'm using 1 combobox1, for select image n 1 commandbutoon. but when I select 2nd image in click button, the image on picbox will auto overwrite it. Is it caused by .cls ??
Private Sub Combo1_Click()
Dim pin As String
Dim intx As Integer
If UCase$(Combo1.List(intx)) = UCase$(pin) Then
Combo1.ListIndex = intx
End If
End Sub
Private Sub Command1_Click()
If Combo1.ListIndex = 0 Then
Set mPic = pin8.Image
ElseIf Combo1.ListIndex = 1 Then
Set mPic = pin12.Image
Else
Set mPic = pin16.Image
End If
mPicWidth = Me.ScaleX(mPic.Width, vbHimetric, Picture1.ScaleMode)
mPicHeight = Me.ScaleY(mPic.Height, vbHimetric, Picture1.ScaleMode)
ShowPictureAtPosition mLeft, mTop
End Sub
Thank you.
Best regard,
chan
Look, The only way to do that is to add 2 images as resources in the project then make one is the default picture or leave it blank as you wish.
The process now is when you click on the command button you switch between the two pictures.
Button Code:
if
PictureBox1.Image = My.Resources.<Name_of_res_file>.<Name_of_image1111_resource>
Then
PictureBox1.Image = My.Resources.<Name_of_res_file>.<Name_of_image2222_resource>
Else
PictureBox1.Image = My.Resources.<Name_of_res_file>.<Name_of_image1111_resource>
End If
This will switch between the 2 pictures. Hope this helps you.
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