clscreatestripmap.cls

使用VB和ArcObject结合的程序

    Dim dDataFrameHeight As Double
    Dim dConvertPageToMapUnits As Double
    Dim dIncrement As Double
    Dim pInsertFeatureBuffer As IFeatureBuffer
    Dim pInsertFeatureCursor As IFeatureCursor
    Dim pFL As IFeatureLayer
    Dim pFC As IFeatureClass
    Dim pProgress As frmProgress

    On Error GoTo eh

    ' Set mouse pointer
287:     Screen.MousePointer = vbArrowHourglass

    ' Init
290:     Set pMx = Application.Document
291:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
292:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
293:             If UCase(pMx.FocusMap.Layer(lLoop).Name) = UCase(m_DestFL.Name) Then
294:                 Set pFL = pMx.FocusMap.Layer(lLoop)
295:                 Exit For
296:             End If
297:         End If
298:     Next
299:     If pFL Is Nothing Then
300:         MsgBox "No match in the Map for layer '" & m_DestFL.Name & "'."
        Exit Sub
302:     End If
303:     Set pFC = pFL.FeatureClass
    ' Check for required fields - that the field exists
    Dim bErrorWithFields As Boolean
306:     bErrorWithFields = (pFC.FindField(m_FldStripName) < 0)
307:     bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldNumInSeries) < 0)
308:     bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldMapAngle) < 0)
309:     If Len(m_FldScale) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldScale) < 0)
    ' If error
311:     If bErrorWithFields Then
312:         Err.Raise vbObjectError, "GenerateStripMap", "Could not find all the given field names in " & pFL.Name & "." _
            & vbCrLf & " - " & m_FldStripName & ", " & m_FldNumInSeries & ", " & m_FldMapAngle & ", " & m_FldScale
314:     End If
    ' Check the field types
316:     bErrorWithFields = (pFC.Fields.Field(pFC.FindField(m_FldStripName)).Type <> esriFieldTypeString)
317:     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))
322:     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))
327:     If Len(m_FldScale) > 0 Then
328:         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))
333:     End If
    ' if error
335:     If bErrorWithFields Then
336:         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."
338:     End If
    ' Get the dataset and workspace (to start editing upon)
340:     Set pFeatDataset = pFC.FeatureDataset
341:     If Not pFeatDataset Is Nothing Then
342:         Set pWorkspaceEdit = pFeatDataset.Workspace
343:     Else
        ' Is a shapefile, go via just IDataset
345:         Set pDataset = pFC
346:         Set pWorkspaceEdit = pDataset.Workspace
347:     End If
    
'    ' If replacing, delete all existing polygons
350:     Set pProgress = New frmProgress
351:     m_pProgress.Create pProgress
352:     pProgress.ProgressBar1.Min = 0
353:     pProgress.ProgressBar1.Max = 100
354:     pProgress.ProgressBar1.Value = 0
355:     If m_RemoveGrids Then
        Dim pFCu As IFeatureCursor
        Dim pT As ITable
358:         Set pFCu = m_DestFL.Search(Nothing, False)
359:         Set pT = m_DestFL.FeatureClass
360:         If pT.RowCount(Nothing) = 0 Then
361:             dIncrement = 99
362:         Else
363:             dIncrement = 100 / pT.RowCount(Nothing)
364:         End If
365:         pProgress.lblInformation.Caption = "Deleting previous grids..."
366:         pProgress.cmdCancel.Visible = False        ' User cannot cancel this step
367:         m_pProgress.Visible = True
368:         Set pFeature = pFCu.NextFeature
369:         While Not pFeature Is Nothing
370:             pFeature.Delete
371:             If (pProgress.ProgressBar1.Value + dIncrement) <= pProgress.ProgressBar1.Max Then
372:                 pProgress.ProgressBar1.Value = pProgress.ProgressBar1.Value + dIncrement
373:             Else
374:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
375:             End If
376:             Set pFeature = pFCu.NextFeature
377:         Wend
378:         m_pProgress.Visible = False
379:     End If
    
        
    ' Init strip map stuff
383:     Set pPolyline = m_Polyline
    ' Flip, if required
385:     If m_Flip Then
386:         pPolyline.ReverseOrientation
387:     End If
388:     Set pCenterPoint = pPolyline.FromPoint
    ' Get the progress bar ready
390:     pProgress.ProgressBar1.Min = 0
391:     pProgress.ProgressBar1.Max = 101
392:     pProgress.ProgressBar1.Value = 0
393:     pProgress.lblInformation.Caption = "Creating strip map..."
394:     pProgress.cmdCancel.Visible = True        ' User cannot cancel this step
    ' Get map units size for grids
