PDA

View Full Version : Multi pushpin sets on drivetime coded VBA code



Banana Co
12-03-2013, 07:11 AM
Hi All, I'm looking for some help on a project i'm doing with Mappoint. I'm not a coder so you'll have to go easy on me.

Basically, I found some code online (probably from here) which helped me set drivetime areas against uk postcodes. It took a bit of editing for my data and european mappoint but it now works.

What I would like to do next is set the data into different pushpin sets depending on if a record is equal to 'WW' or equal to 'CTX' from my spreadsheet.

My code so far looks like this...



Dim oApp As MapPoint.Application
Private Sub CommandButton1_Click()

Set oApp = CreateObject("MapPoint.Application.EU.19")
oApp.Visible = True
Set objMap = oApp.NewMap

'start reading on row 2 of spreadsheet
nReadRow = 4
nShapeIndex = 1

'test to see if there is an address in column 1 (A) for the current row
Do While Worksheets("Dealer information").Cells(nReadRow, 1) <> ""

szAddress1 = Worksheets("Dealer information").Cells(nReadRow, 3)
szTown = Worksheets("Dealer information").Cells(nReadRow, 5)
szCounty = Worksheets("Dealer information").Cells(nReadRow, 6)
szPostcode = Worksheets("Dealer information").Cells(nReadRow, 7)
fDriveTime = Worksheets("Dealer information").Cells(nReadRow, 18 )
nColor = AssignColor(Worksheets("Dealer information").Cells(nReadRow, 19))

Set objLoc = objMap.FindAddressResults( _
szPostcode, szAddress1, szTown, szCounty)(1)

objMap.AddPushpin objLoc, _
Worksheets("Dealer information").Cells(4, 1)

objMap.Shapes.AddDrivetimeZone objLoc, fDriveTime * geoOneMinute
objMap.Shapes.Item(nShapeIndex).Fill.Visible = True
objMap.Shapes.Item(nShapeIndex).ZOrder (geoSendBehindRoads)
objMap.Shapes.Item(nShapeIndex).Fill.ForeColor = nColor
objMap.Shapes.Item(nShapeIndex).Line.ForeColor = vbBlack
objMap.Shapes.Item(nShapeIndex).Line.Weight = 1

nShapeIndex = nShapeIndex + 1
nReadRow = nReadRow + 1
Loop

objMap.DataSets.ZoomTo

End Sub

Function AssignColor(szColor)

'MsgBox szColor

Select Case szColor
Case "red"
AssignColor = vbRed
Case "green"
AssignColor = vbGreen
Case "yellow"
AssignColor = vbYellow
Case "blue"
AssignColor = vbBlue
Case "magenta"
AssignColor = vbMagenta
Case "cyan"
AssignColor = vbCyan
Case "white"
AssignColor = vbWhite
Case "black"
AssignColor = vbBlack

End Select

'MsgBox AssignColor
'AssignColor = vbRed

End Function


Could someone give me some pointers on how i would do this? I'm afraid this is my first go with VBA so go easy on me :wacko2:

Many thanks in advance!

Edit : It should be an 8 in the code, not a smiley face.... but I guess you'd have figured that eh?

Eric Frost
12-03-2013, 11:30 AM
Banana Co,

