One way:
Const csTOOSMALL As String = _
"Please Select the Large Photo Cell where" & _
" you require the Photo FIRST."
Const csPROMPT As String = _
"What is the Photo of, " & vbCrLf & vbCrLf & _
vbTab & "This or That ?"
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim picMyPic As Picture
Dim vRes As Variant
Dim sAns As String
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Set ws = wb.Sheets("JSA Procedure")
ws.Select
If ActiveCell.Height <> 220.5 Then
MsgBox csTOOSMALL, vbExclamation
Exit Sub
Else
sAns = InputBox(csPROMPT, "....")
vRes = Application.GetOpenFilename _
("Image Files (*.jpg), *.jpg")
If vRes = False Then Exit Sub
Set rng = ActiveCell
Set picMyPic = ws.Pictures.Insert(vRes)
With picMyPic
.Top = rng.Top
.Left = rng.Left
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = 278
.ShapeRange.Rotation = 0#
End With
rng.Offset(2, 0).Value = sAns
rng.Offset(0, 8).Value = vRes
End If
Application.ScreenUpdating = True
In article <#$(E-Mail Removed)>,
"Corey" <(E-Mail Removed)> wrote:
> The folowing code places a Picture into a cell, but i need to add the
> pictures name and file path to
> a cell (Offset(0,8) from where it is placed.
> How can i code this? See below CAPITAL TEXT to see where i need it ?
>
> Application.ScreenUpdating = False
> Sheets("JSA Procedure").Select
> If ActiveCell.Height <> 220.5 Then
> MsgBox "Please Select the Large Photo Cell where you require the Photo
> FIRST.", vbExclamation
> Exit Sub
> Else
> Dim ans As String
> ans = InputBox("What is the Photo of, " & vbCrLf & vbCrLf & vbTab & "This or
> That ?", "....")
> Dim WB As Workbook
> Dim SH As Worksheet
> Dim rng As Range
> Dim myPic As Picture
> Dim res As Variant
> 'Const sAddress As String = ActiveCell
> Set WB = ActiveWorkbook
> res = Application.GetOpenFilename _
> ("Image Files (*.jpg), *.jpg")
> If res = False Then Exit Sub
> Set SH = ActiveSheet
> Set rng = ActiveCell
> Set myPic = SH.Pictures.Insert(res)
> With myPic
> .Top = rng.Top
> .Left = rng.Left
> myPic.ShapeRange.LockAspectRatio = msoTrue
> ' myPic.ShapeRange.Height = 220#
> myPic.ShapeRange.Width = 278
> myPic.ShapeRange.Rotation = 0#
> ActiveCell.Offset(2, 0).Value = ans
> ActiveCell.Offset(, 8).Value = WANT PICTURES FILEPATH AND NAME
> HERE
> End With
> End If
> Application.ScreenUpdating = True
>
>
> Regards
>
> ctm
|
Similar Threads
