I copy the picture. How to adjust this picture to the size of cell, using VBA?
Use this code (Q related to this):
Sub copy()
Dim sh As Shape, ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets("mechanic")
Set ws2 = Worksheets("character")
ws1.Shapes("Picture").copy
With ws2.Range("A8").MergeArea
.PasteSpecial
Set sh = ws2.Shapes(ws2.Shapes.Count) 'get last shape, i.e. pasted picture
If .Height / sh.Height < .Width / sh.Width Then
sh.ScaleHeight .Height / sh.Height, msoFalse
Else
sh.ScaleWidth .Width / sh.Width, msoFalse
End If
End With
End Sub
Related
I have a lot of squares that will hide a picture behind them.
I will repeat this process in many slides in a ppt, That's why I want it to be random.
I am new to macros and don't understand them that well.
Is there a way to make a random square disappear and then after 2 seconds, another random square disappears, and so on? Until I stop it or all squares have disappeared.
Thank you in advance.
I have this code that makes the square disappear when clicked that I got from google.
Sub triggerMe()
Dim osld As Slide
Dim oshp As Shape
Dim oeff As Effect
On Error Resume Next
Set oshp = ActiveWindow.Selection.ShapeRange(1)
If Not oshp Is Nothing Then
Set osld = oshp.Parent
Set oeff = osld.TimeLine.InteractiveSequences.Add.AddEffect(oshp, msoAnimEffectFade, , msoAnimTriggerOnShapeClick)
With oeff
.Timing.TriggerShape = oshp
.Exit = True
End With
End If
End Sub
This is a screenshot of the slide:
Here is the ppt link
https://docs.google.com/presentation/d/1SHJmcg4IaHsBaiqwJJZktXQQCjUKMq7a/edit?usp=sharing&ouid=107891975751630303148&rtpof=true&sd=true
So this block of code works. It was a lot more complicated than I thought.
Sub Dala()
currentslide = ActiveWindow.Selection.SlideRange.SlideIndex
Dim slideShapes As shapes
Dim slideShape As Shape
Dim osld As Slide
Dim oshp As Shape
Dim oeff As Effect
'Get shapes for the slide
Set slideShapes = ActivePresentation.Slides(currentslide).shapes
Dim MyListOfNumbers(0 To 500) As Integer
MyListOfNumbers(0) = 0
Dim r As Variant
Dim x As Integer
Dim exist As Boolean
Dim i As Integer
For Each slideShape In slideShapes
x = Random(slideShapes.Count)
'So that it does not double animate the same square again
For Each r In MyListOfNumbers
If r = x Then
exist = True
End If
Next r
'Animates and add it to the array
If exist = False Then
MyListOfNumbers(i) = x
Set oshp = slideShapes(x)
Set osld = oshp.Parent
On Error Resume Next
Set oshp = oshp
If Not oshp Is Nothing Then
Set osld = oshp.Parent
Set oeff = osld.TimeLine.MainSequence.AddEffect(oshp, msoAnimEffectFade, , msoAnimTriggerAfterPrevious)
With oeff
.Timing.TriggerDelayTime = 1
.Exit = True
End With
End If
i = i + 1
End If
exist = False
Next slideShape
End Sub
Function Random(High As Integer) As Integer
'Generates a random number less than or equal to
'the value passed in High
Randomize
Random = Int((High * Rnd) + 1)
End Function
I'm having a problem that has me stumped. After I copy a table from a PPTX file and paste it t another file and try to repsosition it, it fails. THe two message boxes after that are not working
here's the code and thanks in advance
Option Private Module
' Tables
Sub InsertTable(n As Integer)
Dim CurWindow As DocumentWindow
Dim SourceWindow As DocumentWindow
Dim LoadFrom As String
Dim LoadImage As Shapes
LoadFrom = "Tables.pptx"
'disable screen updating
Set appObject = New cScreenUpdating
appObject.ScreenUpdating = False
'' On Error GoTo Err_handler
With Application.ActiveWindow
If Not (.ViewType = ppViewNormal Or .ViewType = ppViewSlide) Then _
Application.ActiveWindow.ViewType = ppViewNormal
If .ActivePane.ViewType <> ppViewSlide Then .Panes(2).Activate
End With
Set CurWindow = Application.ActiveWindow
'load the library and copy the slide
LoadLibrary LoadFrom
LoadDiagram = ActivePresentation.Slides(n).Shapes.Paste(1)
With ActiveWindow.Selection
.Left = 335
.Top = 370
End With
If ActiveWindow.Selection.Type = ppSelectionShapes Then MsgBox "Shapes"
If ActiveWindow.Selection.Type = msoTable Then MsgBox "Tables"
ExitMe:
On Error Resume Next
SourceWindow.Close
Set CurWindow = Nothing
Set SourceWindow = Nothing
'' RefreshWindow
'enable screen updating
ScreenUpdating = True
Exit Sub
Err_handler:
MsgBox "Switch to Normal View.", vbInformation + vbOKOnly, strAppName
glbErr = True
Resume Err_Resume
Err_Resume:
On Error Resume Next
GoTo ExitMe
End Sub
(Edited significantly) this works, adapt as needed
Sub InsertTable()
Dim SourceFile As Presentation
Set SourceFile = Application.Presentations.Open("Tables.pptx", True, False, msoFalse)
SourceFile.Slides(1).Shapes("Table").Copy
ActivePresentation.Slides(1).Shapes.Paste.Select
With ActiveWindow.Selection.ShapeRange
.Left = 0
.Top = 0
End With
End Sub
This might to be too easy to ask but i am a beginner.
I want to be able to copy ranges from a worksheet and paste it to another worksheet in adjusted size which i should pick and paste it to selected range area in the otherworksheet.
When i do this by using a macro, i can paste it and adjust its size manually.When i try to use this recoreded macro again, it does not paste it to the range that i have selected and its size is not like its original nor like my adjusted size.
How can i specify the size and the ranges the paste?
If you paste image, you can use .width, .height, .top, .left to position it and to set it width and height. Also if you wana to fit in certain range, you can specify it by .width, .height, .top, .left atributes of that range, or even cells. Need further example? It seems too clear to me :(
edit: Try something like this
Sub copyPic()
Dim targetSheet As Worksheet
Set targetSheet = Sheets("Sheet1")
With targetSheet
.Range(.Cells(1, 1), .Cells(3, 3)).CopyPicture
.Paste
Selection.Name = "pastedPic"
With .Shapes("pastedPic")
.Top = targetSheet.Cells(5, 5).Top
.Left = targetSheet.Cells(5, 5).Left
.Width = 50
.Height = 50
End With
End With
End Sub
You can use something like
.range("A1:B10")
instead of my reference, but try to understand it, its much easier to read. It tells you that you wana range which have two corners cells which are specified by row and column number (in this order). Or selection can even be .range(.cells(1,"A"),.cells(3,"C")) but numbers are number... and eventualy if you need to increment range columns or numbers... its much better aproach
So for your need it will be
Sub copyPic()
Dim targetSheet As Worksheet
Set targetSheet = Sheets("Sheet1")
With targetSheet
.Range("A1:B10") .CopyPicture
.Paste
Selection.Name = "pastedPic"
With .Shapes("pastedPic")
.Top = targetSheet.Cells(5, 5).Top
.Left = targetSheet.Cells(5, 5).Left
.Width = 50
.Height = 50
End With
End With
End Sub
If you wana to paste it to another workbook, try something like this
Sub copyPic()
Dim targetSheet As Worksheet
Set targetSheet = Sheets("Sheet1")
Dim targetWB as excel.workbook
set targetWB = workbooks.open("pathToYourWorkbook")
With targetSheet
.Range("A1:B10") .CopyPicture
targetWb.sheets("sheetName").Paste
Selection.Name = "pastedPic"
With .Shapes("pastedPic")
.Top = targetSheet.Cells(5, 5).Top
.Left = targetSheet.Cells(5, 5).Left
.Width = 50
.Height = 50
End With
End With
End Sub
I have below macro.
Could you please modify it in such ways that it will show slide number on the top and also extract notes page.
I tried all ways but couldn't get answer-:
Sub WriteToWord()
Dim aSlide As Slide, MyDoc As New Word.Document, MyRange As Word.Range
Dim aTable As Table, aShape As Shape, TablesCount As Integer, ShapesCount As Integer
Dim i As Word.Paragraph
On Error Resume Next
With MyDoc
.Application.Visible = False
.Application.ScreenUpdating = False
For Each aSlide In ActivePresentation.Slides
For Each aShape In aSlide.Shapes
Set MyRange = .Range(.Content.End - 1, .Content.End - 1)
Select Case aShape.Type
Case msoAutoShape, msoPlaceholder, msoTextBox
If aShape.TextFrame.HasText Then
aShape.TextFrame.TextRange.Copy
MyRange.Paste
With MyRange
.ParagraphFormat.Alignment = wdAlignParagraphLeft
For Each i In MyRange.Paragraphs
If i.Range.Font.Size >= 16 Then
i.Range.Font.Size = 14
Else
i.Range.Font.Size = 12
End If
Next
End With
End If
Case msoPicture
aShape.Copy
MyRange.PasteSpecial DataType:=wdPasteMetafilePicture
ShapesCount = .Shapes.Count
With .Shapes(ShapesCount)
.LockAspectRatio = msoFalse
.Width = Word.CentimetersToPoints(14)
.Height = Word.CentimetersToPoints(6)
.Left = wdShapeCenter
.ConvertToInlineShape
End With
.Content.InsertAfter Chr(13)
Case msoEmbeddedOLEObject, msoLinkedOLEObject, msoLinkedPicture, msoOLEControlObject
aShape.Copy
MyRange.PasteSpecial DataType:=wdPasteOLEObject
ShapesCount = .Shapes.Count
With .Shapes(ShapesCount)
.LockAspectRatio = msoFalse
.Width = Word.CentimetersToPoints(14)
.Height = Word.CentimetersToPoints(6)
.Left = wdShapeCenter
.ConvertToInlineShape
End With
.Content.InsertAfter Chr(13)
Case msoTable
aShape.Copy
MyRange.Paste
TablesCount = .Tables.Count
With .Tables(TablesCount)
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Range.Font.Size = 11
End With
.Content.InsertAfter Chr(13)
End Select
Next
If aSlide.SlideIndex < ActivePresentation.Slides.Count Then .Content.InsertAfter Chr(12)
.UndoClear ' Clear used memory
Next
' Change white font to black color
With .Content.Find
.ClearFormatting
.Format = True
.Font.Color = wdColorWhite
.Replacement.Font.Color = wdColorAutomatic
.Execute Replace:=wdReplaceAll
End With
MsgBox "PPT Converted to WORD completed, Please check and save document", vbInformation + vbOKOnly, "ExcelHome/ShouRou"
.Application.Visible = True
.Application.ScreenUpdating = True
End With
End Sub
Sub Auto_Open() ' Add PPTtoWord to Tool Bar when Powerpoint start
Dim MyControl As CommandBarControl
On Error Resume Next
Application.CommandBars("Standard").Controls("PPTtoWord").Delete
Set MyControl = Application.CommandBars("Standard").Controls.Add(Before:=1)
With MyControl
.Caption = "PPTtoWord"
.FaceId = 567 ' Word Icon
.Enabled = True
.Visible = True
.Width = 100
.OnAction = "WriteToWord"
.Style = msoButtonIconAndCaption
End With
End Sub
Sub Auto_Close() ' Delete PPTtoWord from Tool Bar when Powerpoint close
On Error Resume Next
Application.CommandBars("Standard").Controls("PPTtoWord").Delete
End Sub
You are running this from Word and automating PowerPoint using early binding, you need to fully qualify any PowerPoint reference.
Have you added a reference to PowerPoint library.
Change to aShape As PowerPoint.Shape
Grab the reference to the running instance of PowerPoint. PowerPoint is single instance multi-use so you can use this.
Dim PPT as PowerPoint.Application
Set PPT = CreateObject("PowerPoint.Application")
Fully qualify all references to ActivePresentation with PPT.ActivePresentation
Your macro should run then and generate something so that you can continue debugging.
I have an excel worksheet with a lot of pictures with various sizes and formats. I want to use excel VBA to loop through all the pictures in the worksheet, and set each picture to the same width (214) and change the picture type to a JPEG after resizing (to keep the file size down). My pictures are located in various cells, and I don't want the picture locations to change (i.e. stay in the same cell). I'm new to VBA and tried the following - but it doesn't work. The debugger stops at the line where I'm trying to cut the picture.
Sub Macro6()
Dim p As Object
Dim iCnt As Integer
For Each p In ActiveSheet.Shapes
p.Width = 217.44
p.Cut
p.PasteSpecial Format:="Picture (JPEG)", Link:=False
iCnt = iCnt + 1
Next p
End Sub
It's not the cutting part that Excel doesn't like--it's the pasting part. Paste and PasteSpecial are methods you call with a worksheet object (where you're pasting to) instead of the image (the thing you're pasting). I don't know if you want to just shrink the width and hold the height constant or if you want to scale both dimensions evenly. If you want to scale both evenly, try this:
Sub Macro6()
Dim p As Object
Dim iCnt As Integer
Dim s As Double
Dim r As Range
For Each p In ActiveSheet.Shapes
s = 214 / p.Width
Set r = p.TopLeftCell
p.Width = 214
p.Height = p.Height * s
p.Cut
r.Select
ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False
Application.CutCopyMode = False
iCnt = iCnt + 1
Next p
End Sub
If you're just trying to shrink the width and leave the height the same, try this:
Sub Macro6()
Dim p As Object
Dim iCnt As Integer
Dim r As Range
For Each p In ActiveSheet.Shapes
Set r = p.TopLeftCell
p.Width = 214
p.Cut
r.Select
ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False
Application.CutCopyMode = False
iCnt = iCnt + 1
Next p
End Sub
The locations of your pictures should stay exactly the same if they were originally right at the corner of a cell. Otherwise, this will align the top left corner of the image to the nearest cell corner. The Application.CutCopyMode = False is good practice after pasting. It tells Excel to wipe the clipboard and go back to normal operation instead of waiting for you to paste again. Hope this helps.
Thanks for answering my question! Here's the code I ended up using based on your suggestions. The program took several minutes to run (had over 5000 pictures in the file - yikes!). However, it was worth the wait, because it shrunk the file size in half.
Sub all_pics_to_jpeg()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim mypic As Shape
Dim picleft As Double
Dim pictop As Double
For Each mypic In ActiveSheet.Shapes
mypic.LockAspectRatio = msoTrue
If mypic.Width > mypic.Height Then
mypic.Width = 217.44
Else: mypic.Height = 157.68
End If
picleft = mypic.Left
pictop = mypic.Top
With mypic
.Cut
ActiveSheet.PasteSpecial Format:="Picture (JPEG)", Link:=False, _
DisplayAsIcon:=False
Application.CutCopyMode = False
Selection.Left = picleft
Selection.Top = pictop
End With
Next mypic
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub