PDA

View Full Version : [SOLVED] Embedding the most recent picture taken into a cell



ridestp
04-05-2017, 04:06 PM
First off, I want to say THANK YOU to everyone who has contributed to these forums, as it has been a valuable resource in getting my project to where it is today. I am unable to proceed at this point without asking a question myself, however.

Background/What my project is:
I am working to create an Excel file to be used in auditing a store. It has checklists and lots of data to be collected using UserForms. For this part, if a question receives a FAIL response, I want to force a picture to be taken. I have already figured out how to launch the camera (a Windows 10 "Metro" app, what a pain) from within VBA, now I need to embed the picture taken.

What my question/issue is:
I need to embed the picture that was just taken into the Excel document.

I know it will always be stored to the same file path (C:\Users\***XX\Pictures\Camera Roll)
I know the picture file name will be based on date/hour/minute/second the picture was taken
I know I always want the newest file in the folder


In a perfect world, the pictures could be stored in a separate sheet (or anywhere, they just need to stay with the file when moved), and my main sheet would hyperlink to them, to keep the main sheet tidy. So, how can I query for the most recent photo, then embed it?

To give an idea of where I am at right now:

18867

Thank you so much in advance for any help!

mdmackillop
04-06-2017, 03:39 AM
Option Explicit
'Requires reference to Microsoft Scripting Runtime

Sub Test()
Dim x, y
Dim FSO As Object
Dim f As Object
Dim fld As Object
Dim Pth As String

Set FSO = New FileSystemObject
Set fld = FSO.GetFolder("C:\Pictures")
x = 0
For Each f In fld.Files
If f.DateLastModified > x Then
x = f.DateLastModified
y = f.Name
End If
Next f
Pth = fld & "\" & y

ActiveSheet.Pictures.Insert (Pth)
ActiveSheet.Hyperlinks.Add Cells(1, 1), Pth, y
End Sub

snb
04-06-2017, 07:05 AM
The most recent .jpg file in G:\


Sub M_snb()
MsgBox Split(CreateObject("wscript.shell").exec("cmd /c dir G:\*.jpg /b/o-d").stdout.readall, vbCrLf)(0)
End Sub

ridestp
04-06-2017, 09:02 AM
Option Explicit
'Requires reference to Microsoft Scripting Runtime

Sub Test()
...

Thank you so much for taking the time to respond Could you explain the significance of what was quoted above?

When I try to run this, I received the following error:

18871

Here is the full code, and I also attached the workbook


Option Explicit


Sub Test()

Dim x, y
Dim FSO As Object
Dim f As Object
Dim fld As Object
Dim Pth As String


Set FSO = New FileSystemObject
Set fld = FSO.GetFolder("C:\Users\rides\Pictures\Camera Roll")
x = 0
For Each f In fld.Files
If f.DateLastModified > x Then
x = f.DateLastModified
y = f.Name
End If
Next f
Pth = fld & "\" & y

ActiveSheet.Pictures.Insert (Pth)
ActiveSheet.Hyperlinks.Add Cells(1, 1), Pth, y

End Sub


Private Sub CommandButton1_Click()

Dim x As Variant
Dim Path As String


Path = "C:\Users\rides\Desktop\Camera.bat"


x = Shell(Path)


End Sub


Private Sub CommandButton2_Click()
Test
End Sub




Private Sub UserForm_Click()


End Sub

mdmackillop
04-06-2017, 09:17 AM
In the VBE Tools/References 18874

ridestp
04-07-2017, 12:28 PM
Thank you so much for your help, but I have been playing with this all day and it is driving me nuts. The solution you provided does save the picture to the Excel file, but when the file is moved to another computer, the picture doesn't come along with it.

From what I can tell, Shapes.AddPicture allows the pic to be saved to the Excel file. But again, I have been playing with this for hours without a good result.

I do not care how it works, but what I need is to click a link in Sheet1 and for the picture from that row to show up. Any ideas on if that is feasible?

Here is the full code, modified a bit from what the solution said:


Sub embedPic()

Dim x, y
Dim FSO As Object
Dim f As Object
Dim fld As Object
Dim Pth As String
Nextrow = Application.WorksheetFunction.CountA(Range("A:A")) + 1

Set FSO = New FileSystemObject

''This is the path for windows 10 camera roll
Set fld = FSO.GetFolder("C:\Users\a0l00gr\Pictures\Camera Roll")

x = 0
For Each f In fld.Files
If f.DateLastModified > x Then
x = f.DateLastModified
y = f.Name
End If
Next f
Pth = fld & "\" & y

'Sheet2.Pictures.Insert (Pth)
Dim s As Shape
Set s = Sheet2.Shapes.AddPicture(Pth, False, True, 1, (Nextrow - 2) * 300, -1, -1)
s.LockAspectRatio = True
s.ScaleWidth 0.25, msoTrue

Sheet1.Hyperlinks.Add Cells(Nextrow, 5), Pth

