VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ThisDocument" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit Private Sub UIButtonControl1_Click() '1989 Michael Silberbauer - Pascal program to draw individual symbols, stuck on map by hand '1992 Michael Silberbauer - C version '1993-10 Michael Silberbauer - AML version in ArcInfo (see comments at end of procMauchaPolygon() ) '2000-10 Michael Silberbauer - Avenue version '2006-03-03? Michael Silberbauer - Adapted code by Hagen Probsthain 2003-03-25 that drew lines, polylines on open map '2006-05-12 Willie Geldenhuys - produced a different procedure in Visual Basic, based on this '2008-05-08 Michael Silberbauer - Got successful plots, with the rays in the correct colours for the first time '2008-05-13 Michael Silberbauer - Incorporated suggestions of Abel Perez [Abel.Perez@aa.com] for projecting points '2008-05-14 Michael Silberbauer - added grouping of symbol components (can only move them with arrow keys, not mouse) Call procGraphicMaucha End Sub Sub procGraphicMaucha() Dim pPoint As IPoint Dim pActiveView As IActiveView Dim pMap As IMap Dim pProjCoordSys As IProjectedCoordinateSystem Dim pGeoCoordSystem As ISpatialReference Dim pSpatialReferenceMap As ISpatialReference Dim pSpatRefFact As ISpatialReferenceFactory Set pSpatRefFact = New SpatialReferenceEnvironment Set pGeoCoordSystem = pSpatRefFact.CreateGeographicCoordinateSystem(esriSRGeoCS_WGS1984) Dim pGraphicsContainer As IGraphicsContainer Dim pPolygonElement As IPolygonElement Dim pElement As IElement Dim theCoords As Variant Dim SymbolScale As Single Dim xCentre As Double, yCentre As Double Dim Potassium As Single, Sodium As Single, Calcium As Single, Magnesium As Single Dim Chloride As Single, Sulphate As Single, TotalAlk As Single, pH As Single Dim TotalDisSalt As Single Dim pApp As IApplication Set pApp = Application Dim pDoc As IMxDocument Set pDoc = ThisDocument Set pActiveView = pDoc.ActiveView Set pMap = pDoc.FocusMap Set pSpatialReferenceMap = pMap.SpatialReference 'symbolScale = ( x2m - x1m ) / 100 ' based on screen extent SymbolScale = InputBox("Please enter a scale", "Maucha symbols", 25000) Set pGraphicsContainer = pActiveView.GraphicsContainer 'erst mal alle vorhandenen GraphicLines löschen (delete all existing graphic-lines and polygons): pGraphicsContainer.Reset Set pElement = pGraphicsContainer.Next Do Until pElement Is Nothing If (pElement.geometry.GeometryType = esriGeometryPolygon) Then pGraphicsContainer.DeleteElement pElement ElseIf TypeOf pElement Is IGroupElement Then pGraphicsContainer.DeleteElement pElement End If Set pElement = pGraphicsContainer.Next Loop 'Draw Maucha polygons (MJS) Dim varList(88) Close #1 ' Close file, n case still open from previous crash Dim NR As Integer ' counter NR = 0 Open "C:\data\AV\National_water_quality\National\bcjuanita20060201all2001-2005_latlon.csv" For Input As #1 ' Open file for input. Do While Not EOF(1) ' Loop until end of file. Must be a more efficient way to parse the string. 'Do While NR < 3 NR = NR + 1 Input #1, varList(1), varList(2), varList(3), varList(4), varList(5), varList(6), varList(7), varList(8), varList(9), varList(10), varList(11), varList(12), varList(13), varList(14), varList(15), varList(16), varList(17), varList(18), varList(19), varList(20), varList(21), varList(22), varList(23), varList(24), varList(25), varList(26), varList(27), varList(28), varList(29), varList(30), varList(31), varList(32), varList(33), varList(34), varList(35), varList(36), varList(37), varList(38), varList(39), varList(40), varList(41), varList(42), varList(43), varList(44), varList(45), varList(46), varList(47), varList(48), varList(49), varList(50), varList(51), varList(52), varList(53), varList(54), varList(55), varList(56), varList(57), varList(58), varList(59), varList(60), varList(61), varList(62), varList(63), varList(64), varList(65), varList(66), _ varList(67), varList(68), varList(69), varList(70), varList(71), varList(72), varList(73), varList(74), varList(75), varList(76), varList(77), varList(78), varList(79), varList(80), varList(81), varList(82), varList(83), varList(84), varList(85), varList(86), varList(87), varList(88) If NR > 1 Then ' skipped header pApp.StatusBar.Message(0) = varList(2) & varList(36) & varList(48) & varList(52) & varList(56) & varList(60) & varList(64) & varList(68) & varList(72) & varList(76) & varList(87) & varList(88) Set pPoint = New Point pPoint.SetEmpty pPoint.PutCoords varList(87), varList(88) Set pPoint.SpatialReference = pGeoCoordSystem pPoint.Project pSpatialReferenceMap 'Set pPoint = funcProjectEx(varList(87), varList(88)) pPoint.QueryCoords xCentre, yCentre Call procMauchaPolygon(SymbolScale, xCentre, yCentre, varList(60), varList(56), varList(68), varList(64), varList(48), varList(36), varList(52), varList(72), varList(76)) 'pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing End If Loop Close #1 ' Close file. pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing 'pActiveView.Refresh End Sub Function funcProjectEx(dLonDecimalDegrees, dLatDecimalDegrees) As IPoint Dim pPoint As IPoint Set pPoint = New Point pPoint.SetEmpty pPoint.PutCoords dLonDecimalDegrees, dLatDecimalDegrees Dim pProjCoordSys As IProjectedCoordinateSystem Dim pGeoCoordSystem As ISpatialReference Dim pActiveView As IActiveView Dim pMap As IMap Dim pSpatialReferenceMap As ISpatialReference Dim pSpatRefFact As ISpatialReferenceFactory Set pSpatRefFact = New SpatialReferenceEnvironment Set pGeoCoordSystem = pSpatRefFact.CreateGeographicCoordinateSystem(esriSRGeoCS_WGS1984) Set pPoint.SpatialReference = pGeoCoordSystem Dim pDoc As IMxDocument Set pDoc = ThisDocument Set pActiveView = pDoc.ActiveView Set pMap = pDoc.FocusMap Set pSpatialReferenceMap = pMap.SpatialReference If Not Nothing Is pSpatialReferenceMap Then pPoint.Project pSpatialReferenceMap End If Set funcProjectEx = pPoint End Function Sub procMauchaPolygon(SymbolScale, xCentre, yCentre, Potassium, Sodium, Calcium, Magnesium, Chloride, Sulphate, TotalAlk, logH, TotalDisSalt) Dim pActiveView As IActiveView Dim pDoc As IMxDocument Dim pPointColl As IPointCollection Dim pCircColl As IPointCollection Dim pSegColl As ISegmentCollection Dim pCentrePoint As IPoint Dim pPolygon As IPolygon Dim pPolygonElement As IPolygonElement Dim pElement As IElement Dim pGroupElement As IGroupElement Set pGroupElement = New GroupElement Dim pCircle As IPolygon Dim pPoint As IPoint Dim pGraphicsContainer As IGraphicsContainer Dim pCoord As Variant Dim xyv As Variant Dim pX As Double, pY As Double Dim i As Long Const pi As Double = 3.14159265358979 Dim xSymbol As Double, ySymbol As Double Dim A As Single, Ion(7) As Single, TDS As Single Dim AnionSum As Single, CationSum As Single, EquivSum As Single Dim io As Variant Dim RayNumber As Integer, dAng As Integer Dim angrad As Single Dim TotalArea As Double, TotalRadius As Double, AnnoRadius As Double Dim xcirc As Double, ycirc As Double, RadiusCirc As Double Dim Equivalents As Single Dim IonArea As Double, IonRadius As Double, angle As Double Dim StartAngle As Double, IonAngle As Double, Io1Angle As Double, Io2Angle As Double, EndAngle As Double Dim x(4) As Double, y(4) As Double Dim xc(360) As Double, yc(360) As Double Dim x2 As Double, y2 As Double, x3 As Double, y3 As Double, x4 As Double, y4 As Double, x5 As Double, y5 As Double Dim pFillSymbol As ISimpleFillSymbol Dim pOutline As ILineSymbol Dim pColour As IRgbColor Dim pRgbColor As IRgbColor Dim pApp As IApplication Dim pIFillShapeElement As IFillShapeElement Dim prgbray As Variant Set pDoc = ThisDocument Set pActiveView = pDoc.ActiveView Set pApp = Application Set pGraphicsContainer = pActiveView.GraphicsContainer 'Dim pFillSymbol As ISimpleFillSymbol Dim pRgb_red As IRgbColor Dim pRgb_wht As IRgbColor Dim pRgb_gry As IRgbColor Dim pRgb_ray(8) As IRgbColor Set pRgb_red = New RgbColor pRgb_red.RGB = RGB(255, 0, 0) Set pRgb_wht = New RgbColor pRgb_wht.RGB = RGB(255, 255, 255) pRgb_wht.Transparency = 75 Set pRgb_gry = New RgbColor pRgb_gry.RGB = RGB(200, 200, 200) 'For Each prgbray In pRgb_ray 'Set pRgb_ray(prgbray) = New RgbColor 'Next prgbray Set pRgb_ray(0) = New RgbColor Set pRgb_ray(1) = New RgbColor Set pRgb_ray(2) = New RgbColor Set pRgb_ray(3) = New RgbColor Set pRgb_ray(4) = New RgbColor Set pRgb_ray(5) = New RgbColor Set pRgb_ray(6) = New RgbColor Set pRgb_ray(7) = New RgbColor pRgb_ray(0).RGB = RGB(255, 255, 0) pRgb_ray(1).RGB = RGB(255, 0, 255) pRgb_ray(7).RGB = RGB(255, 0, 0) pRgb_ray(6).RGB = RGB(127, 127, 127) pRgb_ray(5).RGB = RGB(0, 0, 255) pRgb_ray(4).RGB = RGB(0, 255, 0) pRgb_ray(3).RGB = RGB(0, 255, 255) pRgb_ray(2).RGB = RGB(0, 0, 0) ' Convert milligrams per litre to equivalents per litre (equivalents = ' molarity times charge on ion) altering the sequence to allow for the ' way in which AML works out its degrees... Ion(1) = Potassium * 1 / 39.1 Ion(0) = Sodium * 1 / 22.99 Ion(7) = Calcium * 2 / 40.08 Ion(6) = Magnesium * 2 / 24.31 Ion(5) = Sulphate * 2 / 96.07 Ion(4) = Chloride * 1 / 35.45 A = TotalAlk * 2 / 100 TDS = TotalDisSalt Ion(3) = A Ion(2) = 0 AnionSum = Ion(2) + Ion(3) + Ion(4) + Ion(5) CationSum = Ion(0) + Ion(1) + Ion(6) + Ion(7) EquivSum = CationSum + AnionSum 'MsgBox "Anions " & AnionSum & "; Cations " & CationSum & ";Total " & EquivSum pApp.StatusBar.Message(0) = "Anions " & AnionSum & "; Cations " & CationSum & ";Total " & EquivSum angrad = pi / 180 TotalArea = Log(EquivSum + 1) TotalRadius = Sqr((0.125 * TotalArea) / Sin(angrad * 22.5)) AnnoRadius = 1.5 * TotalRadius Set pPolygonElement = New PolygonElement Set pElement = pPolygonElement Set pCircColl = New Polygon For angle = 0 To 360 Step 5 xc(angle) = TotalRadius * Cos(angrad * angle) yc(angle) = TotalRadius * Sin(angrad * angle) pX = (xc(angle) * SymbolScale) + xCentre pY = (yc(angle) * SymbolScale) + yCentre Set pPoint = New Point pPoint.SetEmpty pPoint.PutCoords pX, pY pCircColl.AddPoint pPoint Set pPoint = Nothing Next angle Set pFillSymbol = New SimpleFillSymbol Set pOutline = New SimpleLineSymbol Set pColour = New RgbColor 'pColour.NullColor = True pColour.RGB = RGB(210, 210, 210) pOutline.Color = pColour pOutline.Width = 0.1 With pFillSymbol .Style = esriSFSSolid .Color = pRgb_wht .Outline = pOutline End With Set pCircle = pCircColl pElement.geometry = pCircle Set pIFillShapeElement = pElement pIFillShapeElement.Symbol = pFillSymbol Set pElement = pIFillShapeElement pGroupElement.AddElement pElement 'pGraphicsContainer.AddElement pElement, 0 'pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing RayNumber = 0 For Each io In Ion Equivalents = Ion(RayNumber) angle = RayNumber RayNumber = RayNumber + 1 IonArea = Equivalents / EquivSum * TotalArea IonRadius = IonArea / (TotalRadius * Sin(angrad * 22.5)) StartAngle = angle * 45 IonAngle = StartAngle + 22.5 EndAngle = RayNumber * 45 x(0) = 0 y(0) = 0 x(1) = TotalRadius * Cos(angrad * StartAngle) y(1) = TotalRadius * Sin(angrad * StartAngle) x(2) = IonRadius * Cos(angrad * IonAngle) y(2) = IonRadius * Sin(angrad * IonAngle) x(3) = TotalRadius * Cos(angrad * EndAngle) y(3) = TotalRadius * Sin(angrad * EndAngle) x(4) = x(0) y(4) = y(0) 'MsgBox "Ion (" & RayNumber & ") = " & io & "; Ray point " & x(2) & y(2) xyv = 0 Set pPointColl = New Polygon Do While xyv < 5 Set pPoint = New Point pPoint.SetEmpty pX = (x(xyv) * SymbolScale) + xCentre pY = (y(xyv) * SymbolScale) + yCentre pPoint.PutCoords pX, pY pPointColl.AddPoint pPoint Set pPoint = Nothing xyv = xyv + 1 Loop Set pFillSymbol = New SimpleFillSymbol ' Set pOutline = New SimpleLineSymbol ' Set pColour = New RgbColor ' pColour.NullColor = True ' pOutline.Color = pColour With pFillSymbol .Style = esriSFSSolid .Color = pRgb_ray(RayNumber - 1) .Outline = pOutline End With Set pPolygonElement = New PolygonElement Set pElement = pPolygonElement Set pPolygon = New Polygon Set pPolygon = pPointColl pElement.geometry = pPolygon Set pIFillShapeElement = pElement pIFillShapeElement.Symbol = pFillSymbol Set pElement = pIFillShapeElement pGroupElement.AddElement pElement Next io 'Dim pEnvelope As IEnvelope 'MsgBox "Envelope " & pGroupElement.XMax pGraphicsContainer.AddElement pGroupElement, 2 pActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing End Sub '----------------------------------------------------------------------------- ' Comments from the original AML: ' Michael Silberbauer - August to October 1993 ' mauchsym.aml takes a set of chemical concentrations in mg/L ' (K+, Na+, Ca++, Mg++, SO4=, Cl-, HCO3-, CO3=) and produces the ' coordinates required to plot them in the format used by ' Maucha (1932) Hydrochemische Metoden in der Limnologie. ' Binnengewasser 12, 173p, ' and modified by ' Broch E S & Yake W (1969) A modification of Maucha's ' ionic diagram to include ionic concentrations. ' Limnology and Oceanography 14, 933-935. ' ' Please refer to ' "Silberbauer M J & King J M (1991) Geographical trends in the ' water chemistry of wetlands in the south-western Cape Province, South ' Africa. Southern African Journal of Aquatic Sciences 17 (1/2) 82 - 88." ' if you wish to cite this programme or use it for any publication. ' Other useful documents are: ' Day J A & King J M (1995) Geographical patterns, and their origins, in the ' dominance of major ions in South African rivers. ' South African Journal of Science 91, 299-306. ' Day J A (1993) The major ion chemistry of some southern African saline systems. ' Hydrobiologia 267, 37-59. ' ' The Maucha diagram is the specific case of a radial plot in which the major ' cations are plotted on the right-hand side of an eight-point star and the ' major anions are plotted on the left-hand side. ' ' The aqueous CO2 should be split between H2CO3, HCO3- and CO3= using the approach of ' Mackereth FJH, Heron J & Talling JF (1978) Water Analysis: Some Revised ' Methods for Limnologists. Freshwater Biological Association Scientific ' Publication No 36. pp39-42. (but this option not implemented) ' ' Broch and Yake's modification was to use the TDS value to scale the whole ' diagram up or down, so that an idea of the relative concentration of various ' samples can be obtained. A logarithmic scale is necessary when widely ' differing concentrations are plotted on the same map. '----------------------------------------------------------------------------- Private Sub UIButtonControl2_Click() End Sub '************************************************************************* '* NAME : createMultipartPolygonRingPointCollection '* DESCRIPTION : Create a multipart polygon using rings via IPointCollection. '* This sub is demonstrating it by creating 1001 '* concentric square rings and add those to a polygon. '************************************************************************* Private Sub createMultipartPolygonRingPointCollection() Dim pGraphicsContainer As IGraphicsContainer Dim pPolygonElement As IPolygonElement Dim pElement As IElement Dim pActiveView As IActiveView Dim pDoc As IMxDocument Dim pDoc As IMxDocument Set pDoc = ThisDocument Set pActiveView = pDoc.ActiveView Dim pPointsRing0(4) As IPoint, pPointsRing1(4) As IPoint, pRingsColl(1) As IPointCollection Dim pGeometry(1) As IGeometry, i As Long, pGonColl As IGeometryCollection Dim d0X0 As Double, d0X1 As Double, d0X2 As Double, d0X3 As Double, d0Y0 As Double, d0Y1 As Double Dim d0Y2 As Double, d0Y3 As Double, d1X0 As Double, d1X1 As Double, d1X2 As Double, d1X3 As Double Dim d1Y0 As Double, d1Y1 As Double, d1Y2 As Double, d1Y3 As Double, j As Long, k As Long Dim pspref As ISpatialReference, pGeoSpRef As IGeometry 'Create the resulting polygon Set pGonColl = New Polygon '********************************************************* 'THE SPATIAL REFERENCE SHOULD BE SET HERE ON THE POLYGON 'Here the spatial reference is created in memory but could also come from various sources: 'IMap, IGeodataset, IGeometry etc... Set pspref = New UnknownCoordinateSystem pspref.SetFalseOriginAndUnits -10000, -10000, 100000 'Set the false origin and units. 'The XYUnits value is equivalent to the precision specified when creating a feature class Set pGeoSpRef = pGonColl Set pGeoSpRef.SpatialReference = pspref '********************************************************* d0X0 = 0: d0Y0 = 0: d0X1 = 0: d0Y1 = 0: d0X2 = 0: d0Y2 = 0: d0X3 = 0: d0Y3 = 0 d1X0 = 10000: d1Y0 = 10000: d1X1 = 10000: d1Y1 = 10000: d1X2 = 10000: d1Y2 = 10000: d1X3 = 10000: d1Y3 = 10000 'Loop to change the coordinates of the points For i = 0 To 1000 Set pRingsColl(0) = New Ring Set pRingsColl(1) = New Ring 'QI(Query Interface) to make sure that we have the correct type of geometry when passing this array to the addsegments Set pGeometry(0) = pRingsColl(0) Set pGeometry(1) = pRingsColl(1) 'Create the new points For k = 0 To 4 Set pPointsRing0(k) = New EsriGeometry.Point Set pPointsRing1(k) = New EsriGeometry.Point Next d0X0 = d0X0 - 5: d0Y0 = d0Y0 - 5: d0X1 = d0X1 + 5: d0Y1 = d0Y1 - 5: d0X2 = d0X2 + 5: d0Y2 = d0Y2 + 5: d0X3 = d0X3 - 5: d0Y3 = d0Y3 + 5 'Put the coordinates of the points to use in the first ring pPointsRing0(0).PutCoords d0X0, d0Y0 pPointsRing0(1).PutCoords d0X1, d0Y1 pPointsRing0(2).PutCoords d0X2, d0Y2 pPointsRing0(3).PutCoords d0X3, d0Y3 pPointsRing0(4).PutCoords d0X0, d0Y0 'Add the points to the ring pRingsColl(0).AddPoints 5, pPointsRing0(0) d1X0 = d1X0 - 5: d1Y0 = d1Y0 - 5: d1X1 = d1X1 + 5: d1Y1 = d1Y1 - 5: d1X2 = d1X2 + 5: d1Y2 = d1Y2 + 5: d1X3 = d1X3 - 5: d1Y3 = d1Y3 + 5 'Put the coordinates of the points to use in the second ring pPointsRing1(0).PutCoords d1X0, d1Y0 pPointsRing1(1).PutCoords d1X1, d1Y1 pPointsRing1(2).PutCoords d1X2, d1Y2 pPointsRing1(3).PutCoords d1X3, d1Y3 pPointsRing1(4).PutCoords d1X0, d1Y0 'Add the points to the ring pRingsColl(1).AddPoints 5, pPointsRing1(0) 'Add the rings to the polygon pGonColl.AddGeometries 2, pGeometry(0) Next 'You can draw, store or use the polygon (pGonColl) in other geometry operations at this point pActiveView.Refresh End Sub Function funcProjectEx1(dLonDecimalDegrees, dLatDecimalDegrees) As IPoint Dim pPoint As IPoint Set pPoint = New Point pPoint.SetEmpty pPoint.PutCoords dLonDecimalDegrees, dLatDecimalDegrees Dim pActiveView As IActiveView Dim pMap As IMap Dim pDoc As IMxDocument Set pDoc = ThisDocument Set pActiveView = pDoc.ActiveView Set pMap = pDoc.FocusMap IProjectedCoordinateSystem pMapSR = pMap.SpatialReference IGeographicCoordinateSystem pMapGraphicsContainerS = pMapSR.GeographicCoordinateSystem Set pPoint.SpatialReference = pMapGraphicsContainerS pPoint.Project (pMapSR) End Function Private Function IsNaN(expression As Variant) As Boolean On Error Resume Next If Not IsNumeric(expression) Then IsNaN = False Exit Function End If If (CStr(expression) = "1.#QNAN") Or (CStr(expression) = "1,#QNAN") Then ' can vary by locale IsNaN = True Else IsNaN = False End If End Function