clscreatestripmap.cls

一个不错的插件

    ' Set mouse pointer
299:     Screen.MousePointer = vbArrowHourglass

    ' Init
302:     Set pMx = Application.Document
303:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
304:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
305:             If UCase(pMx.FocusMap.Layer(lLoop).Name) = UCase(m_DestFL.Name) Then
306:                 Set pFL = pMx.FocusMap.Layer(lLoop)
307:                 Exit For
308:             End If
309:         End If
310:     Next
311:     If pFL Is Nothing Then
312:         MsgBox "No match in the Map for layer '" & m_DestFL.Name & "'."
        Exit Sub
314:     End If
315:     Set pFC = pFL.FeatureClass
    ' Check for required fields - that the field exists
    Dim bErrorWithFields As Boolean
318:     bErrorWithFields = (pFC.FindField(m_FldStripName) < 0)
319:     bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldNumInSeries) < 0)
320:     bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldMapAngle) < 0)
321:     If Len(m_FldScale) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldScale) < 0)
    ' If error
323:     If bErrorWithFields Then
324:         Err.Raise vbObjectError, "GenerateStripMap", "Could not find all the given field names in " & pFL.Name & "." _
            & vbCrLf & " - " & m_FldStripName & ", " & m_FldNumInSeries & ", " & m_FldMapAngle & ", " & m_FldScale
326:     End If
    ' Check the field types
328:     bErrorWithFields = (pFC.Fields.Field(pFC.FindField(m_FldStripName)).Type <> esriFieldTypeString)
329:     bErrorWithFields = bErrorWithFields Or _
       ((pFC.Fields.Field(pFC.FindField(m_FldNumInSeries)).Type <> esriFieldTypeDouble) And _
        (pFC.Fields.Field(pFC.FindField(m_FldNumInSeries)).Type <> esriFieldTypeInteger) And _
        (pFC.Fields.Field(pFC.FindField(m_FldNumInSeries)).Type <> esriFieldTypeSingle) And _
        (pFC.Fields.Field(pFC.FindField(m_FldNumInSeries)).Type <> esriFieldTypeSmallInteger))
334:     bErrorWithFields = bErrorWithFields Or _
       ((pFC.Fields.Field(pFC.FindField(m_FldMapAngle)).Type <> esriFieldTypeDouble) And _
        (pFC.Fields.Field(pFC.FindField(m_FldMapAngle)).Type <> esriFieldTypeInteger) And _
        (pFC.Fields.Field(pFC.FindField(m_FldMapAngle)).Type <> esriFieldTypeSingle) And _
        (pFC.Fields.Field(pFC.FindField(m_FldMapAngle)).Type <> esriFieldTypeSmallInteger))
339:     If Len(m_FldScale) > 0 Then
340:         bErrorWithFields = bErrorWithFields Or _
           ((pFC.Fields.Field(pFC.FindField(m_FldScale)).Type <> esriFieldTypeDouble) And _
            (pFC.Fields.Field(pFC.FindField(m_FldScale)).Type <> esriFieldTypeInteger) And _
            (pFC.Fields.Field(pFC.FindField(m_FldScale)).Type <> esriFieldTypeSingle) And _
            (pFC.Fields.Field(pFC.FindField(m_FldScale)).Type <> esriFieldTypeSmallInteger))
345:     End If
    ' if error
347:     If bErrorWithFields Then
348:         Err.Raise vbObjectError, "GenerateStripMap", "Given field names are not of the correct type." _
            & vbCrLf & "Strip Map Name field must be a Text field, all others must be numeric fields."
350:     End If
    ' Get the dataset and workspace (to start editing upon)
352:     Set pFeatDataset = pFC.FeatureDataset
353:     If Not pFeatDataset Is Nothing Then
354:         Set pWorkspaceEdit = pFeatDataset.Workspace
355:     Else
        ' Is a shapefile, go via just IDataset
357:         Set pDataset = pFC
358:         Set pWorkspaceEdit = pDataset.Workspace
359:     End If
    
