Hey guys always such great help
this macro works great i found online except for one flaw, it keeps the filenam as a string so when i go back and reopen the workbook it re-pulls all the filenam links. This ends up crashing the server which some folks are not too happy with me about
Is there any way i could import the filenam but have the image populate as say a PNG or something so it does not keep pulling that link?
I tried a few different ways but it does not seem to be working.
Any help would be appreciated....
Sub URLPictureInsert1()
Worksheets("Data Entry").Select
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = True
Set Rng = ActiveSheet.Range("AE2:AE415")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column - 13
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 300
.Height = 75
.Top = xRg.Top + (xRg.Height - .Height)
.Left = xRg.Left + (xRg.Width - .Width)
Selection.Placement = xlMoveAndSize
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 299
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 75
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 78
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
End With
lab:
Set Pshp = Nothing
Range("Q2").Select
Next
Application.ScreenUpdating = False
End Sub
this macro works great i found online except for one flaw, it keeps the filenam as a string so when i go back and reopen the workbook it re-pulls all the filenam links. This ends up crashing the server which some folks are not too happy with me about
Is there any way i could import the filenam but have the image populate as say a PNG or something so it does not keep pulling that link?
I tried a few different ways but it does not seem to be working.
Any help would be appreciated....
Sub URLPictureInsert1()
Worksheets("Data Entry").Select
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = True
Set Rng = ActiveSheet.Range("AE2:AE415")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column - 13
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 300
.Height = 75
.Top = xRg.Top + (xRg.Height - .Height)
.Left = xRg.Left + (xRg.Width - .Width)
Selection.Placement = xlMoveAndSize
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 299
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 75
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 78
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
End With
lab:
Set Pshp = Nothing
Range("Q2").Select
Next
Application.ScreenUpdating = False
End Sub