frmmapserieswiz.frm

使用VB和ArcObject结合的程序

  If pMapBook Is Nothing Then Exit Sub
  
283:   pMapBook.EnableBook = True
284:   Set pDoc = m_pApp.Document
  
286:   Set pMapSeries = New DSMapSeries
287:   Set pSeriesOpt = pMapSeries
288:   Set pSeriesOpt2 = pSeriesOpt  'Added 6/18/03 to support cross hatch outside clip area
289:   Set pSeriesProps = pMapSeries
290:   pMapSeries.EnableSeries = True
  
  'Find the detail frame
293:   Set pMap = FindDataFrame(pDoc, cmbDetailFrame.Text)
294:   If pMap Is Nothing Then
295:     MsgBox "Detail frame not found!!!"
    Exit Sub
297:   End If
298:   pSeriesProps.DataFrameName = pMap.Name
  
  'Find the layer
301:   Set pFeatLayer = FindLayer(cmbIndexLayer.Text, pMap)
302:   If pFeatLayer Is Nothing Then
303:     MsgBox "Index layer not found!!!"
    Exit Sub
305:   End If
306:   pSeriesProps.IndexLayerName = pFeatLayer.Name
307:   pSeriesProps.IndexFieldName = cmbIndexField.Text
    
  'Determine the tiles we are interested in
310:   Set pQuery = New QueryFilter
311:   sFieldName = cmbIndexField.Text
312:   pQuery.AddField sFieldName
'  pQuery.WhereClause = sFieldName & " <> ''"
314:   pQuery.WhereClause = sFieldName & " is not null"
315:   If optTiles(0).Value Then
316:     Set pCursor = pFeatLayer.Search(pQuery, True)
317:     pSeriesProps.TileSelectionMethod = 0
318:   ElseIf optTiles(1).Value Then
319:     Set pFeatLayerSel = pFeatLayer
320:     pFeatLayerSel.SelectionSet.Search pQuery, True, pCursor
321:     pSeriesProps.TileSelectionMethod = 1
322:   Else
323:     Set pActiveView = pMap
324:     Set pSpatialQuery = New SpatialFilter
325:     pSpatialQuery.AddField sFieldName
326:     pSpatialQuery.SpatialRel = esriSpatialRelIntersects
327:     Set pSpatialQuery.Geometry = pActiveView.Extent
328:     pSpatialQuery.WhereClause = sFieldName & " <> ''"
329:     pSpatialQuery.GeometryField = pFeatLayer.FeatureClass.shapeFieldName
330:     Set pCursor = pFeatLayer.Search(pSpatialQuery, True)
331:     pSeriesProps.TileSelectionMethod = 2
332:   End If
  
  'Add 2/18/04 to keep track of starting page number
335:   pSeriesProps.StartNumber = CLng(txtNumbering.Text)
  
  'Set the clip, label and rotate properties
  'Updated 6/18/03 to support cross hatch outside clip area
339:   If chkOptions(1).Value = 1 Then
340:     If chkOptions(3).Value = 1 Then
341:       pSeriesOpt2.ClipData = 2
342:     Else
343:       pSeriesOpt2.ClipData = 1
344:     End If
345:   Else
346:     pSeriesOpt2.ClipData = 0
347:   End If
'  If chkOptions(1).Value = 1 Then
'    pSeriesOpt.ClipData = True
'  Else
'    pSeriesOpt.ClipData = False
'  End If
  
354:   If chkOptions(0).Value = 1 Then
355:     pSeriesOpt.RotateFrame = True
356:     pSeriesOpt.RotationField = cmbRotateField.Text
357:     lRotIndex = pFeatLayer.FeatureClass.FindField(cmbRotateField.Text)
358:   Else
359:     pSeriesOpt.RotateFrame = False
360:   End If
361:   If chkOptions(2).Value = 1 Then
362:     pSeriesOpt.LabelNeighbors = True
363:   Else
364:     pSeriesOpt.LabelNeighbors = False
365:   End If
366:   Set pSeriesOpt.LabelSymbol = m_pTextSym
  
  'Set the extent properties