'    ' If replacing, delete all existing polygons
362:     Set pProgress = New frmProgress
363:     m_pProgress.Create pProgress
364:     pProgress.ProgressBar1.Min = 0
365:     pProgress.ProgressBar1.Max = 100
366:     pProgress.ProgressBar1.value = 0
367:     If m_RemoveGrids Then
        Dim pFCu As IFeatureCursor
        Dim pT As ITable
370:         Set pFCu = m_DestFL.Search(Nothing, False)
371:         Set pT = m_DestFL.FeatureClass
372:         If pT.RowCount(Nothing) = 0 Then
373:             dIncrement = 99
374:         Else
375:             dIncrement = 100 / pT.RowCount(Nothing)
376:         End If
377:         pProgress.lblInformation.Caption = "Deleting previous grids..."
378:         pProgress.cmdCancel.Visible = False        ' User cannot cancel this step
379:         m_pProgress.Visible = True
380:         Set pFeature = pFCu.NextFeature
381:         While Not pFeature Is Nothing
382:             pFeature.Delete
383:             If (pProgress.ProgressBar1.value + dIncrement) <= pProgress.ProgressBar1.Max Then
384:                 pProgress.ProgressBar1.value = pProgress.ProgressBar1.value + dIncrement
385:             Else
386:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
387:             End If
388:             Set pFeature = pFCu.NextFeature
389:         Wend
390:         m_pProgress.Visible = False
391:     End If
    
        
    ' Init strip map stuff
395:     Set pPolyline = m_Polyline
    ' Flip, if required
397:     If m_Flip Then
398:         pPolyline.ReverseOrientation
399:     End If
400:     Set pCenterPoint = pPolyline.FromPoint
    ' Get the progress bar ready
402:     pProgress.ProgressBar1.Min = 0
403:     pProgress.ProgressBar1.Max = 101
404:     pProgress.ProgressBar1.value = 0
405:     pProgress.lblInformation.Caption = "Creating strip map..."
406:     pProgress.cmdCancel.Visible = True        ' User cannot cancel this step
    ' Get map units size for grids
408:     dConvertPageToMapUnits = CalculatePageToMapRatio(Application)
409:     m_GridWidth = ((m_dMapScale * m_dFrameWidthInPageUnits) / dConvertPageToMapUnits)
410:     m_GridHeight = ((m_dMapScale * m_dFrameHeightInPageUnits) / dConvertPageToMapUnits)
    ' Init for processing
412:     dHighestPrev = -1
413:     bFirstRun = True
414:     Set pArc = pPolyline
415:     Set pInsertFeatureCursor = pFC.Insert(True)
416:     Set pInsertFeatureBuffer = pFC.CreateFeatureBuffer
417:     m_pProgress.Visible = True
418:     Do
        Dim dCircleRadius As Double, colIntersects As Collection, dIntersect As Double
420:         If bFirstRun Then
421:             dCircleRadius = m_GridWidth / 2
422:         Else
423:             dCircleRadius = m_GridWidth
424:         End If
425:         bReducedRadius = False
426:         Do
            ' Create the search circle
428:             Set pCircularArc = New CircularArc
429:             pCircularArc.ConstructCircle pCenterPoint, dCircleRadius, False 'make it clockwise
430:             Set pCirclePoly = New Polygon
431:             Set pSegmentCollection = pCirclePoly
432:             pSegmentCollection.AddSegment pCircularArc
            
            ' Intersect the polyline and the circle
435:             Set pTopoOpt = pPolyline
436:             Set pGeoCol = New GeometryBag
437:             Set pGeoCol = pTopoOpt.Intersect(pCirclePoly, esriGeometry0Dimension)
            
439:             If pGeoCol.GeometryCount = 0 Then
440:                 MsgBox "error - no geoms intersected"
                Exit Sub
