A
AKTransplant
I have a project that seemed easy at first glance. Simply stated, I
want to insert a cropped and sized .PNG image from a website into my
worksheet at a predetermined location.
It wasn't that easy (I'm new at VBA, so bear with me). I started out
with little knowledge of VBA and my code is a Frankenstein collection
of recorded macros and cuts and pastes (mostly from this board). This
code does the following:
1. Clears all pictures on the active sheet for a clean slate
2. Adds a new worksheet (temp) to perform all the work of the macro
3. Change the date to now +9 hours (to construct the webquery URL)
4. Webquery the constructed URL and paste results to temp worksheet
5. Delete columns A of the query results (unneeded)
6. AutoFilter for all cells that end with a static text string (the
picture I need always ends with this string)
7. Copy Filter results to bottom of worksheet (just to get them out of
the way for now)
8. Delete Range containing WebQuery results
9. Sort filter results in descending order (the beginning of each cell
is a time in hhhhmmss (GMT) format so the most recent picture would end
up being sorted to the top in cell A1)
10. Open up Internet Explorer to URL constructed much like the
Webquery, but concatenating the value of cell A1 at the end of it.
11. SendKeys to Internet Explorer to:
a. Select All
b. Copy
c. Close
12. Paste Picture to cell A2
13. Crop and Size Picture
14. Copy Picture
15. Paste Picture back to Main Sheet
16. Move Picture to just the right spot
17. Delete "temp" sheet
I am still left with one problem: Error Handling. If my Webquery (step
4) tries to go to the current GMT day's URL and that URL hasn't been
created yet, I would like to turn back the clock in my code by one day
to pull the query info from the previous day's (GMT) URL. I would like
to do the same Error handling when I create the URL in step 10 above.
Finally, I'm willing to bet that there's an easier/more elegant way to
do all of this. Any ideas would be greatly appreciated. Here's the
code (URLs have been changed to protect the innocent):
Sub SurfaceChart()
'
' SurfaceChart Macro
' Macro recorded 12/7/2006 by
'
ActiveSheet.Pictures.Delete
Worksheets.add
ActiveSheet.Name = "temp"
Dim I As Date
I = Now() + 0.375
With ActiveSheet.QueryTables.add(Connection:= _
"URL;https://www.whatevercomesfirst" & Format(I, "yyyymm") &
"/" & Format(I, "dd") & "/ANALYSIS/ALASKA", _
Destination:=Range("A1"))
.Name = "ALASKA_5"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("A").Select
Selection.Delete Shift:=xlToLeft
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:= _
"=*_MY_PICTURE_ALWAYS_ENDS_WITH_THIS.PNG", Operator:=xlAnd
If ActiveSheet.AutoFilterMode Then
Set rng = ActiveSheet.AutoFilter.Range
rng.Copy Destination:=Worksheets("temp").Range("A500")
Debug.Print rng.Address
Else
MsgBox "No filter in place"
End If
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:= _
"=*_MY_PICTURE_ALWAYS_ENDS_WITH_THIS.PNG", Operator:=xlAnd
Selection.AutoFilter
Rows("1:500").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWorkbook.FollowHyperlink
Address:="https://www.whatevercomesfirst" & Format(I, "yyyymm") & "/" &
Format(I, "dd") & "/ANALYSIS/ALASKA/" & Range("A1").Value
SendKeys ("%E"), True
SendKeys ("A"), True
SendKeys ("%E"), True
SendKeys ("C"), True
SendKeys ("%{F4}"), True
Range("A2").Select
ActiveSheet.Paste
ActiveSheet.Shapes("Picture 6").Select
Selection.ShapeRange.PictureFormat.CropTop = 132#
Selection.ShapeRange.PictureFormat.CropRight = 191.37
Selection.ShapeRange.PictureFormat.CropLeft = 203.39
Selection.ShapeRange.PictureFormat.CropBottom = 201.75
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 190.5
Selection.ShapeRange.Width = 227.25
Selection.ShapeRange.Rotation = 0#
Selection.Copy
Sheets("MEF Worksheet").Select
Range("H3").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -0.75
Selection.ShapeRange.IncrementTop -11.25
Application.DisplayAlerts = False
Sheets("temp").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Range("A3:G17").Select
End Sub
Any help is greatly appreciated. Thanks in advance
want to insert a cropped and sized .PNG image from a website into my
worksheet at a predetermined location.
It wasn't that easy (I'm new at VBA, so bear with me). I started out
with little knowledge of VBA and my code is a Frankenstein collection
of recorded macros and cuts and pastes (mostly from this board). This
code does the following:
1. Clears all pictures on the active sheet for a clean slate
2. Adds a new worksheet (temp) to perform all the work of the macro
3. Change the date to now +9 hours (to construct the webquery URL)
4. Webquery the constructed URL and paste results to temp worksheet
5. Delete columns A of the query results (unneeded)
6. AutoFilter for all cells that end with a static text string (the
picture I need always ends with this string)
7. Copy Filter results to bottom of worksheet (just to get them out of
the way for now)
8. Delete Range containing WebQuery results
9. Sort filter results in descending order (the beginning of each cell
is a time in hhhhmmss (GMT) format so the most recent picture would end
up being sorted to the top in cell A1)
10. Open up Internet Explorer to URL constructed much like the
Webquery, but concatenating the value of cell A1 at the end of it.
11. SendKeys to Internet Explorer to:
a. Select All
b. Copy
c. Close
12. Paste Picture to cell A2
13. Crop and Size Picture
14. Copy Picture
15. Paste Picture back to Main Sheet
16. Move Picture to just the right spot
17. Delete "temp" sheet
I am still left with one problem: Error Handling. If my Webquery (step
4) tries to go to the current GMT day's URL and that URL hasn't been
created yet, I would like to turn back the clock in my code by one day
to pull the query info from the previous day's (GMT) URL. I would like
to do the same Error handling when I create the URL in step 10 above.
Finally, I'm willing to bet that there's an easier/more elegant way to
do all of this. Any ideas would be greatly appreciated. Here's the
code (URLs have been changed to protect the innocent):
Sub SurfaceChart()
'
' SurfaceChart Macro
' Macro recorded 12/7/2006 by
'
ActiveSheet.Pictures.Delete
Worksheets.add
ActiveSheet.Name = "temp"
Dim I As Date
I = Now() + 0.375
With ActiveSheet.QueryTables.add(Connection:= _
"URL;https://www.whatevercomesfirst" & Format(I, "yyyymm") &
"/" & Format(I, "dd") & "/ANALYSIS/ALASKA", _
Destination:=Range("A1"))
.Name = "ALASKA_5"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("A").Select
Selection.Delete Shift:=xlToLeft
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:= _
"=*_MY_PICTURE_ALWAYS_ENDS_WITH_THIS.PNG", Operator:=xlAnd
If ActiveSheet.AutoFilterMode Then
Set rng = ActiveSheet.AutoFilter.Range
rng.Copy Destination:=Worksheets("temp").Range("A500")
Debug.Print rng.Address
Else
MsgBox "No filter in place"
End If
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:= _
"=*_MY_PICTURE_ALWAYS_ENDS_WITH_THIS.PNG", Operator:=xlAnd
Selection.AutoFilter
Rows("1:500").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlDescending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ActiveWorkbook.FollowHyperlink
Address:="https://www.whatevercomesfirst" & Format(I, "yyyymm") & "/" &
Format(I, "dd") & "/ANALYSIS/ALASKA/" & Range("A1").Value
SendKeys ("%E"), True
SendKeys ("A"), True
SendKeys ("%E"), True
SendKeys ("C"), True
SendKeys ("%{F4}"), True
Range("A2").Select
ActiveSheet.Paste
ActiveSheet.Shapes("Picture 6").Select
Selection.ShapeRange.PictureFormat.CropTop = 132#
Selection.ShapeRange.PictureFormat.CropRight = 191.37
Selection.ShapeRange.PictureFormat.CropLeft = 203.39
Selection.ShapeRange.PictureFormat.CropBottom = 201.75
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 190.5
Selection.ShapeRange.Width = 227.25
Selection.ShapeRange.Rotation = 0#
Selection.Copy
Sheets("MEF Worksheet").Select
Range("H3").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -0.75
Selection.ShapeRange.IncrementTop -11.25
Application.DisplayAlerts = False
Sheets("temp").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Range("A3:G17").Select
End Sub
Any help is greatly appreciated. Thanks in advance