Hi I want to change the file format of the comment shape picture (Fill) and as well as to a standard height and width. Tried the following code but it is keep on throwing Application defined error "Run time error 1004". Please guide me to correct this one.
Sub ReduceImageSize()
Dim cmt As Comment
Dim MyChart As Chart
Dim MyPicture As String
Dim pic As Object
Dim PicWidth As Long
Dim PicHeight As Long
Dim num As Long
num = 1
Application.ScreenUpdating = False
For Each cmt In ActiveSheet.Comments
With cmt
.Visible = True
.Shape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
.Visible = False
PicHeight = .Shape.Height
PicWidth = .Shape.Width
Set MyChart = Charts.Add(0, 0, 100, 100).Chart
With MyChart.Parent
.Width = PicWidth
.Height = PicHeight
.ChartArea.Select
.Paste
.ChartObjects(1).Chart.Export Filename:="C:\Temp\MyPic " & num & ".jpg", FilterName:="jpg"
End With
.Shape.Fill.UserPicture PictureFile:="C:\Temp\MyPic " & num - 1 & ".jpg"
num = num + 1
ActiveChart.Delete
End With
Next
Application.ScreenUpdating = True
End Sub
Try changing Format:=xlPicture to Format:=xlBitmap because jpg is a bitmap type image. See the following from MS. https://msdn.microsoft.com/en-us/library/office/ff837557.aspx
And also https://msdn.microsoft.com/en-us/library/office/ff195475.aspx
Found the solution:
Option Explicit
Sub ReduceImageSize()
Dim cmt As Comment
Dim MyChart As ChartObject
Dim MyPicture As String
Dim pic As Object
Dim PicWidth As Long
Dim PicHeight As Long
Dim num As Long
Dim Mysheet As Worksheet
num = 1
Application.ScreenUpdating = False
For Each Mysheet In ThisWorkbook.Worksheets
For Each cmt In ActiveSheet.Comments
With cmt
.Visible = True
.Shape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.Visible = False
PicHeight = .Shape.Height
PicWidth = .Shape.Width
Set MyChart = ActiveSheet.ChartObjects.Add(0, 0, 100, 100)
With MyChart
.Activate
.Width = PicWidth
.Height = PicHeight
.Chart.Paste
'.ChartArea.Select
'.Paste
.Chart.Export Filename:="C:\Temp\MyPic " & num & ".jpg", FilterName:="jpg"
End With
.Shape.Fill.UserPicture PictureFile:="C:\Temp\MyPic " & num & ".jpg"
num = num + 1
MyChart.Delete
End With
Next
Application.ScreenUpdating = True
Next
End Sub
Related
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("D2:D3")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("D2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
Mostly, the stated code can help me to transfer the urls to images. But some urls won't work.
such as this link:
https://www.revolvecn888.com/images/p4/n/d/AGOL-WJ95_V1.jpg
it can not be transfered to images.
I am extracting a excel table as png file the extraction is ok, but the extracted file is too zoomed out and when i zoom in it is all blurr, i am going to attach the image in a mail so the data should be clear visible,Any idea where to change the code ,changed the width and height below to almost 50 no change
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
Here is the code
Sub check(filename As String, picturename As String)
Dim myWb As Workbook
Dim ws As Worksheet
Dim i, j As Long, LastRow As Integer
'Dim filename As String, picturename As String
Set myWb = Workbooks.Open(filename:=filename)
Worksheets("Sheet1").Activate
Dim FName As String
FName = picturename
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = ActiveSheet.Range("A2:N42")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export filename:=picturename, FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
myWb.Close False
End Sub
The selection in your case is the Chart itself, and nothing will be increase n its dimensions. And the code must paste the picture in the increased chart... Otherwise, any increase does not help.
Try the next way, please:
'what you have in your code...
'.....
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ChTemp.Parent
.Width = rng.Width + 10
.Height = rng.Height + 10
End With
ChTemp.Paste
ChTemp.Export filename:=picturename, FilterName:="jpg"
'your code...
'...
I have used some code that will allow a user to store a picture in the comments of a cell using:
Application.ActiveCell.AddComment.Shape.Fill.UserPicture (fName)
I now want to write something that iterates through the comments of a worksheet and exports all the pictures used above into separate picture files. I am not sure how to reach the right object to do this.
Thanks
Martin
I cobbled some code together from a few sources. How does this work?
Sub extractCommentImage()
'Borrowed from: https://excelribbon.tips.net/T011165_Moving_Comment_Background_Pictures_to_Cells.html
Dim cmt As Comment
Dim cel As Range
Dim bvisible As Boolean
For Each cmt In ActiveSheet.Comments
With cmt
bvisible = .Visible
.Visible = True
Set cel = .Parent.Offset(0, 1)
.Shape.CopyPicture appearance:=xlScreen, Format:=xlPicture
cel.PasteSpecial
selection.ShapeRange.LockAspectRatio = msoFalse
.Visible = bvisible
.Shape.Fill.OneColorGradient msoGradientFromCenter, 1, 1
End With 'cmt
Next cmt
ExportMyPicture
End Sub
And the "Export" sub:
Sub ExportMyPicture()
'borrowed from: https://stackoverflow.com/questions/18232987/export-pictures-from-excel-file-into-jpg-using-vba
Dim MyChart As String, MyPicture As String, pic As Object
Dim PicWidth As Long, PicHeight As Long, num As Long
Dim shtName as String
num = 1
Application.ScreenUpdating = False
shtName = ActiveSheet.Name
For Each pic In ActiveSheet.Pictures
MyPicture = pic.Name
With pic
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=shtName
selection.Border.LineStyle = 0
MyChart = Split(ActiveChart.Name, " ")(1) & " 1"
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="C:\Users\[CHANGE THIS]\Desktop\MyPic " & num & ".jpg", FilterName:="jpg"
num = num + 1
.Shapes(MyChart).Cut
End With
Next pic
Application.ScreenUpdating = True
Exit Sub
End Sub
I would like to make this code save the image name from a value in a cell. For example if "cat" was in the cell Y36 I would like it to be called cat.jpg.
The code below works when I don't have & FileNumber & in it or FileNumber = Range("Y36").
Sub ExportCellsAsPicture()
FileNumber = Range("Y36")
Const FName As String = "HD:Users:User:Desktop:" & FileNumber & ".jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("QR Code").Range("Y50:AS70") 'Set your range here
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 10
.Height = PicTemp.Height + 10
End With
ChTemp.Export Filename:="HD:Users:User:Desktop:" & FileNumber & ".jpg", FilterName:="jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
UPDATE: WORKING CODE
Sub whatsup()
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Dim fileCon As String
fileCon = "JK"
Application.ScreenUpdating = False
Set pic_rng = Worksheets("QR Code").Range("Y50:AS70") 'Set your range here
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
'Here I want the .jpg to be called test_yyyy_mm_dd.jpg
ChTemp.Export Filename:="HD:Users:User1:Desktop:" & fileCon & ".jpg"
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Change the Const to a variable. By Definition, a Const(ant) can't change, but you are using it like a variable. Change it to these two lines:
Dim FName As String
FName = "HD:Users:User:Desktop:" & FileNumber & ".jpg"
You should also declare FileNumber before you set it.
Dim FileNumber As Long 'if this is a number. If not, string
FileNumber = Range("Y36")
And finally, it is always good to make everything Explicit and compile to be sure at least your syntax is correct. This will help reduce many simple but easy to miss errors. Place this at the very top of your module:
Option Explicit
Then compile and correct any syntax errors before debugging.
To debug, set a breakpoint on your first executable line (not a Dim statement) and step through line by line checking to see if it is working as you expect.
Hello I am try to copy an image from excel into powerpoint. My code already copy and pastes into excel but I am having an issue with the code that would automate the resizing. With this current code I get object required Runtime error 424. Any help would be appreciated. MY abbreviated code is below.
Sub CopyDataToPPT()
'Const ppLayoutBlank = 12
Dim objWorkSheet As Worksheet
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Dim intLocation As Integer
Dim intHeight As Integer
Dim inLayout As Integer
Dim strRange As String
Dim boolOK As Boolean
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
'First 1 Xor 2 charts
If Sheets("Summary Table").Cells(15, 4) <> "Not Found" Then
strRange = "B4:N24"
intHeight = 380
Else
strRange = "B4:N13"
intHeight = 190
End If
Set objslide = objPresentation.Slides.Add(1, inLayout)
objPresentation.Slides(1).Layout = ppLayoutTitleOnly
objPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = Sheets("Summary Table").Cells(2, 5) & " - " & Sheets("Summary Table").Cells(4, 2)
Set objRange = Sheets("Summary Table").Range(strRange)
objRange.Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
shapePPTOne.Height = intHeight
shapePPTOne.Left = 50
shapePPTOne.Top = 100
Application.CutCopyMode = False
Next intLocation
This (a simplified version of your code) works fine for me:
Sub CopyDataToPPT()
Dim objslide
Dim objRange As Range
Dim objPPT As PowerPoint.Application
Dim objPresentation As Presentation
Dim shapePPTOne As Object
Set objPPT = CreateObject("PowerPoint.Application")
Set objPresentation = objPPT.Presentations.Add
Set objslide = objPresentation.Slides.Add(1, ppLayoutTitleOnly) 'you had inLayout???
objslide.Shapes.Title.TextFrame.TextRange.Text = "blah blah"
Sheets("Sheet1").Range("C6:G22").Copy
DoEvents
Set shapePPTOne = objslide.Shapes.PasteSpecial( _
DataType:=ppPasteEnhancedMetafile, Link:=msoFalse)
With shapePPTOne
.Height = 200
.Left = 50
.Top = 100
End With
Application.CutCopyMode = False
End Sub