I recognize this code! Off the top of my head, I believe it's probably from one of the past newsletters --
MP2K Update Archives (http://www.mp2kmag.com/update/)

Welcome to the forums and congrats on your first post! I hope you find the forum useful and fun to participate. Please don't hesitate to share any suggestions or pertinent observations.

Regarding your question, would it be possible to zip and share a sample spreadsheet or table with some sample data? That will make it easier to see what's going on, what column data is in, etc. and to prepare sample code to do what you want.

Just zip the spreadsheet and post here as an attachment to a post.

It might help to have the macro and data altogether in a single spreadsheet.

Looking forward to your reply.

Eric

Banana Co
12-04-2013, 03:11 AM
Hi Eric, Many thanks for the reply, I had a feeling the code had originated from somewhere around here but i'd googled so much i'd kind of lost track!

I've uploaded the file i'm using, although i notice that it says if its not used within an hour of upload it will be removed. I think we're on different time zones so maybe i'll re-upload later on today.

Thanks again!

798

Eric Frost
12-06-2013, 11:42 AM
This might sound bad, but I think what I want to do is leave all that code alone and working and not touch it.

Instead at the end, I will copy/paste (duplicate) the Pushpin dataset and then loop over both the the pushpin sets and delete the ones that don't match that dataset.

I will post the code shortly (if it works!)

Eric

Eric Frost
12-06-2013, 12:39 PM
I did it! I did have to change the code above just a little bit to store the CTX/WW information in the .Note property so it would know what to delete later.

Here's a screenshot --

800

Note that I changed the Pushpin Symbol manually.

The code --



Dim oApp As MapPoint.Application
Private Sub CommandButton1_Click()

Set oApp = CreateObject("MapPoint.Application.EU")
oApp.Visible = True
Set objMap = oApp.NewMap

'start reading on row 2 of spreadsheet
nReadRow = 4
nShapeIndex = 1

Dim pp As MapPoint.Pushpin

'test to see if there is an address in column 1 (A) for the current row
Do While Worksheets("Dealer information").Cells(nReadRow, 1) <> ""

szAddress1 = Worksheets("Dealer information").Cells(nReadRow, 3)
szTown = Worksheets("Dealer information").Cells(nReadRow, 5)
szCounty = Worksheets("Dealer information").Cells(nReadRow, 6)
szPostcode = Worksheets("Dealer information").Cells(nReadRow, 7)
fDriveTime = Worksheets("Dealer information").Cells(nReadRow, 18)
nColor = AssignColor(Worksheets("Dealer information").Cells(nReadRow, 19))

Set objLoc = objMap.FindAddressResults( _
szPostcode, szAddress1, szTown, szCounty)(1)

Set pp = objMap.AddPushpin(objLoc, Worksheets("Dealer information").Cells(nReadRow, 1))
pp.Note = Worksheets("Dealer information").Cells(nReadRow, 20)

objMap.Shapes.AddDrivetimeZone objLoc, fDriveTime * geoOneMinute
objMap.Shapes.Item(nShapeIndex).Fill.Visible = True
objMap.Shapes.Item(nShapeIndex).ZOrder (geoSendBehindRoads)
objMap.Shapes.Item(nShapeIndex).Fill.ForeColor = nColor
objMap.Shapes.Item(nShapeIndex).Line.ForeColor = vbBlack
objMap.Shapes.Item(nShapeIndex).Line.Weight = 1

nShapeIndex = nShapeIndex + 1
nReadRow = nReadRow + 1
Loop

objMap.DataSets.ZoomTo

objMap.DataSets(1).Copy
objMap.Paste

objMap.DataSets(1).Name = "WW"
objMap.DataSets(2).Name = "CTX"

Dim rs As MapPoint.Recordset

Set rs = objMap.DataSets(1).QueryAllRecords
rs.MoveFirst
Do While Not rs.EOF
If rs.Pushpin.Note = "CTX" Then
rs.Pushpin.Delete
End If
rs.MoveNext
Loop

Set rs = objMap.DataSets(2).QueryAllRecords
rs.MoveFirst
Do While Not rs.EOF
If rs.Pushpin.Note = "WW" Then
rs.Pushpin.Delete
End If
rs.MoveNext
Loop


End Sub


Hope this helps!

Eric

Banana Co
12-10-2013, 07:03 AM
Thanks Eric, looks great, i'll have a play with it now!

Banana Co
12-10-2013, 10:31 AM
Hi Eric,
it works really well, however it does seem to have an issue with ...
nColor = AssignColor(Worksheets("Dealer information").Cells(nReadRow, 19))

If I remove that line its ok, does the spreadsheet need colour added in a particular format?

Also i'm guessing having different pins is an issue ;-)

Eric Frost
12-10-2013, 01:50 PM
Hi Eric,
it works really well, however it does seem to have an issue with ...
nColor = AssignColor(Worksheets("Dealer information").Cells(nReadRow, 19))

If I remove that line its ok, does the spreadsheet need colour added in a particular format?


Well, the function AssignColor is only set up to work with the colors listed in that function, but if you want other colors we can work on that.


Also i'm guessing having different pins is an issue ;-)

What do you mean? Different Pushpin Symbols? What is the issue?

hope to help!

Eric