Private Sub Workbook_Open()
Dim ws As Worksheet
Dim nm As Range
Dim buffer As Range
Set ws = ThisWorkbook.Sheets("Site_Report")
Set nm = ws.Range("Site_Analysis_Selected_Site")
Set buffer = ws.Range("Site_Buffer_Selected")
' nm.Activate 'previously caused error 1004 but no longer in use
nm.FormulaR1C1 = "=IFERROR(PROPER(INDEX(DE_Loc_Name,1)),"""")"
' buffer.Activate
buffer.FormulaR1C1 = "=IFERROR(PROPER(INDEX(DE_Unique_Buffer,1)),"""")"
Range("Q4").Select
End Sub
'change picture without change image size
Sub change_picture()
Dim Loc As String
Dim i, pfile, strpic, shp, t, l, h, w, shp2 As Variant
Loc = "http://maps.googleapis.com/maps/api/staticmap?scale=2&autoscale=1&size=640x380&maptype=roadmap&format=png&visual_refresh=true&" + Cells(45, 1).Value
For i = 49 To 123
If Cells(i, 1).Value <> "" Then
Loc = Loc + Cells(i, 1).Value
End If
Next i
shortenergoogle (Loc)
pfile = DownloadFile(Loc)
If pfile <> "Error" Then
strpic = "MapImage"
Set shp = ActiveSheet.Shapes(strpic)
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
DoEvents
Set shp2 = ActiveSheet.Shapes.AddPicture(pfile, msoFalse, msoTrue, l, t, w, h)
shp.Delete
shp2.Name = strpic
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim keycells As Range
Dim mapcells As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Site_Report")
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set keycells = ws.Range("Q2")
[B] If Not Application.Intersect(keycells, Range(Target.Address)) _[/B]
[B] Is Nothing Then [/B]'this is the line of code causing the current 1004 error
Call change_picture
End If
Set mapcells = ws.Range("Q3")
If Not Application.Intersect(mapcells, Range(Target.Address)) _
Is Nothing Then
Call change_picture
End If
End Sub
Sub shortenergoogle(ByVal url As String)
Dim Token, EndAPI, InText, FimText, JSONString As String
Token = "AIzaSyA5ha9R1tQRZpjzrIhRFeoQGcT7GwPX2c0"
Dim HttpReq As New WinHttpRequest
Dim response As String
Dim result As Variant
EndAPI = "https://www.googleapis.com/urlshortener/v1/url?key=" + Token
On Error Resume Next 'This is to avoid errors on invalid URLs
JSONString = "{""longUrl"": """ + url + """}"
With HttpReq
.Open "POST", EndAPI, False
.SetRequestHeader "Content-Type", "application/json"
.Send JSONString
End With
response = HttpReq.ResponseText
HttpReq.WaitForResponse
result = Left(Mid(response, 40), InStr(response, "longUrl") - InStr(response, "https") - 5)
Cells(12, 3).Value = result
'Set shp = ActiveSheet.Shapes.AddPicture(result, msoFalse, msoTrue, l, t, w, h)
'ActiveSheet.Shapes(strPic).Visible = True
'ActiveSheet.Shapes(strPic).Delete
'ActiveSheet.Shapes(strPic).Visible = False
End Sub
Function DownloadFile(ByVal myurl As String) As String
Dim url, str_tmppath, ostream, pfile As Variant
'myURL = "https://YourWebSite.com/?your_query_parameters"
url = myurl
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myurl, False, "username", "password"
WinHttpReq.Send
str_tmppath = Environ("temp")
pfile = str_tmppath + "\file.png"
myurl = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set ostream = CreateObject("ADODB.Stream")
ostream.Open
ostream.Type = 1
ostream.Write WinHttpReq.responseBody
ostream.SaveToFile pfile, 2 ' 1 = no overwrite, 2 = overwrite
ostream.Close
DownloadFile = pfile
Else
DownloadFile = "Error"
End If
End Function