396:     dConvertPageToMapUnits = CalculatePageToMapRatio(Application)
397:     m_GridWidth = ((m_dMapScale * m_dFrameWidthInPageUnits) / dConvertPageToMapUnits)
398:     m_GridHeight = ((m_dMapScale * m_dFrameHeightInPageUnits) / dConvertPageToMapUnits)
    ' Init for processing
400:     dHighestPrev = -1
401:     bFirstRun = True
402:     Set pArc = pPolyline
403:     Set pInsertFeatureCursor = pFC.Insert(True)
404:     Set pInsertFeatureBuffer = pFC.CreateFeatureBuffer
405:     m_pProgress.Visible = True
406:     Do
        Dim dCircleRadius As Double, colIntersects As Collection, dIntersect As Double
408:         If bFirstRun Then
409:             dCircleRadius = m_GridWidth / 2
410:         Else
411:             dCircleRadius = m_GridWidth
412:         End If
413:         bReducedRadius = False
414:         Do
            ' Create the search circle
416:             Set pCircularArc = New CircularArc
417:             pCircularArc.ConstructCircle pCenterPoint, dCircleRadius, False 'make it clockwise
418:             Set pCirclePoly = New Polygon
419:             Set pSegmentCollection = pCirclePoly
420:             pSegmentCollection.AddSegment pCircularArc
            
            ' Intersect the polyline and the circle
423:             Set pTopoOpt = pPolyline
424:             Set pGeoCol = New GeometryBag
425:             Set pGeoCol = pTopoOpt.Intersect(pCirclePoly, esriGeometry0Dimension)
            
427:             If pGeoCol.GeometryCount = 0 Then
428:                 MsgBox "error - no geoms intersected"
                Exit Sub
430:             End If
431:             Set pArc = pPolyline
432:             lHighestRef = -1
433:             dHighestThisTurn = 102
434:             For lLoop2 = 0 To pGeoCol.GeometryCount - 1
435:                 Set pIntersectPoint = pGeoCol.Geometry(lLoop2)
436:                 dIntersect = ReturnPercentageAlong(pArc, pIntersectPoint)
437:                 If dIntersect > (dHighestPrev * 1.001) And dIntersect < dHighestThisTurn Then
438:                     dHighest = dIntersect
439:                     dHighestThisTurn = dIntersect
440:                     lHighestRef = lLoop2
441:                 End If
442:             Next
            ' If no intersection higher than our previous run, we are at the end.
444:             If lHighestRef < 0 Then
445:                 dHighest = 101
                ' Need to extend the end (tangent) to get intersection
447:                 Set pIntersectPoint = IntersectPointExtendedTo(pPolyline, pCirclePoly)
448:                 Set pIntersectPointPrev = pCenterPoint
            ' Otherwise, still in the middle somewhere
450:             Else
451:                 Set pIntersectPoint = pGeoCol.Geometry(lHighestRef)
                ' If just starting off (ie: first grid)
453:                 If bFirstRun Then
                    ' Set the grid so the polyline's starting point is in the
                    '  center of the first grid polygon we make
456:                     Set pIntersectPointPrev = New esrigeometry.Point
457:                     pIntersectPointPrev.PutCoords pCenterPoint.X - (pIntersectPoint.X - pCenterPoint.X), _
                                                  pCenterPoint.Y - (pIntersectPoint.Y - pCenterPoint.Y)
                ' Otherwise, we already have a previous point
460:                 Else
                    ' So use it
462:                     Set pIntersectPointPrev = pCenterPoint
463:                 End If
464:             End If
            ' Make our grid polygon, allowing for any 'shrunken' grids
466:             If bReducedRadius Then
                Dim pTmpPLine As IPolyline
                Dim pTmpCPoly As IPolygon
                Dim pTmpIntPoint As IPoint
470:                 Set pCircularArc = New CircularArc
471:                 If bFirstRun Then
472:                     pCircularArc.ConstructCircle pCenterPoint, m_GridWidth / 2, False 'make it clockwise
473:                 Else
474:                     pCircularArc.ConstructCircle pCenterPoint, m_GridWidth, False 'make it clockwise
475:                 End If
476:                 Set pTmpCPoly = New Polygon
477:                 Set pSegmentCollection = pTmpCPoly
478:                 pSegmentCollection.AddSegment pCircularArc
                
480:                 Set pTmpPLine = New Polyline
481:                 pTmpPLine.FromPoint = pIntersectPointPrev
482:                 pTmpPLine.ToPoint = pIntersectPoint
483:                 Set pTmpIntPoint = IntersectPointExtendedTo(pTmpPLine, pTmpCPoly)
484:                 CreateAngledGridPolygon pIntersectPointPrev, pTmpIntPoint, pGridPoly, dGridAngle
485:             Else
486:                 CreateAngledGridPolygon pIntersectPointPrev, pIntersectPoint, pGridPoly, dGridAngle
487:             End If
            ' Now, we potentially need to reprocess if the route dips out of our grid