End Sub


Private Sub CommandButton1_Click()

'This launches the camera app
Dim j As Variant
Dim Path As String


Path = "C:\Users\a0l00gr\Desktop\Camera.bat"


j = Shell(Path)


End Sub


Private Sub CommandButton2_Click()


embedPic

End Sub

mdmackillop
04-07-2017, 12:41 PM
Do the other PCs have the picture folder or can it be stored on a server?

ridestp
04-07-2017, 12:44 PM
Do the other PCs have the picture folder or can it be stored on a server?

It could eventually be stored on a server, potentially, however when the picture is taken, it will be in the field and without wifi access.

mdmackillop
04-07-2017, 01:16 PM
From what I've read the Shapes.Addicture seems the way to go. I've modified the code slightly here as there was a Desktop.ini file returning a wrong result in the CameraRoll folder on my PC

For Each f In fld.Files
If UCase(Right(f.Name, 3)) = "JPG" Then
If f.DateLastModified > x Then
x = f.DateLastModified
y = f.Name
End If
End If
Next f

ridestp
04-07-2017, 03:19 PM
For anyone else looking to do something similar to this, here is the dirty, nasty code that is hacked together to finally make it do what I want!!!


Sub embedPic()

Dim x, y
Dim FSO As Object
Dim f As Object
Dim fld As Object
Dim Pth As String
Nextrow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Set FSO = New FileSystemObject

'This is the path for windows 10 camera roll
Set fld = FSO.GetFolder("C:\Users\a0l00gr\Pictures\Camera Roll")

x = 0
For Each f In fld.Files
If f.DateLastModified > x Then
x = f.DateLastModified
y = f.Name
End If
Next f
Pth = fld & "\" & y

Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single

' position to the top/left cell of Nextrow * 45 (To space pics 45 cells apart)
Location = "A" & ((Nextrow - 2) * 45) + 1
MyTop = Range(Location).Top
MyLeft = Range(Location).Left


Set MyPic = Sheet2.Shapes.AddPicture(Pth, _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
' ^^^ LinkTo SaveWith -1 = keep size


' now resize pic and move all the way left
MyPic.Height = 250
MyPic.Left = 0


'Add a hyperlink to the picture stored in Sheet2
With Worksheets(1)
.Hyperlinks.Add Anchor:=.Cells(Nextrow, 5), _
Address:="", _
SubAddress:="Sheet2!" & Location, _
TextToDisplay:="Link to Picture"
End With


End Sub


Private Sub CommandButton1_Click()

'This launches the camera app
Dim j As Variant
Dim Path As String


Path = "C:\Users\a0l00gr\Desktop\Camera.bat"


j = Shell(Path)


End Sub


Private Sub CommandButton2_Click()


embedPic

End Sub

mdmackillop
04-07-2017, 04:17 PM
Option Explicit

Sub embedPic()
Dim NextRow As Long
Dim fld As String
Dim Pth As String
Dim MyPic As Shape

NextRow = Application.WorksheetFunction.CountA(Sheet1.Range("A:A")) + 1

'This is the path for windows 10 camera roll
Pth = "C:\Users\a0l00gr\Pictures\Camera Roll\"
fld = Pth & "*.jpg"
fld = """" & fld & """" 'Surround in quotes in case of space in names

Pth = Pth & Split(CreateObject("wscript.shell").exec("cmd /c dir " & fld & " /b/o-d").stdout.readall, vbCrLf)(0)

'Adjust cell size and insert picture
With Sheet2
.Cells.RowHeight = 260
.Columns(1).ColumnWidth = 95
Set MyPic = .Shapes.AddPicture(Pth, msoFalse, msoTrue, 0, .Cells(NextRow, 1).Top, -1, -1)
MyPic.Height = 250
End With

'Add a hyperlink to the picture stored in Sheet2
With Worksheets(1)
.Hyperlinks.Add Anchor:=.Cells(NextRow, 5), _
Address:="", _
SubAddress:="Sheet2!" & Cells(NextRow, 1).Address, _
TextToDisplay:="Link to Picture"
End With
End Sub

snb
04-08-2017, 04:28 AM
Sub M_snb()
With Sheet2
.Cells.RowHeight = 260
.Columns(1).ColumnWidth = 95
.Shapes.AddPicture(Split(CreateObject("wscript.shell").exec("cmd /c dir ""C:\Users\a0l00gr\Pictures\Camera Roll\*.jpg"" /s/b/o-d").stdout.readall, vbCrLf)(0), 0, -1, 0, .Cells(rows.count,1).end(xlup).offset(1).Top, -1, -1).Height = 250
End With

With sheets(1)
.Hyperlinks.Add .Cells(rows.count,5).end(xlup).offset(1), ,"Sheet2!" & sheet2.Cells(rows.count,1).end(xlup).offset(1).Address,"Link to Picture"
End With
End Sub