442:             End If
443:             Set pArc = pPolyline
444:             lHighestRef = -1
445:             dHighestThisTurn = 102
446:             For lLoop2 = 0 To pGeoCol.GeometryCount - 1
447:                 Set pIntersectPoint = pGeoCol.Geometry(lLoop2)
448:                 dIntersect = ReturnPercentageAlong(pArc, pIntersectPoint)
449:                 If dIntersect > (dHighestPrev * 1.001) And dIntersect < dHighestThisTurn Then
450:                     dHighest = dIntersect
451:                     dHighestThisTurn = dIntersect
452:                     lHighestRef = lLoop2
453:                 End If
454:             Next
            ' If no intersection higher than our previous run, we are at the end.
456:             If lHighestRef < 0 Then
457:                 dHighest = 101
                ' Need to extend the end (tangent) to get intersection
459:                 Set pIntersectPoint = IntersectPointExtendedTo(pPolyline, pCirclePoly)
460:                 Set pIntersectPointPrev = pCenterPoint
            ' Otherwise, still in the middle somewhere
462:             Else
463:                 Set pIntersectPoint = pGeoCol.Geometry(lHighestRef)
                ' If just starting off (ie: first grid)
465:                 If bFirstRun Then
                    ' Set the grid so the polyline's starting point is in the
                    '  center of the first grid polygon we make
468:                     Set pIntersectPointPrev = New esrigeometry.Point
469:                     pIntersectPointPrev.PutCoords pCenterPoint.X - (pIntersectPoint.X - pCenterPoint.X), _
                                                  pCenterPoint.Y - (pIntersectPoint.Y - pCenterPoint.Y)
                ' Otherwise, we already have a previous point
472:                 Else
                    ' So use it
474:                     Set pIntersectPointPrev = pCenterPoint
475:                 End If
476:             End If
            ' Make our grid polygon, allowing for any 'shrunken' grids
478:             If bReducedRadius Then
                Dim pTmpPLine As IPolyline
                Dim pTmpCPoly As IPolygon
                Dim pTmpIntPoint As IPoint
482:                 Set pCircularArc = New CircularArc
483:                 If bFirstRun Then
484:                     pCircularArc.ConstructCircle pCenterPoint, m_GridWidth / 2, False 'make it clockwise
485:                 Else
486:                     pCircularArc.ConstructCircle pCenterPoint, m_GridWidth, False 'make it clockwise
487:                 End If
488:                 Set pTmpCPoly = New Polygon
489:                 Set pSegmentCollection = pTmpCPoly
490:                 pSegmentCollection.AddSegment pCircularArc
                
492:                 Set pTmpPLine = New Polyline
493:                 pTmpPLine.FromPoint = pIntersectPointPrev
494:                 pTmpPLine.ToPoint = pIntersectPoint
495:                 Set pTmpIntPoint = IntersectPointExtendedTo(pTmpPLine, pTmpCPoly)
496:                 CreateAngledGridPolygon pIntersectPointPrev, pTmpIntPoint, pGridPoly, dGridAngle
497:             Else
498:                 CreateAngledGridPolygon pIntersectPointPrev, pIntersectPoint, pGridPoly, dGridAngle
499:             End If
            ' Now, we potentially need to reprocess if the route dips out of our grid
501:             Set pTopoOpt = pGridPoly
502:             Set pGeoCol = New GeometryBag
503:             Set pGeoCol = pTopoOpt.Intersect(pPolyline, esriGeometry0Dimension)
504:             bContinue = True
505:             If pGeoCol.GeometryCount > 2 Then
506:                 Set colIntersects = New Collection
507:                 For lLoop2 = 0 To pGeoCol.GeometryCount - 1
508:                     colIntersects.Add ReturnPercentageAlong(pArc, pGeoCol.Geometry(lLoop2))
509:                 Next
510:                 For lLoop2 = 1 To colIntersects.count
511:                     If colIntersects.Item(lLoop2) > (dHighestPrev * 1.001) And colIntersects.Item(lLoop2) < (dHighest * 0.999) Then
512:                         bContinue = False
513:                         dHighest = dHighestPrev
514:                         dCircleRadius = dCircleRadius - (m_GridWidth * 0.1)
515:                         bReducedRadius = True
516:                         If dCircleRadius <= 0 Then
517:                             bContinue = True
518:                         End If
519:                         Exit For
520:                     End If
521:                 Next
522:             End If
            ' If all OK and a reduced radius, look for a quick jump ahead