369:   If optExtent(0).Value Then         'Variable
370:     pSeriesOpt.ExtentType = 0
371:     If txtMargin.Text = "" Then
372:       pSeriesOpt.Margin = 0
373:     Else
374:       pSeriesOpt.Margin = CDbl(txtMargin.Text)
375:     End If
376:     pSeriesOpt.MarginType = cmbMargin.ListIndex
377:   ElseIf optExtent(1).Value Then    'Fixed
378:     pSeriesOpt.ExtentType = 1
379:     pSeriesOpt.FixedScale = txtFixed.Text
380:   Else                        'Data driven
381:     pSeriesOpt.ExtentType = 2
382:     pSeriesOpt.DataDrivenField = cmbDataDriven.Text
383:     lScaleIndex = pFeatLayer.FeatureClass.FindField(cmbDataDriven.Text)
384:   End If
  
  'Store suppression information
387:   If chkSuppress.Value = 1 And lstSuppressTiles.SelCount > 0 Then
388:     pSeriesProps.SuppressLayers = True
389:     For lLoop = 0 To lstSuppressTiles.ListCount - 1
390:       If lstSuppressTiles.Selected(lLoop) Then
391:         pSeriesProps.AddLayerToSuppress lstSuppressTiles.List(lLoop)
392:       End If
393:     Next lLoop
394:   Else
395:     pSeriesProps.SuppressLayers = False
396:   End If
  
  'Create the pages and populate the treeview
399:   Set pTmpColl = New Collection
400:   lIndex = pFeatLayer.FeatureClass.FindField(sFieldName)
401:   Set pFeature = pCursor.NextFeature
402:   With g_pFrmMapSeries.tvwMapBook
403:     Set pNode = .Nodes.Add("MapBook", tvwChild, "MapSeries", "Map Series", 3)
404:     pNode.Tag = "MapSeries"
    
    'Add tile names to a listbox first for sort purposes
407:     g_pFrmMapSeries.lstSorter.Clear
408:     Do While Not pFeature Is Nothing
409:       sName = pFeature.Value(lIndex)
410:       Set pTmpPage = New tmpPageClass
411:       pTmpPage.PageName = sName
412:       pTmpPage.PageRotation = 0
413:       pTmpPage.PageScale = 1
414:       Set pClone = pFeature.Shape
415:       Set pTmpPage.PageShape = pClone.Clone
      'Track the rotation and scale values (if we are going to use them) to the end
      'of the name, so we can assign them to the page when it is added without having
      'to query the index layer again.
419:       If chkOptions(0).Value = 1 And lRotIndex >= 0 Then
420:         If Not IsNull(pFeature.Value(lRotIndex)) Then
421:           pTmpPage.PageRotation = pFeature.Value(lRotIndex)
422:         End If
423:       End If
424:       If optExtent(2).Value And lScaleIndex >= 0 Then
425:         If Not IsNull(pFeature.Value(lScaleIndex)) Then
426:           pTmpPage.PageScale = pFeature.Value(lScaleIndex)
427:         End If
428:       End If
429:       If chkSuppress.Value = 1 And lstSuppressTiles.SelCount > 0 Then
430:         If FeaturesInTile(pFeature, pMap) Then
431:           g_pFrmMapSeries.lstSorter.AddItem sName
432:           pTmpColl.Add pTmpPage, sName
433:         End If
434:       Else
435:         g_pFrmMapSeries.lstSorter.AddItem sName
436:         pTmpColl.Add pTmpPage, sName
437:       End If
438:       Set pFeature = pCursor.NextFeature
439:     Loop
    
    'Now loop back through the list and add the tile names as nodes in the tree
442:     For lLoop = 0 To g_pFrmMapSeries.lstSorter.ListCount - 1
443:       Set pMapPage = New DSMapPage
444:       lPageNumber = lLoop + CLng(txtNumbering.Text)
445:       sName = g_pFrmMapSeries.lstSorter.List(lLoop)
446:       Set pNode = .Nodes.Add("MapSeries", tvwChild, "a" & sName, lPageNumber & " - " & sName, 5)
447:       Set pTmpPage = pTmpColl.Item(sName)
448:       pNode.Tag = lLoop
449:       pMapPage.PageName = sName
450:       pMapPage.PageRotation = pTmpPage.PageRotation
451:       pMapPage.PageScale = pTmpPage.PageScale
452:       Set pMapPage.PageShape = pTmpPage.PageShape
453:       pMapPage.LastOutputted = #1/1/1900#
454:       pMapPage.EnablePage = True
455:       pMapPage.PageNumber = lPageNumber
456:       pMapSeries.AddPage pMapPage
457:     Next lLoop
458:     .Nodes.Item("MapBook").Expanded = True
459:     .Nodes.Item("MapSeries").Expanded = True
460:   End With
  
  'Add the series to the book
463:   pMapBook.AddContent pMapSeries

  Exit Sub
ErrHandler:
467:   MsgBox "CreateSeries - most likely you do not have unique names in your index layer!!!"
End Sub

Private Sub CheckForSelected()
On Error GoTo ErrHand:
  Dim pFeatSel As IFeatureSelection
  
  'Make sure there is something to check
475:   optTiles(1).Enabled = False
  If m_pIndexLayer Is Nothing Then Exit Sub
  
  'Check for selected features in the index layer
479:   Set pFeatSel = m_pIndexLayer
480:   If pFeatSel.SelectionSet.count <> 0 Then
481:     optTiles(1).Enabled = True
482:   End If

  Exit Sub
ErrHand:
486:   MsgBox "CheckForSelected - " & Err.Description
End Sub

Private Sub Form_Load()
On Error GoTo ErrHand:
  Dim pDoc As IMxDocument, lLoop As Long
  'Get the extension
  If m_pApp Is Nothing Then Exit Sub
    
495:   m_bFormLoad = True
496:   Set m_pCurrentFrame = Nothing
497:   PositionFrame fraPage1
498:   cmdNext.Enabled = False
499:   cmdBack.Enabled = False
  
  'Initialize variables and controls
502:   m_iPage = 1
503:   chkOptions(0).Value = 0
504:   chkOptions(1).Value = 0
505:   chkOptions(2).Value = 0
506:   chkSuppress.Value = 0
507:   optTiles(0).Value = True
508:   optExtent(0).Value = True
509:   lstSuppressTiles.Enabled = False
510:   cmbRotateField.Enabled = False
511:   cmdLabelProps.Enabled = False
512:   chkOptions(3).Enabled = False
513:   txtNumbering.Text = "1"
  
  'Populate the data frame combo
516:   Set pDoc = m_pApp.Document
517:   cmbIndexField.Clear
518:   cmbDetailFrame.Clear
519:   For lLoop = 0 To pDoc.Maps.count - 1
520:     cmbDetailFrame.AddItem pDoc.Maps.Item(lLoop).Name
521:   Next lLoop
522:   cmbDetailFrame.ListIndex = 0
523:   m_bFormLoad = False
  
  'Populate the extent options
526:   cmbMargin.Clear
527:   cmbMargin.AddItem "percent"
528:   cmbMargin.AddItem "mapunits"
529:   cmbMargin.Text = "percent"
530:   txtMargin.Text = "0"
  
  'Set the initial Label symbol
533:   Set pDoc = m_pApp.Document
534:   Set m_pTextSym = New TextSymbol
535:   m_pTextSym.Font = pDoc.DefaultTextFont
536:   m_pTextSym.Size = pDoc.DefaultTextFontSize.Size
  
  'Make sure the wizard stays on top
539:   TopMost Me

  Exit Sub
  
ErrHand:
544:   MsgBox "frmMapSheetWiz Load - " & Err.Description
  Exit Sub
End Sub

