clscreategrids.cls

一个不错的插件

277:             Else
278:                 sRowID = "A" & sRowID
279:             End If
280:         Next
281:     Else
282:         sRowID = Format(lRow + 1, sNumericFormat)
283:     End If
    ' Col ---------------------------------------------
285:     sNumericFormat = ""
286:     For lLoop = 1 To iColIDLen
287:         sNumericFormat = sNumericFormat & "0"
288:     Next
289:     If m_ColIDType = Alphabetical Then
290:         For lLoop = 1 To iColIDLen
291:             lTmp = 26 ^ lLoop
292:             lTmp2 = (26 ^ (lLoop - 1))
293:             If lCol >= lTmp2 Then
294:                 lCalc = ((((lCol - lTmp2) / lTmp) * 26) + 1) Mod 26
295:                 sColID = Chr(Asc("A") + lCalc) & sColID
296:                 lCol = lCol - (lCalc * lTmp2)
297:             Else
298:                 sColID = "A" & sColID
299:             End If
300:         Next
301:     Else
302:         sColID = Format(lCol + 1, sNumericFormat)
303:     End If
    ' Join --------------------------------------------
305:     If m_IDOrderType = Row_Column Then
306:         If m_UseUnderscore Then
307:             CalculateID = sRowID & "_" & sColID
308:         Else
309:             CalculateID = sRowID & sColID
310:         End If
311:     Else
312:         If m_UseUnderscore Then
313:             CalculateID = sColID & "_" & sRowID
314:         Else
315:             CalculateID = sColID & sRowID
316:         End If
317:     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
325:     lTmp = lBase
326:     lIndex = 1
327:     While lValue > (lTmp - 1)
328:         lTmp = lTmp * lBase
329:         lIndex = lIndex + 1
330:     Wend
331:     GetMinimumStringLength = lIndex
    Exit Function
eh:
334:     Err.Raise Err.Number, "GetMinimumStringLength", "Error in GetMinimumStringLength: " & Err.Description
End Function

Public Sub RunStandardGUI(pApp As IApplication)
338:     Set frmGridSettings.m_Application = pApp
339:     frmGridSettings.Tickle
340:     SetWindowLong frmGridSettings.hwnd, GWL_HWNDPARENT, pApp.hwnd
341:     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
416:     Screen.MousePointer = vbArrowHourglass
    
    ' Init
419:     Set pMx = Application.Document
420:     For lLoop = 0 To pMx.FocusMap.LayerCount - 1
421:         If TypeOf pMx.FocusMap.Layer(lLoop) Is IFeatureLayer Then
422:             If UCase(pMx.FocusMap.Layer(lLoop).Name) = UCase(m_DestFL.Name) Then
423:                 Set pFL = pMx.FocusMap.Layer(lLoop)
424:                 Exit For
425:             End If
426:         End If
427:     Next
428:     If pFL Is Nothing Then
429:         MsgBox "No match in the Map for layer '" & m_DestFL.Name & "'."
        Exit Sub
431:     End If
432:     Set pFC = pFL.FeatureClass
    ' Check for required fields - that the field exists
    Dim bErrorWithFields As Boolean
435:     bErrorWithFields = (pFC.FindField(m_FldID) < 0)
436:     If Len(m_FldRowNum) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldRowNum) < 0)
437:     If Len(m_FldColNum) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldColNum) < 0)
438:     If Len(m_FldScale) > 0 Then bErrorWithFields = bErrorWithFields Or (pFC.FindField(m_FldScale) < 0)
    ' If error
440:     If bErrorWithFields Then
441:         Err.Raise vbObjectError, "GenerateGrids", "Could not find all the given field names in " & pFL.Name & "." _
            & vbCrLf & " - " & m_FldID & ", " & m_FldRowNum & ", " & m_FldColNum & ", " & m_FldScale
443:     End If
    ' Check the field types
445:     bErrorWithFields = (pFC.Fields.Field(pFC.FindField(m_FldID)).Type <> esriFieldTypeString)
446:     If Len(m_FldRowNum) > 0 Then
447:         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))
452:     End If
453:     If Len(m_FldColNum) > 0 Then
454:         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))
459:     End If
460:     If Len(m_FldScale) > 0 Then
461:         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))
466:     End If
    ' if error
468:     If bErrorWithFields Then
469:         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."
471:     End If
    ' Get the dataset and workspace (to start editing upon)
473:     Set pFeatDataset = pFC.FeatureDataset
474:     If Not pFeatDataset Is Nothing Then
475:         Set pWorkspaceEdit = pFeatDataset.Workspace
476:     Else
        ' Is a shapefile, go via just IDataset
478:         Set pDataset = pFC
479:         Set pWorkspaceEdit = pDataset.Workspace
480:     End If
481:     dDataFrameWidth = m_dFrameWidthInPageUnits
482:     dDataFrameHeight = m_dFrameHeightInPageUnits
    ' Start Editing
484:     pWorkspaceEdit.StartEditing False
485:     pWorkspaceEdit.StartEditOperation
    
    ' If replacing, delete all existing polygons
488:     Set pProgress = New frmProgress
489:     m_pProgress.Create pProgress
490:     If m_RemoveGrids Then
        Dim pFCu As IFeatureCursor
        Dim pT As ITable
493:         Set pFCu = m_DestFL.Search(Nothing, False)
494:         Set pT = m_DestFL.FeatureClass
495:         pProgress.ProgressBar1.Min = 0
496:         pProgress.ProgressBar1.Max = 100
497:         If pT.RowCount(Nothing) = 0 Then
498:             dIncrement = 99
499:         Else
500:             dIncrement = 100 / pT.RowCount(Nothing)
501:         End If
502:         pProgress.ProgressBar1.value = 0
503:         pProgress.lblInformation.Caption = "Deleting previous grids..."
504:         pProgress.cmdCancel.Visible = False        ' User cannot cancel this step
        
506:         m_pProgress.Visible = True
507:         Set pFeature = pFCu.NextFeature
508:         While Not pFeature Is Nothing
509:             pFeature.Delete
510:             If (pProgress.ProgressBar1.value + dIncrement) <= pProgress.ProgressBar1.Max Then
511:                 pProgress.ProgressBar1.value = pProgress.ProgressBar1.value + dIncrement
512:             Else
513:                 pProgress.lblInformation.Caption = "Warning: Val > Max (" & pProgress.ProgressBar1.Max & ")"
514:             End If
515:             Set pFeature = pFCu.NextFeature
516:         Wend
517:         m_pProgress.Visible = False
518:     End If
    
    ' Calc the row/column extents, grid size (map units), ID lengths and starting coordinate
521:     Set pStartingCoord = New esrigeometry.Point
522:     pStartingCoord.PutCoords m_StartX, m_StartY
523:     dConvertPageToMapUnits = CalculatePageToMapRatio(Application)
524:     dGridSizeW = ((m_dMapScale * dDataFrameWidth) / dConvertPageToMapUnits)
525:     dGridSizeH = ((m_dMapScale * dDataFrameHeight) / dConvertPageToMapUnits)
526:     If Not (pFL.FeatureClass.FeatureDataset Is Nothing) Then
527:         CalculateRowColCounts m_StartX, m_StartY, m_EndX, m_EndY, _
            dGridSizeW, dGridSizeH, GetValidExtentForLayer(m_DestFL), lColCount, lRowCount
529:     Else
530:         CalculateRowColCounts m_StartX, m_StartY, m_EndX, m_EndY, _
            dGridSizeW, dGridSizeH, Nothing, lColCount, lRowCount
532:     End If
533:     If lColCount = 0 Or lRowCount = 0 Then
534:         Err.Raise vbObjectError, "GenerateGrids", "CalculateRowColCounts returned zero row/columns"
535:     End If
536:     If m_ColIDType = Alphabetical Then
537:         lBase = 26
538:     Else
539:         lBase = 10
540:     End If
541:     iStringLengthCol = GetMinimumStringLength(lColCount, lBase)
542:     If m_RowIDType = Alphabetical Then
543:         lBase = 26
544:     Else
545:         lBase = 10
546:     End If
547:     iStringLengthRow = GetMinimumStringLength(lRowCount, lBase)
    
    ' Create and add the new Grid polygon features
550:     bOKToAdd = True
551:     pProgress.ProgressBar1.Min = 0
552:     pProgress.ProgressBar1.Max = 100
553:     pProgress.ProgressBar1.value = 0
554:     pProgress.lblInformation.Caption = "Creating new Grid features..."
555:     pProgress.cmdCancel.Visible = True
556:     m_pProgress.Visible = True
557:     dIncrement = 99.9 / (lRowCount * lColCount)
558:     Set pInsertFeatureCursor = pFC.Insert(True)
559:     Set pInsertFeatureBuffer = pFC.CreateFeatureBuffer
560:     For lRow = 0 To lRowCount - 1
561:         For lCol = 0 To lColCount - 1
            ' Create the source polygon
563:             Set pGridPolygon = CreateGridPoly2(pStartingCoord, lRow, lCol, dGridSizeW, dGridSizeH)
            ' If required, check for containing features
565:             If m_NoEmptyGrids Then