524:             If bContinue And bReducedRadius Then 'And pGeoCol.GeometryCount <= 2 Then
                Dim dTmpHighest As Double
526:                 Set pArc = pPolyline
527:                 lHighestRef = -1
528:                 dTmpHighest = -1
529:                 For lLoop2 = 0 To pGeoCol.GeometryCount - 1
530:                     Set pIntersectPoint = pGeoCol.Geometry(lLoop2)
531:                     dIntersect = ReturnPercentageAlong(pArc, pIntersectPoint)
532:                     If dIntersect > dTmpHighest Then
533:                         dTmpHighest = dIntersect
534:                         lHighestRef = lLoop2
535:                     End If
536:                 Next
537:                 If lHighestRef >= 0 Then Set pIntersectPoint = pGeoCol.Geometry(lHighestRef)
538:                 dHighest = dTmpHighest
539:             End If
540:         Loop Until bContinue
        
542:         bFirstRun = False
543:         dHighestPrev = dHighest
        
        ' All OK to create our grid feature now (hopefully, anyway)
546:         lCounter = lCounter + 1
        'CreateGridFeaturesAsGraphics pGridPoly, lCounter, dGridAngle, Application 'AAA
        
        ' Create new grid cell feature
550:         Set pInsertFeatureBuffer.Shape = pGridPoly
551:         pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldStripName)) = m_StripMapName & CStr(lCounter)
552:         pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldNumInSeries)) = lCounter
553:         pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldMapAngle)) = dGridAngle 'degrees
554:         If Len(m_FldScale) > 0 Then pInsertFeatureBuffer.value(pFC.Fields.FindField(m_FldScale)) = m_dMapScale
555:         pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
556:         If dHighest <= pProgress.ProgressBar1.Max Then
557:             pProgress.ProgressBar1.value = dHighest
558:         Else
559:             pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
560:             pProgress.ProgressBar1.value = pProgress.ProgressBar1.Max
561:         End If
562:         If (lCounter Mod 20 = 0) Then
563:             DoEvents
564:             pInsertFeatureCursor.Flush
565:         End If
566:         pProgress.Refresh
567:         If pProgress.Cancelled Then
            Dim vUserChoice
569:             pProgress.Cancelled = False       ' Reset the form
570:             vUserChoice = MsgBox("Operation cancelled." _
                & "  Save the edits made thus far?" & vbCrLf & vbCrLf _
                & "(Click Cancel to continue processing)", _
                            vbYesNoCancel, "Generate Strip Map")
574:             If vUserChoice <> vbCancel Then
575:                 GoTo CancelledGenerateGrids     'Sorry for GoTo usage - in a hurry
576:             End If
577:         End If
        ' For next time
579:         Set pCenterPoint = pIntersectPoint
580:     Loop While dHighest < 100
    ' Add remainder polys
582:     pInsertFeatureCursor.Flush
583:     m_pProgress.Visible = False

    ' Stop editing
586:     pWorkspaceEdit.StopEditOperation
587:     pWorkspaceEdit.StopEditing True
588:     pMx.ActiveView.Refresh
    
    Exit Sub
    
CancelledGenerateGrids:
593:     m_pProgress.Visible = False
594:     If vUserChoice = vbYes Then
595:         pInsertFeatureCursor.Flush
596:         pWorkspaceEdit.StopEditOperation
597:         pWorkspaceEdit.StopEditing True
598:     Else
599:         pWorkspaceEdit.StopEditOperation
600:         pWorkspaceEdit.StopEditing False
601:     End If
602:     Screen.MousePointer = vbDefault
603:     pMx.ActiveView.Refresh
    Exit Sub
    
606:     Resume
eh: