Here is a screen shot of the Note message.
Here is another workspace of the Canadian regions which has a thematic theme and legend.
Here is the project code showing the respective modules.
Project file: Atlas.mbp
Application=..\Atlas.mbx
Module=Library\ARRAYLib.mbo
Module=Library\DEBUGLib.mbo
Module=Library\ERRORLib.mbo
Module=Library\RIBBONLib.mbo
Module=AtlasRibbonInterface.mbo
Module=Functions.mbo
Module=End_Program.mbo
Module=AtlasAbout.mbo
Module=MLB.mbo
Module=LayoutPortrait.mbo
Module=LayoutLandscape.mbo
Module=MLBOKButton.mbo
Module=SelectAllFromMLB.mbo
Module=HighLightSelectedRegions.mbo
Module=PopulateRegionsArray.mbo
Module=InputAtlasDefaultSettings
Module=Atlas_dialog.mbo
Module=AddMaps.mbo
Module=CreateRibbonMask.mbo
Module=RibbonMaskSettings.mbo
Module=CreateMaskMaps.mbo
Module=ShadeInfo1.mbo
Module=SearchReplace.mbo
Module=ThematicName.mbo
Module=CartoLegend
Additionally, Atlas.def has also been updated.
'** Project Atlas
'**
'** Definition file
'**
'** Author: Joseph Short
'** Date: 14 September 2017
'** Version: AppVersion (see below)
'************************************************************************************
Include "MAPBASIC.DEF"
Include "ICONS.DEF"
Include "MENU.DEF"
Declare Sub Main
Declare Sub End_Program
Declare Sub Endhandler
Declare Sub InputAtlasDefaultSettings
Declare Sub MLB
Declare Sub LayoutPortrait
Declare Sub LayoutLandscape
Declare Sub MLBOKButton
Declare Sub SelectAllFromMLB
Declare Sub HighLightSelectedRegions
Declare Sub PopulateRegionsArray
Declare Sub DlgHandler
Declare Sub Atlas_dialog
Declare Sub AddMaps
Declare Sub DialogHandler
Declare Sub AtlasAbout
Declare Sub RibbonMaskSettings
Declare Sub CreateMaskMaps
Declare Sub CreateRibbonMask
Declare Sub ShadeInfo1
Declare Sub ThematicName
Declare Sub LegendInfo
Declare Sub CartoLegend
Declare Sub WinFocusChangedHandler
Declare Function LongDate(ByVal dDate As Date) As String
Declare Function SearchReplace(ByVal strInput as String, ByVal strReplace as String, ByVal strReplacement as String) as String
'Function to check whether a table is open or not
Declare Function TableIsOpen (ByVal sTabName As String) As Logical
' ///// Class "MBExtensions.MBDateAndTime" /////
' Allows you to retreive information from a MapBasic Date (i.e. YYYYMMDD) or
' DateTime (i.e. YYYYMMDDHHMMSSFFF) string
' Convert the string to it's equivalent long date string representation
' (depends on Control Panel > Regional and Language Options)
Declare Method RegionalLongDate
Class "MBExtensions.MBDateAndTime"
Lib "MBExtensions.dll" (ByVal sDateString as string) As String
Define AppName "Ribbon Based Atlas Sample Code"
Define AppVersion "0.70"
Define MLBID 1001
Define SelectAllMLBID 1002
'Defining Dialog Width and Height
'This allows you to specify with and height clauses in terms of characters (i.e., Width 30dW, Height 10dH).
Define dW *4 'Four dialog units equals one character in width
Define dH *8 'Eight dialog units equals one character in height
Global tTime as Time
Global dDate as Date
Global sTabFile, sTable, sColA, sColB, sRegionsArray(), sAddressArray(5), sPrintDate, sCopyrightText, sFont, sRegion, sRegionTitle, sPrinterName, sDocTitle, sPapersize, sOutputFolder, sThematicLayer, sShadeText, sTotalString,sFirstLine, sFirstPart, sSecondPart,sFirstPartThematic, sSecondPartThematic, s_title, sColumn,sRec1, sLegendText As String
Global iRegionsSelectedArray(), iPaperChoice, iPapersize, iLogoWindowID, iMapWindowID, iInitialMapWindowID,iLayoutWindowID, iLayoutFontSize1, iLayoutFontSize2, iLayoutFontSize3, iLayoutFontSize4, iOrientation as Integer
Global fZoom, fMp, fPaper1, fPaper2, fPaperWidth, fPaperHeight, fHorizontalDistance, fVerticalDistance, fPos1, fPos2 As Float
Global lRegionObjectsSelected As Logical
Global l_create_mask, l_shadeInfo, is_thematic, is_legend, is_cartographic As Logical 'TRUE means include mask
Global sMaskTable, sMaskTabFilePath As String
Global sPctTranslucencyArray(5) As String
Global fX1, fY1, fX2, fY2 As Float
Global oRectangle, oCutter, oMask, ObjRegion As Object
Global iPctTranslucency As Integer
Global pPenStyle As Pen
Global alAlias,alTable As Alias
'** Project Atlas
'**
'** Module CartoLegend
'**
'** Author: Joseph Short
'** Date: 18 October 2017
'************************************************************************************
Include "Atlas.def"
Dim tables(), columns() as String '// Dim your array outside of any subs or functions so it is accessible to all in the module
'***************************************************************************************
Sub CartoLegend
Dim i, nCols, nTables, iMapWindowID, iWndLegend as Integer
Dim iColSelection, iTabSelection as Integer
iMapWindowID = FrontWindow()
'Check to see if the map window is in focus. When a workspace is loaded the 'cartographic legend is highlighted. For the program to work you need the focus 'in the map window
If WindowInfo(iMapWindowID, WIN_INFO_TYPE) <> WIN_MAPPER Then
Note "You need the map window in focus to use" + Chr$(10) + " thematic and cartographic options." + Chr$(10) + " Please click in the map window and start the Atlas program again" + Chr$(10) + " if you want to enable these features"
Exit Sub
End If
' Note that this code was created with information in the MapBasic Help LegendInfo() section.
For i = 1 to NumWindows()
If WindowInfo(WindowID(i), WIN_INFO_TYPE) = WIN_MAPPER Then
iMapWindowID = WindowInfo(WindowID(i), WIN_INFO_WINDOWID)
End if
If WindowInfo(WindowID(i), WIN_INFO_TYPE) = WIN_LEGEND_DESIGNER Then
iWndLegend = WindowInfo(WindowID(i), WIN_INFO_WINDOWID)
is_cartographic = TRUE
End if
Next
Call ThematicName
'******************************************************************************************
End Sub CartoLegend
'******************************************************************************************
'** Project Atlas
'**
'** Module ThematicName
'**
'** Author: Joseph Short
'** Date: 14 October 2017
'************************************************************************************
Include "Atlas.def"
Dim j,i as Integer
'*********************************************************************************************
Sub ThematicName
'*********************************************************************************************
If NumAllWindows() > 1 Then
iMapWindowID = FrontWindow()
If WindowInfo(iMapWindowID, WIN_INFO_TYPE) <> WIN_MAPPER Then
Note "You need the map window in focus to use" + Chr$(10) + " thematic and cartographic options." + Chr$(10) + " Please click in the map window and start the Atlas program again" + Chr$(10) + " if you want to enable these features"
Exit Sub
End If
' Check to see if there is a thematic layer
j= iMapWindowID
If WindowInfo(iMapWindowID, WIN_INFO_TYPE) = WIN_MAPPER Then
for i = 1 to MapperInfo(j,MAPPER_INFO_LAYERS)
If LayerInfo(j,i,LAYER_INFO_TYPE) = 3 Then
sThematicLayer = LayerInfo(j,i,LAYER_INFO_NAME)
is_thematic = TRUE
End If
Next
End If
End If
' If there is a thematic layer disable the cartographic option
If is_thematic = TRUE Then
is_cartographic = FALSE
End If
'*********************************************************************************************
End Sub ThematicName
'*********************************************************************************************
'** Project Atlas
'**
'** Module SearchReplace
'**
'** Author: Egg-Jan Polle
'** Date: 10th October 2017
'************************************************************************************
Include "Atlas.def"
'Search and replace function takes a string and returns a string as output
'For example: sTextField = SearchReplace(sTextField, ",","")
Function SearchReplace(ByVal strInput as String, ByVal strReplace as String, ByVal strReplacement as String) as String
Dim iPos as Integer
Dim strOut as String
Dim i as Integer
iPos = InStr(1, strInput, strReplace)
If iPos < 1 then '// nothing to replace, return original string
SearchReplace = strInput
Exit Function
End If
While iPos > 0 '// loop until nothing left to replace
If iPos > 1 then
strOut = Left$(strInput, iPos - 1)
End if
strOut = strOut & strReplacement
If iPos + Len(strReplace) - 1 < Len(strInput) then
strOut = strOut & Mid$(strInput, iPos + Len(strReplace), Len(strInput) - (iPos + Len(strReplace)) + 1)
End If
strInput = strOut
iPos = InStr(iPos + 1, strInput, strReplace)
Wend
SearchReplace = strOut
End Function
'** Project Atlas
'**
'** Module ShadeInfo1
'**
'** Author: Joseph Short
'** Date: 14 September 2017
'************************************************************************************
Include "Atlas.def"
Declare Function GetNextRecord(
ByVal sText As String, ' lines of text to parse
n As Integer) ' updated pointer into the text
As String ' returns the next line of text
'*********************************************************************************************
Sub ShadeInfo1
'*********************************************************************************************
Dim i, j, iResult, iFirstLine,iTotalLine, iDifference As Integer
Dim m,n, iLength, iStart, x, iPos1, iPos2, iPos3,iPos4, iPos5, iPos6 As Integer
Dim sText, sFirstLine, sPartial As String
Dim sRec As String
If is_thematic = True Then
If Len(sShadeText) > 0 Then
Exit Sub
End If
CLS
sText = WindowInfo(FrontWindow(), WIN_INFO_CLONEWINDOW )
'Print sText
j = Len(sText )
n = 1
Do While n < j
sRec = GetNextRecord( sText, n )
' look for the start of the shade clause
If Left$(sRec, 5) = "shade" Then
sRec1 = sRec
'Note "This is sRec1 " + sRec1
iPos1 = InStr(1, sRec,"with")
iPos2 = InStr(1, sRec,"ranges")
iPos3 = InStr(1, sRec1,"with")+ 4
iPos6 = InStr(1, sRec,"ignore")
If iPos6 > 0 Then
iPos4 = InStr(1, sRec1,"ignore")
Else
iPos4 = InStr(1, sRec1,"ranges")
End If
iLength = Len(sRec)
iStart = iLength - iPos1
iResult = iPos4 - iPos3
sColumn = Mid$(sRec1,iPos3,iResult)
iPos5 = InStr(1, sColumn,"_")
If iPos5 > 0 Then
sColumn = SearchReplace(sColumn, "_"," ")
End If
sFirstPart = Left$(sRec,6)
sSecondPart = Mid$(sRec,iPos1,iStart)
sFirstPartThematic = Left$(sRec,60)
sSecondPartThematic = Mid$(sRec,iPos1,iResult)
' gather up all the lines in the shade clause
sShadeText = ""
End If
If Like(sRec,"%0:%","") Then
Do While n < j
sShadeText = sShadeText + sRec
sRec = GetNextRecord( sText, n )
' all lines in the shade clause after the first start with a space.
If Like(sRec,"%#%","") Then
Exit Do
End If
Loop
End If
' if any thematic clause was found, display it and exit the loop
If Len(sShadeText) > 0 Then
l_shadeInfo = True
Exit Do
End If
Loop
End If
End Sub ShadeInfo1
Function GetNextRecord( ByVal sText As String, n As Integer ) As String
' Read the next record in a body of text
Dim m As Integer
Dim sRec As String
m = InStr( n, sText, "" + Chr$(10)) ' This code calculates the length of the string
sRec = Mid$( sText, n, (m-n+1)) 'This code calculates the text starting at n then going to length of the string minus n+1
n = m+1 'This code increments n to read length of m + 1
GetNextRecord = sRec
End Function
As this module has been updated since the last blog here is the code:
'** Project Atlas
'**
'** Module Atlas_dialog
'**
'** Author: Joseph Short
'** Date: 14 September 2017
'************************************************************************************
Include "Atlas.def"
Dim tables(), columns() as String '// Dim your array outside of any subs or functions so it is accessible to all in the module
'*********************************************************************************************
Sub Atlas_dialog
'*********************************************************************************************
Dim i, nCols, nTables as Integer
Dim iColSelection, iTabSelection as Integer
nTables = NumTables() '// get number of open tables
If nTables < 1 then
Note "Please open tables to create an atlas"
Exit Sub 'Exit Sub
End If
Call CartoLegend
If is_thematic = True Then
iInitialMapWindowID = FrontWindow()
If Len(sShadeText) > 0 Then
sShadeText = ""
End If
Call ShadeInfo1
End If
Redim tables(nTables) '// resize tables array to fit the number of open tables
For i = 1 to nTables
tables(i) = TableInfo(i, TAB_INFO_NAME) '// populate array with table names
Next
nCols = TableInfo(1, TAB_INFO_NCOLS) '// get number of columns from the first table
Redim columns(nCols) '// resize columns array to hold column names from first table
For i = 1 to nCols
columns(i) = ColumnInfo(1, "COL" & i, COL_INFO_NAME) '// populate array with column names
Next
Dialog
Title "Choose a table and column for your atlas"
Control PopUpMenu
ID 10
Width 100
Calling DlgHandler '// *** CHANGING THE VALUE OF THIS CONTROL WILL CALL DlgHandler ***
Title From Variable tables() '// Use array to get values for popupmenu
Into iTabSelection '// Store index of selected value into iSelection
Control PopupMenu
ID 20
Width 100
Title From Variable columns()
Into iColSelection
Control OkButton
Position 10, 28
If CommandInfo(CMD_INFO_DLG_OK) then '// Check that the OK button was clicked in dialog box
sTable = tables(iTabSelection) '// Get selected table value from array
sColA = columns(iColSelection) '// Get selected column value from array
End If
Call MLB
End Sub Atlas_dialog
Sub DlgHandler
Dim selID as Integer
Dim selTable as String
Dim nCols, i as Integer
If TriggerControl() = 10 then
selID = ReadControlValue(10) '// get the index of the selected item from the Control with ID 10
selTable = tables(selID) '// get the table name from the tables array using the index we just got
'// Resize and populate the columns array with the columns from the new table
nCols = TableInfo(selTable, TAB_INFO_NCOLS) '// get number of columns from the selected table
Redim columns(nCols) '// resize columns array to hold column names from selected table
For i = 1 to nCols
columns(i) = ColumnInfo(selTable, "COL" & i, COL_INFO_NAME) '// populate array with column names
Next
'// Now update the column popupmenu (ID 20) to use the new columns array
Alter Control 20 Title From Variable columns()
End If
'*********************************************************************************************
End Sub Atlas_dialog
'********************************************************************************************
After this stage the control again passes back to Atlas_dialog and a menu appears to enable the user to choose the appropriate layer and column to create the atlas.
Atlas_dialog then calls MLB which creates the list of regions present in the chosen map layer. When the user chooses one or more regions to print, the control is then passed to the CreateMasks module.
In the CreateMasks module there is a check to see if a mask is required. Then the AddMaps module is called to add all the other layers to the final map output. As this module has been updated to include code to create thematic maps here is the code for this module:
'** Project Atlas
'**
'** Module Add Maps
'**
'** Author: Joseph Short
'** Date: 14 September 2017
'************************************************************************************
Include "Atlas.def"
Dim tables(), columns() as String '// Dim your array outside of any subs or functions so it is accessible to all in the module
Global aTable, aCategory As Alias
'*********************************************************************************************
Sub AddMaps
'*********************************************************************************************
Dim i, nCols, nTables, iMapWindowID, iAddMapsWinID as Integer
Dim iColSelection, iTabSelection as Integer
nTables = NumTables() '// get number of open tables
If nTables < 1 then
Note "Please open tables to create the atlas"
Exit Sub 'Exit Sub
End If
Redim tables(nTables) '// resize tables array to fit the number of open tables
For i = 1 to nTables
tables(i) = TableInfo(i, TAB_INFO_NAME) '// populate array with table names
If tables(i) <> RegionSelected Then
Add Map Auto Layer tables(i)
Set Map Layer tables(i) Label Auto On
Set Map Layer tables(i) Label Font MakeFont(sFont,256,9,BLACK,16777215)
End If
Next
iMapWindowID = WindowID(FrontWindow())
If is_thematic = True Then
If Left$(sShadeText, 5) = "shade" Then
'Note "This is the second or subsequent time"
Run Command sShadeText
Else
'Note "This is the first time "
sShadeText = sFirstPart & sTable & " " & sSecondPart & sShadeText
'Print sShadeText
Run Command sShadeText
End If
End If
'*********************************************************************************************
End Sub AddMaps
'*******************************************************************************
Control then passes back to CreateMaskMaps. Here the LayoutPortrait and LayoutLandscape modules have been modified to accommodate cartographic and thematic legends.
Here is the code for LayoutPortrait:
'** Project Atlas
'**
'** Module LayoutPortrait
'**
'** Author: Joseph Short
'** Date: 14 September 2017
'************************************************************************************
Include "Atlas.def"
'*********************************************************************************************
Sub LayoutPortrait
'*********************************************************************************************
OnError Goto ErrorHandler
Dim i As Integer
Dim sAppPath As String
sAppPath = ApplicationDirectory$( )
Layout Designer
Position (10,10) Units "mm"
Width 210*fMp Units "mm" Height 297*fMp Units "mm"
iLayoutWindowID = WindowID(FrontWindow())
Set CoordSys Layout Units "mm"
Create Frame (10*fMp,20*fMp) (200*fMp,265*fMp)
Pen (1,2,0)
Brush (2,16777215,16777215)
From Window iMapWindowID
FillFrame On
'***************************************************************************************
If is_thematic = True Then
Create Designer Legend
Position (0,0) Units "mm"
Width 0 Units "mm" Height 0 Units "mm"
Custom
Default Frame Title "# Legend" Font ("Calibri",1,12,16711680)
Default Frame Subtitle "#" Font ("Arial",2,10,255)
Default Frame Style "%" Font ("Lucida Calligraphy",0,8,16732240)
Default Frame Line Width 36 Units "pt"
Default Frame Region Width 32 Units "pt"
Default Frame Region Height 14 Units "pt"
Default Frame Auto Font Size ON
' Note that here we need to use
' the thematic layer name from
' code provided earlier in the program
Frame From Layer sThematicLayer
Position (20*fMp,210*fMp) Units "mm"
Title sTable + " by " + sColumn
Priority 10
End If
'******************************************************************************************
If is_cartographic = True Then
Create Designer Legend
Position (0,0) Units "mm"
Width 0 Units "mm" Height 0 Units "mm"
Custom
Default Frame Title "# Legend" Font ("Calibri",1,12,16711680)
Default Frame Subtitle "#" Font ("Arial",2,10,255)
Default Frame Style "%" Font ("Lucida Calligraphy",0,8,16732240)
Default Frame Line Width 36 Units "pt"
Default Frame Region Width 32 Units "pt"
Default Frame Region Height 14 Units "pt"
Default Frame Auto Font Size ON
Frame From Layer 1
Using column object
label default
Position (20*fMp,30*fMp) Units "mm"
Frame From Layer 2
Using column object
label default
Position (20*fMp,50*fMp) Units "mm"
Frame From Layer 3
Using column object
label default
Position (20*fMp,65*fMp) Units "mm"
End If
'******************************************************************************************
Create Text
sCopyrightText
(197*fMp,264*fMp) (197*fMp,350*fMp)
'(197*fMp,264*fMp) (200*fMp,350*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,6316128,WHITE)
Angle 90
Create Text
sDocTitle
(10*fMp,10*fMp) (200*fMp,20*fMp)
Font MakeFont(sFont,0,iLayoutFontSize3,BLACK,WHITE)
Create Text
"Print Date:"
(64*fMp,266*fMp) (200*fMp,274*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Create Text
sPrintDate
(80*fMp,266*fMp) (200*fMp, 274*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Create Text
"Scale:"
(64*fMp,270*fMp) (200*fMp,278*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Create Text
"1 : " + Format$(fZoom, ",#")
(80*fMp,270*fMp) (200*fMp, 278*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Create Text
"Paper Size:"
(64*fMp,274*fMp) (200*fMp,282*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Create Text
sPapersize
(80*fMp,274*fMp) (200*fMp, 282*fMp)
Font MakeFont(sFont,0,iLayoutFontSize1,BLACK,WHITE)
Add Image Frame Window iLayoutWindowID
Position (11*fMp,269*fMp) Units "mm" '(1.139, 26.535) Units "cm" (39*fMp,287*fMp)
Width 22 Units "mm" '6.112 Units "cm"
Height 16 Units "mm" '1.455 Units "cm"
From File sAppPath + "\Images\Company_logo.png"
fPos1 = 275.5*fMp
fPos2 = 283.5*fMp
For i = 1 to 5
fPos1 = fPos1 + 2*fMp
fPos2 = fPos2 + 2*fMp
Create Text
sAddressArray(i)
(42*fMp,fPos1) (90*fMp,fPos2)
Font MakeFont(sFont,0,iLayoutFontSize4,BLACK,WHITE)
Next
Create Rect (10*fMp,265*fMp) (200*fMp,288*fMp)
Pen (1,2,8421504)
Brush (1,16777215,16777215)
Create Line (62*fMp,265*fMp) (62*fMp,277*fMp)
Pen (1,2,8421504)
Create Line (78*fMp,265*fMp) (78*fMp,277*fMp)
Pen (1,2,8421504)
Create Line (110*fMp,265*fMp) (110*fMp,277*fMp)
Pen (1,2,8421504)
Create Line (62*fMp,269*fMp) (110*fMp,269*fMp)
Pen (1,2,8421504)
Create Line (62*fMp,273*fMp) (110*fMp,273*fMp)
Pen (1,2,8421504)
Create Line (40*fMp,277*fMp) (200*fMp,277*fMp)
Pen (1,2,8421504)
'Create Frame (11*fMp,266*fMp) (39*fMp,287*fMp)
'Pen (1,1,0)
'Brush (2,16777215,16777215)
'From Window iLogoWindowID
Create Line (40*fMp,265*fMp) (40*fMp,288*fMp)
Pen (1,2,8421504)
Set Layout Ruler On Pagebreaks On Frame Contents On
Zoom 33.3333
Set Window FrontWindow() Autoscroll On
Set Window FrontWindow() Title sDocTitle + " Layout"
Set Window FrontWindow() Printer
Name sPrinterName Orientation Portrait Copies 1
Papersize iPapersize
Exit Sub
'---------------------------
ErrorHandler:
'Note Error$()
'*********************************************************************************************
End Sub LayoutPortrait
'********************************************************************************************
The same code changes are also incorporated in the LayoutLandscape module. These changes enable the user to produce a series of maps with either a cartographic legend or a thematic layer and thematic legend.
Here are some more examples from the MapInfo trial data set.
The Atlas program could be customised further to enable a company or organisation to include data in their maps about population, area, sales or other relevant data which may need to be updated on a daily, weekly, monthly, quarterly or yearly basis. As you can see with the Atlas program, using MapBasic code you can automate many mapping tasks which would otherwise take considerable time and effort to carry out by manual efforts using MapInfo Professional.