Page 1 of 2 12 LastLast
Results 1 to 15 of 19
  1. #1
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts

    Copy pic from every site with URL in column A

    Is there VBA what would enable each cell in column A (which is a hyperlink) to go to that page and then copy a PNG image from the page and save it in a particular folder on my external drive? The pics are always in the same spot on each page that's linked from each cell.

    Manually, I have to click on the link, get to the page, right mouse click on the image, and save the PNG file.

    Unfortunately, there are more than 1000 of these to do.

    Would be nice to automate.

  2. #2
    WS Lounge VIP
    Join Date
    Mar 2002
    Location
    Newcazzle, UK
    Posts
    2,826
    Thanks
    136
    Thanked 482 Times in 459 Posts
    Hi

    Perhaps you could provide a sample link showing us the png image you want to save.
    Are they pictures of cats or what???

    zeddy

  3. #3
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    :-) No Cats!

    Baseball players.

    Here's what I have: http://espn.go.com/mlb/player/_/id/28513/adam-jones
    But on that page, I want the photo that's: i.png (if I right mouse click it)

    Here's another: http://espn.go.com/mlb/player/_/id/28575/alexi-casilla
    Same situation, the image is an i.png on the page.

  4. #4
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    The following code works but I don't know if it is what you want.
    I investigated where the pictures were actually stored and found out that they where here:
    http://a.espncdn.com/combiner/i?img=/i/headshots/mlb/players/full/[PlayerID No].png&w=350&h=254
    So by extracting the PlayerID No from the URL and putting it in the URL and then feeding the URL to Insert Picture you get this:
    bbplayers.JPG

    Here's the code:
    Code:
    Option Explicit
    
    Sub RetrievePicture()
    
       Dim vParts As Variant
       
       [B1].Select
       
       Do
         vParts = Split(ActiveCell.Offset(0, -1).Value, "/")
    '     Debug.Print vParts(7)
         ActiveSheet.Pictures.Insert ("http://a.espncdn.com/combiner/i?img=/i/headshots/mlb/players/full/" _
                                      & vParts(7) & ".png&w=350&h=254")
         Selection.RowHeight = 160
         ActiveCell.Offset(1, 0).Select
       Loop Until ActiveCell.Offset(0, -1) = ""
    
    End Sub
    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  5. #5
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    I selected a cell in which there's a hyperlink. Ran the macro but got an error.

    Subscript out of range.

    What did I do incorrectly?

  6. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    The code assumes that there are url's in col A with no breaks until the end of the list.
    The code also automatically starts the code in cell B1 where the 1st picture goes if this is not the case you need to change the [B1].Select to the appropriate cell in Col B.
    HTH

    Sample File: Execl - VBA - Capture Pictures from Internet.xlsm

    P.S. The code also assumes that the text for the hyperlink is the same as the address! If this is not the case I may need to adjust the code to pull the HyperLink Address vs the cell value.
    Last edited by RetiredGeek; 2013-06-28 at 13:07.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  7. #7
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    Here's revised code that pulls the URL from the Hyperlink and will work if the Hyperlink text is the same or different than the URL.
    Code:
    Option Explicit
    
    Sub RetrievePicture()
    
       Dim vParts As Variant
       
       [B1].Select
       
       Do
         vParts = Split(ActiveCell.Offset(0, -1).Hyperlinks(1).Address, "/")
    '     Debug.Print vParts(7)
         ActiveSheet.Pictures.Insert ("http://a.espncdn.com/combiner/i?img=/i/headshots/mlb/players/full/" _
                                      & vParts(7) & ".png&w=350&h=254")
         Selection.RowHeight = 160
         ActiveCell.Offset(1, 0).Select
       Loop Until ActiveCell.Offset(0, -1) = ""
    
    End Sub
    HTH

    Sample File: Execl - VBA - Capture Pictures from Internet.xlsm
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  8. #8
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    I'm attaching your file with a few more lines in column A. They are hyperlinks. Is that the issue?

  9. #9
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    Revised code works as does revised sample file. First sample file the value in A1 was not HyperLink just text my BAD!
    Just discovered another problem with the code as it bombs on Charles Brewer since there is no picture on the ESPN page.
    Back to the drawing board! Stay tuned.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  10. #10
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    Oh, right...When I was doing this the long way, I found a few didn't have posted photos.

  11. #11
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    Ok, hopefully this is the final version.
    Code:
    Option Explicit
    
    Sub RetrievePicture()
    
       Dim vParts As Variant
       
       [B1].Select
       
       Do
         vParts = Split(ActiveCell.Offset(0, -1).Hyperlinks(1).Address, "/")
    '     Debug.Print vParts(7)
         On Error GoTo MissingESPNPic
         ActiveSheet.Pictures.Insert ("http://a.espncdn.com/combiner/i?img=/i/headshots/mlb/players/full/" _
                                      & vParts(7) & ".png&w=350&h=254")
         Selection.RowHeight = 160
    RestartMissingPic:
         ActiveCell.Offset(1, 0).Select
       Loop Until ActiveCell.Offset(0, -1) = ""
    GoTo GetOut
    
    MissingESPNPic:
    
      If Err = 1004 Then
        Resume RestartMissingPic
      Else
        MsgBox "Error: " & Format(Err) & _
                   "Error Text: " & Err.Description, _
                   vbOKOnly + vbCritical, _
                   "UnTrapped Error Occured!"
        Resume GetOut
      End If
    
    GetOut:
    
    End Sub
    Note: Charles Brewer & Chase Anderson have no Pics!

    HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  12. The Following User Says Thank You to RetiredGeek For This Useful Post:

    kweaver (2013-06-28)

  13. #12
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    SLICK! That did the trick.

  14. #13
    Bronze Lounger
    Join Date
    Jan 2001
    Location
    La Jolla, CA
    Posts
    1,470
    Thanks
    30
    Thanked 62 Times in 58 Posts
    Say, RG. Since those pics are not really various B column cells, is there an Excel formula that would indicate which cells in the B column have an overlay pic? ISBLANK won't do it because they're really all blank.

  15. #14
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Kevin,

    You could modify the code to place a number or letter in the Bn cell that has a picture and use that to make the determination. Sorry I can't come up with anything more elegant. HTH
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  16. #15
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,637
    Thanks
    115
    Thanked 650 Times in 592 Posts
    KW

    Here is a slight variation to RG's Code. Select the range of cells and run the code. It will get the hyperlink addresses from the cells and use RG's code to abstract the player's IDs. Using the IDs, it will grab the photo from the image's URLs. It will also obtain the player's names, assign it to the file names, then save the pics to your desired folder. The issue of a player with no pic, blank cells, or cells with no hyperlinks are addressed.

    Note: Change the path to the path of the desired folder. Place code in a standard module. BTW, to get the URL for the picture, right click the pic and select Properties.

    BBPics3.png BBPics4.png

    Code:
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
      "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
        szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    
    Sub GetWebPic()
        Dim Path As String
        Dim Pic As Long
        Dim Link As String
        Dim Player As Variant
        Dim Cell As Range
    On Error Resume Next
    
    For Each Cell In Selection.Cells
        Link = Cell.Hyperlinks(1).Address
        Player = Split(Link, "/")
        Path = "C:\Users\Maudibe\Desktop\Orioles\" & Player(8) & ".png"
        Pic = URLDownloadToFile(0, "http://a.espncdn.com/combiner/i?img=/i/headshots/mlb/players/full/" _
                                      & Player(7) & ".png&w=350&h=254", Path, 0, 0)
    Next Cell
    
    End Sub
    HTH,
    Maud
    Attached Files Attached Files
    Last edited by Maudibe; 2013-06-29 at 08:12. Reason: added file

Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •