clscreategrids.cls

使用VB和ArcObject结合的程序

254:     For lLoop = 1 To iRowIDLen
255:         sNumericFormat = sNumericFormat & "0"
256:     Next
257:     If m_RowIDType = Alphabetical Then
258:         For lLoop = 1 To iRowIDLen
259:             lTmp = 26 ^ lLoop
260:             lTmp2 = (26 ^ (lLoop - 1))
261:             If lRow >= lTmp2 Then
262:                 lCalc = ((((lRow - lTmp2) / lTmp) * 26) + 1) Mod 26
263:                 sRowID = Chr(Asc("A") + lCalc) & sRowID
264:                 lRow = lRow - (lCalc * lTmp2)
265:             Else
266:                 sRowID = "A" & sRowID
267:             End If
268:         Next
269:     Else
270:         sRowID = Format(lRow + 1, sNumericFormat)
271:     End If
    ' Col ---------------------------------------------
273:     sNumericFormat = ""
274:     For lLoop = 1 To iColIDLen
275:         sNumericFormat = sNumericFormat & "0"
276:     Next
277:     If m_ColIDType = Alphabetical Then
278:         For lLoop = 1 To iColIDLen
279:             lTmp = 26 ^ lLoop
280:             lTmp2 = (26 ^ (lLoop - 1))
281:             If lCol >= lTmp2 Then
282:                 lCalc = ((((lCol - lTmp2) / lTmp) * 26) + 1) Mod 26
283:                 sColID = Chr(Asc("A") + lCalc) & sColID
284:                 lCol = lCol - (lCalc * lTmp2)
285:             Else
286:                 sColID = "A" & sColID
287:             End If
288:         Next
289:     Else
290:         sColID = Format(lCol + 1, sNumericFormat)
291:     End If
    ' Join --------------------------------------------
293:     If m_IDOrderType = Row_Column Then
294:         If m_UseUnderscore Then
295:             CalculateID = sRowID & "_" & sColID
296:         Else
297:             CalculateID = sRowID & sColID
298:         End If
299:     Else
300:         If m_UseUnderscore Then
301:             CalculateID = sColID & "_" & sRowID
302:         Else
303:             CalculateID = sColID & sRowID
304:         End If
305:     End If
End Function

Private Function GetMinimumStringLength(lValue As Long, lBase As Long) As Integer
    Dim lTmp As Long, lIndex As Long
    
    On Error GoTo eh
    ' ROW
313:     lTmp = lBase
314:     lIndex = 1
315:     While lValue > (lTmp - 1)
316:         lTmp = lTmp * lBase
317:         lIndex = lIndex + 1
318:     Wend
319:     GetMinimumStringLength = lIndex
    Exit Function
eh:
322:     Err.Raise Err.Number, "GetMinimumStringLength", "Error in GetMinimumStringLength: " & Err.Description
End Function

Public Sub RunStandardGUI(pApp As IApplication)
326:     Set frmGridSettings.m_Application = pApp
327:     frmGridSettings.Tickle
328:     SetWindowLong frmGridSettings.hwnd, GWL_HWNDPARENT, pApp.hwnd
329:     frmGridSettings.Show vbModeless
End Sub

'Private Function CreateGridPoly(pStartPoint As IPoint, lRow As Long, lCol As Long, _
'                                dGridWidth As Double, dGridHeight As Double) As IPolygon
'    Dim pPntColl As IPointCollection
'    Dim pPoint As IPoint
'    Dim dX As Double, dY As Double
'
'    Set CreateGridPoly = New Polygon
'    Set pPntColl = CreateGridPoly
'    Set pPoint = new esrigeometry.point
'    pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
'    pPntColl.AddPoint pPoint
'    Set pPoint = new esrigeometry.point
'    pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
'    pPntColl.AddPoint pPoint
'    Set pPoint = new esrigeometry.point
'    pPoint.PutCoords pStartPoint.X + ((lCol + 1) * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
'    pPntColl.AddPoint pPoint
'    Set pPoint = new esrigeometry.point
'    pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + ((lRow + 1) * dGridHeight)
'    pPntColl.AddPoint pPoint
'    Set pPoint = new esrigeometry.point
'    pPoint.PutCoords pStartPoint.X + (lCol * dGridWidth), pStartPoint.Y + (lRow * dGridHeight)
'    pPntColl.AddPoint pPoint
'
'    'Set CreateGridPoly = pPntColl
'    Debug.Print CreateGridPoly.IsClosed
'    'Debug.Print CreateGridPoly.Envelope.XMin & "," & CreateGridPoly.Envelope.YMin
'
'End Function

Public Sub GenerateGrids2(Application As IApplication) ', _
                         'Optional bRemoveEmptyGrids As Boolean = False, _
                         'Optional bReplaceExistingGrids As Boolean = False)
    Dim pEditor As IEditor
    Dim pUID As New UID
    Dim pWorkspaceEdit As IWorkspaceEdit
    Dim lLoop As Long
    Dim pFeatDataset As IFeatureDataset
    Dim pFeature As IFeature
    Dim pFeatCur As IFeatureCursor
    Dim pSourcePolygon As IPolygon
    Dim pGridPolygon As IPolygon
    Dim pPointColl As IPointCollection
    Dim pStartingCoord As IPoint
    Dim pPoint As IPoint
    Dim lRow As Long
    Dim lCol As Long
    Dim lRowCount As Long
    Dim lColCount As Long
    Dim pClone As IClone
    Dim dGridSizeW As Double
    Dim dGridSizeH As Double
    Dim pTransform As ITransform2D
    Dim bOKToAdd As Boolean
    Dim iStringLengthRow As Integer
    Dim iStringLengthCol As Integer
    Dim pDataset As IDataset
    Dim lBase As Long
    Dim dDataFrameWidth As Double
    Dim dDataFrameHeight As Double
    Dim dConvertPageToMapUnits As Double
    Dim dIncrement As Double
    Dim pInsertFeatureBuffer As IFeatureBuffer
    Dim pInsertFeatureCursor As IFeatureCursor
    Dim pMx As IMxDocument
    Dim pFL As IFeatureLayer
    Dim pFC As IFeatureClass
    Dim pProgress As frmProgress
    
    On Error GoTo eh
    
    ' Set mouse pointer
404:     Screen.MousePointer = vbArrowHourglass
    
    ' Init
407:     Set pMx = Application.Document
408:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
409:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
410:             If UCase(pMx.FocusMap.Layer(lLoop).Name) = UCase(m_DestFL.Name) Then
411:                 Set pFL = pMx.FocusMap.Layer(lLoop)
412:                 Exit For
413:             End If
414:         End If
415:     Next
416:     If pFL Is Nothing Then
417:         MsgBox "No match in the Map for layer '" & m_DestFL.Name & "'."
        Exit Sub
419:     End If
420:     Set pFC = pFL.FeatureClass
    ' Check for required fields - that the field exists
    Dim bErrorWithFields As Boolean
423:     bErrorWithFields = (pFC.FindField(m_FldID) < 0)
424:     If Len(m_FldRowNum) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldRowNum) < 0)
425:     If Len(m_FldColNum) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldColNum) < 0)
426:     If Len(m_FldScale) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldScale) < 0)
    ' If error
428:     If bErrorWithFields Then
429:         Err.Raise vbObjectError, "GenerateGrids", "Could not find all the given field names in " & pFL.Name & "." _
            & vbCrLf & " - " & m_FldID & ", " & m_FldRowNum & ", " & m_FldColNum & ", " & m_FldScale
431:     End If
    ' Check the field types
433:     bErrorWithFields = (pFC.Fields.Field(pFC.FindField(m_FldID)).Type <> esriFieldTypeString)
434:     If Len(m_FldRowNum) > 0 Then
435:         bErrorWithFields = bErrorWithFields Or _
           ((pFC.Fields.Field(pFC.FindField(m_FldRowNum)).Type <> esriFieldTypeDouble) And _
            (pFC.Fields.Field(pFC.FindField(m_FldRowNum)).Type <> esriFieldTypeInteger) And _
            (pFC.Fields.Field(pFC.FindField(m_FldRowNum)).Type <> esriFieldTypeSingle) And _
            (pFC.Fields.Field(pFC.FindField(m_FldRowNum)).Type <> esriFieldTypeSmallInteger))
440:     End If
441:     If Len(m_FldColNum) > 0 Then
442:         bErrorWithFields = bErrorWithFields Or _
           ((pFC.Fields.Field(pFC.FindField(m_FldColNum)).Type <> esriFieldTypeDouble) And _
            (pFC.Fields.Field(pFC.FindField(m_FldColNum)).Type <> esriFieldTypeInteger) And _
            (pFC.Fields.Field(pFC.FindField(m_FldColNum)).Type <> esriFieldTypeSingle) And _
            (pFC.Fields.Field(pFC.FindField(m_FldColNum)).Type <> esriFieldTypeSmallInteger))
447:     End If
448:     If Len(m_FldScale) > 0 Then
449:         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))
454:     End If
    ' if error
456:     If bErrorWithFields Then
457:         Err.Raise vbObjectError, "GenerateGrids", "Given field names are not of the correct type." _
            & vbCrLf & "Grid ID field must be a Text field, all others must be numeric fields."
459:     End If
    ' Get the dataset and workspace (to start editing upon)
461:     Set pFeatDataset = pFC.FeatureDataset
462:     If Not pFeatDataset Is Nothing Then
463:         Set pWorkspaceEdit = pFeatDataset.Workspace
464:     Else
        ' Is a shapefile, go via just IDataset
466:         Set pDataset = pFC
467:         Set pWorkspaceEdit = pDataset.Workspace
468:     End If
469:     dDataFrameWidth = m_dFrameWidthInPageUnits
470:     dDataFrameHeight = m_dFrameHeightInPageUnits
    ' Start Editing
472:     pWorkspaceEdit.StartEditing False
473:     pWorkspaceEdit.StartEditOperation
    
    ' If replacing, delete all existing polygons
476:     Set pProgress = New frmProgress
477:     m_pProgress.Create pProgress
478:     If m_RemoveGrids Then
        Dim pFCu As IFeatureCursor
        Dim pT As ITable
481:         Set pFCu = m_DestFL.Search(Nothing, False)
482:         Set pT = m_DestFL.FeatureClass
483:         pProgress.ProgressBar1.Min = 0
484:         pProgress.ProgressBar1.Max = 100
485:         If pT.RowCount(Nothing) = 0 Then
486:             dIncrement = 99
487:         Else
488:             dIncrement = 100 / pT.RowCount(Nothing)
489:         End If
490:         pProgress.ProgressBar1.Value = 0
491:         pProgress.lblInformation.Caption = "Deleting previous grids..."
492:         pProgress.cmdCancel.Visible = False        ' User cannot cancel this step
        
494:         m_pProgress.Visible = True
495:         Set pFeature = pFCu.NextFeature
496:         While Not pFeature Is Nothing
497:             pFeature.Delete
498:             If (pProgress.ProgressBar1.Value + dIncrement) <= pProgress.ProgressBar1.Max Then
499:                 pProgress.ProgressBar1.Value = pProgress.ProgressBar1.Value + dIncrement
500:             Else
501:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
502:             End If
503:             Set pFeature = pFCu.NextFeature
504:         Wend
505:         m_pProgress.Visible = False
506:     End If
    
    ' Calc the row/column extents, grid size (map units), ID lengths and starting coordinate
509:     Set pStartingCoord = New esrigeometry.Point
510:     pStartingCoord.PutCoords m_StartX, m_StartY
511:     dConvertPageToMapUnits = CalculatePageToMapRatio(Application)
512:     dGridSizeW = ((m_dMapScale * dDataFrameWidth) / dConvertPageToMapUnits)
513:     dGridSizeH = ((m_dMapScale * dDataFrameHeight) / dConvertPageToMapUnits)
514:     If Not (pFL.FeatureClass.FeatureDataset Is Nothing) Then
515:         CalculateRowColCounts m_StartX, m_StartY, m_EndX, m_EndY, _
            dGridSizeW, dGridSizeH, GetValidExtentForLayer(m_DestFL), lColCount, lRowCount
517:     Else
518:         CalculateRowColCounts m_StartX, m_StartY, m_EndX, m_EndY, _
            dGridSizeW, dGridSizeH, Nothing, lColCount, lRowCount
520:     End If
521:     If lColCount = 0 Or lRowCount = 0 Then
522:         Err.Raise vbObjectError, "GenerateGrids", "CalculateRowColCounts returned zero row/columns"
523:     End If
524:     If m_ColIDType = Alphabetical Then
525:         lBase = 26
526:     Else
527:         lBase = 10
528:     End If
529:     iStringLengthCol = GetMinimumStringLength(lColCount, lBase)
530:     If m_RowIDType = Alphabetical Then
531:         lBase = 26
532:     Else
533:         lBase = 10
534:     End If
535:     iStringLengthRow = GetMinimumStringLength(lRowCount, lBase)
    
    ' Create and add the new Grid polygon features
538:     bOKToAdd = True
539:     pProgress.ProgressBar1.Min = 0
540:     pProgress.ProgressBar1.Max = 100
541:     pProgress.ProgressBar1.Value = 0
542:     pProgress.lblInformation.Caption = "Creating new Grid features..."
543:     pProgress.cmdCancel.Visible = True
544:     m_pProgress.Visible = True
545:     dIncrement = 99.9 / (lRowCount * lColCount)
546:     Set pInsertFeatureCursor = pFC.Insert(True)
547:     Set pInsertFeatureBuffer = pFC.CreateFeatureBuffer