489:             Set pTopoOpt = pGridPoly
490:             Set pGeoCol = New GeometryBag
491:             Set pGeoCol = pTopoOpt.Intersect(pPolyline, esriGeometry0Dimension)
492:             bContinue = True
493:             If pGeoCol.GeometryCount > 2 Then
494:                 Set colIntersects = New Collection
495:                 For lLoop2 = 0 To pGeoCol.GeometryCount - 1
496:                     colIntersects.Add ReturnPercentageAlong(pArc, pGeoCol.Geometry(lLoop2))
497:                 Next
498:                 For lLoop2 = 1 To colIntersects.count
499:                     If colIntersects.Item(lLoop2) > (dHighestPrev * 1.001) And colIntersects.Item(lLoop2) < (dHighest * 0.999) Then
500:                         bContinue = False
501:                         dHighest = dHighestPrev
502:                         dCircleRadius = dCircleRadius - (m_GridWidth * 0.1)
503:                         bReducedRadius = True
504:                         If dCircleRadius <= 0 Then
505:                             bContinue = True
506:                         End If
507:                         Exit For
508:                     End If
509:                 Next
510:             End If
            ' If all OK and a reduced radius, look for a quick jump ahead
512:             If bContinue And bReducedRadius Then 'And pGeoCol.GeometryCount <= 2 Then
                Dim dTmpHighest As Double
514:                 Set pArc = pPolyline
515:                 lHighestRef = -1
516:                 dTmpHighest = -1
517:                 For lLoop2 = 0 To pGeoCol.GeometryCount - 1
518:                     Set pIntersectPoint = pGeoCol.Geometry(lLoop2)
519:                     dIntersect = ReturnPercentageAlong(pArc, pIntersectPoint)
520:                     If dIntersect > dTmpHighest Then
521:                         dTmpHighest = dIntersect
522:                         lHighestRef = lLoop2
523:                     End If
524:                 Next
525:                 If lHighestRef >= 0 Then Set pIntersectPoint = pGeoCol.Geometry(lHighestRef)
526:                 dHighest = dTmpHighest
527:             End If
528:         Loop Until bContinue
        
530:         bFirstRun = False
531:         dHighestPrev = dHighest
        
        ' All OK to create our grid feature now (hopefully, anyway)
534:         lCounter = lCounter + 1
        'CreateGridFeaturesAsGraphics pGridPoly, lCounter, dGridAngle, Application 'AAA
        
        ' Create new grid cell feature
538:         Set pInsertFeatureBuffer.Shape = pGridPoly
539:         pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldStripName)) = m_StripMapName & CStr(lCounter)
540:         pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldNumInSeries)) = lCounter
541:         pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldMapAngle)) = dGridAngle 'degrees
542:         If Len(m_FldScale) > 0 Then pInsertFeatureBuffer.Value(pFC.Fields.FindField(m_FldScale)) = m_dMapScale
543:         pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
544:         If dHighest <= pProgress.ProgressBar1.Max Then
545:             pProgress.ProgressBar1.Value = dHighest
546:         Else
547:             pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
548:             pProgress.ProgressBar1.Value = pProgress.ProgressBar1.Max
549:         End If
550:         If (lCounter Mod 20 = 0) Then
551:             DoEvents
552:             pInsertFeatureCursor.Flush
553:         End If
554:         pProgress.Refresh
555:         If pProgress.Cancelled Then
            Dim vUserChoice
557:             pProgress.Cancelled = False       ' Reset the form
558:             vUserChoice = MsgBox("Operation cancelled." _
                & "  Save the edits made thus far?" & vbCrLf & vbCrLf _
                & "(Click Cancel to continue processing)", _
                            vbYesNoCancel, "Generate Strip Map")
562:             If vUserChoice <> vbCancel Then
563:                 GoTo CancelledGenerateGrids     'Sorry for GoTo usage - in a hurry
564:             End If
565:         End If
        ' For next time
567:         Set pCenterPoint = pIntersectPoint
568:     Loop While dHighest < 100
    ' Add remainder polys
570:     pInsertFeatureCursor.Flush
571:     m_pProgress.Visible = False

    ' Stop editing
574:     pWorkspaceEdit.StopEditOperation
575:     pWorkspaceEdit.StopEditing True
576:     pMx.ActiveView.Refresh
    
    Exit Sub
    
CancelledGenerateGrids:
581:     m_pProgress.Visible = False
582:     If vUserChoice = vbYes Then
583:         pInsertFeatureCursor.Flush
584:         pWorkspaceEdit.StopEditOperation
585:         pWorkspaceEdit.StopEditing True
586:     Else
587:         pWorkspaceEdit.StopEditOperation
588:         pWorkspaceEdit.StopEditing False
589:     End If