Pasting a picture from access to axcel via vba

I am coying data from an access from to an excel sheet in vba.
All data moves ok except a picture which will not work.
Tried a couple of solutions but all fail.
All code works except one line......

        .Range("AC17").Picture = Me.Photo

All help welcome.

Dim appExcel As Excel.Application
    Dim wbook As Excel.Workbook
    Dim wsheet As Excel.Worksheet
   
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    Set wbook = appExcel.Workbooks.Open("f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2)
    Set wsheet = wbook.Worksheets("SCR")
   
    With wsheet
        .Range("C5").Value = Me.SCRCode
        .Range("I5").Value = Me.SCRDate
        .Range("O5").Value = Me.Department
        .Range("U5").Value = Me.Site
        .Range("AC5").Value = Me.PrimaryContact
        .Range("AC6").Value = Me.ContactEmail
        .Range("AC7").Value = Me.ContactTel
        .Range("C17").Value = Me.Symtom
        .Range("I25").Value = Me.Classification
        .Range("S27").Value = strST
        .Range("S28").Value = strRM
        .Range("X27").Value = strS
        .Range("X28").Value = strR
        .Range("C12").Value = Me.PartNumber
        .Range("U12").Value = Me.BatchNumber
        .Range("E33").Value = Me.EmergencyAction1
        .Range("AG33").Value = Me.DateImplemented1
        .Range("E34").Value = Me.EmergencyAction2
        .Range("AG34").Value = Me.DateImplemented2
        .Range("E35").Value = Me.EmergencyAction3
        .Range("AG35").Value = Me.DateImplemented3
        .Range("AC17").Picture = Me.Photo
    End With
   
    Set wsheet = Nothing
   
    wbook.Close True
    Set wbook = Nothing
   
    Set appExcel = Nothing
SweetingAAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jeffrey CoachmanMIS LiasonCommented:
Cells (ranges) in Excel do not have a Picture property.
Where did you get that code from?

Images in Excel are not stored in Cells, the are stored at "locations" on the sheet
Furthermore you must know what the Internal "name" of the image is in Excel, in order to do this in VBA.

See here for another approach:
http://www.experts-exchange.com/Programming/Automation/Q_24146689.html
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SweetingAAuthor Commented:
The code for the picture i guessed at i simply guessed as i never trried to copy a picture over before.
Its a little more complicated in that i don't actual have a picture, what i have is a hyperlink to a picture.
Me.Photo (which is the location of my visble picture)  = Me.PhotoFile.Value (which is a hyperlink address)
I'm afraid i can't follow what to do from the code you have supplied.  I am still very much a novice so i have pasted more of the code i am using, maybe that will help.

Thanks

Private Sub CreateReport_Click()
    Dim fso
    Dim strSourceFile As String
    Dim strDestFile As String
    Dim strFilename As String
    Dim strPhotoname As String
    Dim strST As String
    Dim stRM As String
    Dim strS As String
    Dim strR As String
   
    If Me.SCRCode <> "" Then
        strFilename = "SupplierConcernReport.xls"
        StrFileName2 = Me.SCRCode & ".xls"
        strPhotoname = Me.SCRCode & ".jpg"
        strSourceFile = "f:\Quality Systems\Supplier Concerns\Templates\" & strFilename
        strDestFile = "f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile strSourceFile, strDestFile, True
        Set fso = Nothing
    End If
   
    If Me.SpecialTransport = -1 Then
        strST = "ü"
        Else: strST = "û"
    End If
   
    If Me.ReplacementMaterial = -1 Then
        strRM = "ü"
        Else: strRM = "û"
    End If
   
    If Me.Scrap = -1 Then
        strS = "ü"
        Else: strS = "û"
    End If
   
    If Me.Rework = -1 Then
        strR = "ü"
        Else: strR = "û"
    End If
   
    Dim appExcel As Excel.Application
    Dim wbook As Excel.Workbook
    Dim wsheet As Excel.Worksheet
   
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    Set wbook = appExcel.Workbooks.Open("f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2)
    Set wsheet = wbook.Worksheets("SCR")

    With wsheet
        .Range("C5").Value = Me.SCRCode
        .Range("I5").Value = Me.SCRDate
        .Range("O5").Value = Me.Department
        .Range("U5").Value = Me.Site
        .Range("AC5").Value = Me.PrimaryContact
        .Range("AC6").Value = Me.ContactEmail
        .Range("AC7").Value = Me.ContactTel
        .Range("C17").Value = Me.Symtom
        .Range("I25").Value = Me.Classification
        .Range("S27").Value = strST
        .Range("S28").Value = strRM
        .Range("X27").Value = strS
        .Range("X28").Value = strR
        .Range("C12").Value = Me.PartNumber
        .Range("U12").Value = Me.BatchNumber
        .Range("E33").Value = Me.EmergencyAction1
        .Range("AG33").Value = Me.DateImplemented1
        .Range("E34").Value = Me.EmergencyAction2
        .Range("AG34").Value = Me.DateImplemented2
        .Range("E35").Value = Me.EmergencyAction3
        .Range("AG35").Value = Me.DateImplemented3
  '      .Range("AG35").Picture = Me.Photo (does not work)
       
    End With
   
    Set wsheet = Nothing
   
    wbook.Close True
    Set wbook = Nothing
   
    Set appExcel = Nothing
   
    MsgBox ("Supplier concern report number " & StrFileName2 & " has been created")
   
End Sub
0
Jeffrey CoachmanMIS LiasonCommented:
With a Hyperlink you may be out of luck.

You would have a better shot at this if you simply stored the path to the image in Excel.
Then you could just bring this in like any other field.
0
SweetingAAuthor Commented:
In the end i created a photo file in a known directory and picked it up from there.

Private Sub CreateReport_Click()
    Dim fso
    Dim strSourceFile As String
    Dim strDestFile As String
    Dim strFilename As String
    Dim strPhotoname As String
    Dim strST As String
    Dim stRM As String
    Dim strS As String
    Dim strR As String
   
    If Me.SCRCode <> "" Then
        strFilename = "SupplierConcernReport.xls"
        StrFileName2 = Me.SCRCode & ".xls"
        strPhotoname = Me.SCRCode & ".jpg"
        strSourceFile = "f:\Quality Systems\Supplier Concerns\Templates\" & strFilename
        strDestFile = "f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2
        Set fso = CreateObject("Scripting.FileSystemObject")
        fso.CopyFile strSourceFile, strDestFile, True
        Set fso = Nothing
    End If
   
    If Me.SpecialTransport = -1 Then
        strST = "ü"
        Else: strST = "û"
    End If
   
    If Me.ReplacementMaterial = -1 Then
        strRM = "ü"
        Else: strRM = "û"
    End If
   
    If Me.Scrap = -1 Then
        strS = "ü"
        Else: strS = "û"
    End If
   
    If Me.Rework = -1 Then
        strR = "ü"
        Else: strR = "û"
    End If
   
    Dim appExcel As Excel.Application
    Dim wbook As Excel.Workbook
    Dim wsheet As Excel.Worksheet
    Dim myPict As Excel.Picture
   
    Set appExcel = New Excel.Application
    appExcel.Visible = False
    Set wbook = appExcel.Workbooks.Open("f:\Quality Systems\Supplier Concerns\Associated Documents\" & StrFileName2)
    Set wsheet = wbook.Worksheets("SCR")
     
    If Dir("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname) <> "" Then
     
        With wsheet.Range("AA17")
            Set myPict = .Parent.Pictures.Insert("f:\Quality Systems\Supplier Concerns\Photos\" & strPhotoname)
            myPict.Top = .Top
            myPict.Left = .Left
            myPict.Placement = xlMoveAndSize
        End With
   
    End If
   
    With wsheet
        .Range("C5").Value = Me.SCRCode
        .Range("I5").Value = Me.SCRDate
        .Range("O5").Value = Me.Department
        .Range("U5").Value = Me.Site
        .Range("AC5").Value = Me.PrimaryContact
        .Range("AC6").Value = Me.ContactEmail
        .Range("AC7").Value = Me.ContactTel
        .Range("C17").Value = Me.Symtom
        .Range("I25").Value = Me.Classification
        .Range("S27").Value = strST
        .Range("S28").Value = strRM
        .Range("X27").Value = strS
        .Range("X28").Value = strR
        .Range("C12").Value = Me.PartNumber
        .Range("U12").Value = Me.BatchNumber
        .Range("E33").Value = Me.EmergencyAction1
        .Range("AG33").Value = Me.DateImplemented1
        .Range("E34").Value = Me.EmergencyAction2
        .Range("AG34").Value = Me.DateImplemented2
        .Range("E35").Value = Me.EmergencyAction3
        .Range("AG35").Value = Me.DateImplemented3
       
    End With
   
    Set wsheet = Nothing
   
    wbook.Close True
    Set wbook = Nothing
   
    Set appExcel = Nothing
   
    MsgBox ("Supplier concern report number " & StrFileName2 & " has been created")
   
End Sub
0
Jeffrey CoachmanMIS LiasonCommented:
<In the end i created a photo file in a known directory and picked it up from there.>
You Go Boy!

Why don't you accept your own post as the solution?

I mean, ...you actually solved your own issue.
Having your post (not mine) flagged as the actual solution would benefit other members here with the same issue.
Give your self some credit, ...even I am flagging this solution for future reference...

;-)

JeffCoachman
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.