Add a Pictures File Name and Path to a cell ?
 

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

Add a Pictures File Name and Path to a cell ?
 

use: ActiveCell.Offset(, 8).Value = res

pls do rate

"Corey" 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

Add a Pictures File Name and Path to a cell ?
 

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 ,
"Corey" 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

Add a Pictures File Name and Path to a cell ?
 

Simple as thet hey ?

Thank you.
For some reason the (res) would NOt appear in Cell (offset(,8) but would in Cell.Offset(4,0) ??

Shall do the trick though, thanks Muhammed....

"Muhammed Rafeek M" wrote in message
...
use: ActiveCell.Offset(, 8).Value = res

pls do rate

"Corey" 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