Private Sub Form_Unload(Cancel As Integer)
549:   Set m_pApp = Nothing
550:   Set m_pCurrentFrame = Nothing
551:   Set m_pMap = Nothing
552:   Set m_pIndexLayer = Nothing
End Sub

Private Sub optExtent_Click(Index As Integer)
On Error GoTo ErrHand:
  Select Case Index
  Case 0  'Variable
559:     txtMargin.Enabled = True
560:     cmbMargin.Enabled = True
561:     txtFixed.Enabled = False
562:     cmbDataDriven.Enabled = False
563:     If txtMargin.Text = "" Then
564:       cmdNext.Enabled = False
565:     Else
566:       cmdNext.Enabled = True
567:     End If
  Case 1  'Fixed
569:     txtMargin.Enabled = False
570:     cmbMargin.Enabled = False
571:     txtFixed.Enabled = True
572:     cmbDataDriven.Enabled = False
573:     If txtFixed.Text = "" Then
574:       cmdNext.Enabled = False
575:     Else
576:       cmdNext.Enabled = True
577:     End If
  Case 2  'Data driven
579:     txtMargin.Enabled = False
580:     cmbMargin.Enabled = False
581:     txtFixed.Enabled = False
582:     cmbDataDriven.Enabled = True
583:     cmdNext.Enabled = True
584:   End Select

  Exit Sub
ErrHand:
588:   MsgBox "optExtent_Click - " & Err.Description
End Sub

Private Sub txtFixed_KeyUp(KeyCode As Integer, Shift As Integer)
592:   If Not IsNumeric(txtFixed.Text) Then
593:     txtFixed.Text = ""
594:   End If
595:   If txtFixed.Text <> "" Then
596:     cmdNext.Enabled = True
597:   End If
End Sub

Private Sub txtMargin_KeyUp(KeyCode As Integer, Shift As Integer)
601:   If Not IsNumeric(txtMargin.Text) Then
602:     txtMargin.Text = ""
603:   End If
604:   If txtMargin.Text <> "" Then
605:     cmdNext.Enabled = True
606:   End If
End Sub

Private Function FeaturesInTile(pFeature As IFeature, pMap As IMap) As Boolean
'Routine for determining whether the specified tile feature (pFeature) should
'be suppressed.  Tiles are suppressed when there are no features from the checked
'layers in them.
On Error GoTo ErrHand:
  Dim lLoop As Long, pFeatLayer As IFeatureLayer, pSpatial As ISpatialFilter
  Dim pFeatCursor As IFeatureCursor, pSearchFeat As IFeature
  
617:   FeaturesInTile = False
  
619:   Set pSpatial = New SpatialFilter
620:   pSpatial.SpatialRel = esriSpatialRelIntersects
621:   Set pSpatial.Geometry = pFeature.Shape
622:   For lLoop = 0 To lstSuppressTiles.ListCount - 1
623:     If lstSuppressTiles.Selected(lLoop) Then
624:       Set pFeatLayer = FindLayer(lstSuppressTiles.List(lLoop), pMap)
625:       pSpatial.GeometryField = pFeatLayer.FeatureClass.shapeFieldName
626:       Set pFeatCursor = pFeatLayer.Search(pSpatial, True)
627:       Set pSearchFeat = pFeatCursor.NextFeature
628:       If Not pSearchFeat Is Nothing Then
629:         FeaturesInTile = True
        Exit Function
631:       End If
632:     End If
633:   Next lLoop

  Exit Function
  
ErrHand:
638:   MsgBox "FeaturesInTile - " & Err.Description
End Function

Private Sub txtNumbering_KeyUp(KeyCode As Integer, Shift As Integer)
642:   If Not IsNumeric(txtNumbering.Text) Then
643:     txtNumbering.Text = "1"
'  ElseIf CInt(txtNumbering.Text) < 0 Then
'    MsgBox "Can not use a number less than 0!!!"
'    txtNumbering.Text = "1"
647:   End If
End Sub