adddataset.frm

GIS地理信息系统开发。大名鼎鼎的MAPX＋VisualBasic6.0软件开发

  cmbRefineField.AddItem "<AutoDetect>"
  For i = 1 To gRecSrc(iSrcNum).Recordset.Fields.Count
    sName = gRecSrc(iSrcNum).Recordset.Fields(i - 1).Name
    cmbGeoField.AddItem sName
    cmbRefineField.AddItem sName
  Next
  cmbGeoField.ListIndex = 0
  cmbRefineField.ListIndex = 0
End Sub

Private Sub InitDataFields(ByVal iSrcNum As Integer)
  Dim i As Integer, sName As String, iType As Integer

  Set DataFields = New MapXLib.Fields

  lstDestFields.Clear
  ReDim DataSrcs(gRecSrc(iSrcNum).Recordset.Fields.Count)
  For i = 1 To gRecSrc(iSrcNum).Recordset.Fields.Count
    sName = gRecSrc(iSrcNum).Recordset.Fields(i - 1).Name
    iType = gRecSrc(iSrcNum).Recordset.Fields(i - 1).Type
    lstDestFields.AddItem sName
    lstDestFields.ItemData(i - 1) = i
    iType = MakeFieldType(iType)
    If iType = miTypeString Then
      DataFields.Add i, sName, miAggregationIndividual, iType
    Else
      DataFields.Add i, sName, miAggregationSum, iType
    End If
    DataSrcs(i) = i
'    DataFields.Add sName, i, 1, 1
  Next
  cmbGeoField.ListIndex = 0
  cmbRefineField.ListIndex = 0
End Sub

Private Sub cmbSource_Click()
  Dim i As Integer

  If cmbSource.ListIndex + 1 = iPrevSrc Then
    Exit Sub
  End If
  iPrevSrc = cmbSource.ListIndex + 1
  InitGeoFields iPrevSrc
  InitDataFields iPrevSrc
  txtName.Text = cmbSource.Text
End Sub

Private Sub cmdAdd_Click()
  Dim r As Integer, sLayer As String, bNoDataset As Boolean, lGF As Long

  If Trim$(txtName.Text) = "" Then
    r = MsgBox("Please enter DataSet name.", vbOKOnly, "Add DataSet")
    Exit Sub
  End If
  bNoDataset = False
  On Error GoTo NoDataset
  lGF = gMap.Datasets(txtName.Text).GeoField
  On Error GoTo 0
  If Not bNoDataset Then
    r = MsgBox("DataSet " & txtName.Text & " already exists. Please enter another name.", vbOKOnly, "Add DataSet")
    Exit Sub
  End If
  lstDestFields_Click
  If cmbLayer.ListIndex = 0 Then ' AutoDetect
    sLayer = ""
  Else
    sLayer = cmbLayer.List(cmbLayer.ListIndex)
  End If
On Error GoTo addError
  gMap.Datasets.Add 1, gRecSrc(cmbSource.ListIndex + 1).Recordset.Clone, txtName.Text, cmbGeoField.ListIndex, cmbRefineField.ListIndex, sLayer, DataFields
On Error GoTo 0
  AddDataset.Hide
  Exit Sub
NoDataset:
  bNoDataset = True
  Resume Next
addError:
    MsgBox Err.Description
    Resume Next
End Sub

Private Sub cmdAddFields_Click()
  Dim iDelRec() As Integer, i As Integer, iDelNum As Integer, sName As String

  ReDim iDelRec(1 To lstSrcFields.SelCount)
  iDelNum = 0

  For i = 0 To lstSrcFields.ListCount - 1
    If lstSrcFields.Selected(i) Then
      sName = lstSrcFields.List(i)
      lstDestFields.ItemData(AddSortedItem(lstDestFields, sName, lstSrcFields.ItemData(i))) = lstSrcFields.ItemData(i)
      AddSortedField DataFields, DataSrcs, sName, lstSrcFields.ItemData(i), rmFields(sName).AggregationFunction, rmFields(sName).Type
      rmFields.Remove sName
      iDelNum = iDelNum + 1
      iDelRec(iDelNum) = i
    End If
  Next
  
  For i = 1 To iDelNum
    lstSrcFields.RemoveItem iDelRec(i) - i + 1
  Next
  cmdAddFields.Enabled = False
End Sub

Private Sub cmdCancel_Click()
  AddDataset.Hide
End Sub

Private Sub cmdRemoveFields_Click()
  Dim i As Integer, iDelRec() As Integer, iDelNum As Integer, sName As String

  ReDim iDelRec(1 To lstDestFields.SelCount)
  iDelNum = 0

  lstDestFields_Click
  
  For i = 0 To lstDestFields.ListCount - 1
    If lstDestFields.Selected(i) Then
      sName = lstDestFields.List(i)
      rmFields.Add DataSrcs(FindFieldInd(DataFields, sName)), sName, DataFields(sName).AggregationFunction, DataFields(sName).Type
      RemoveField DataFields, DataSrcs, sName
      lstSrcFields.ItemData(AddSortedItem(lstSrcFields, sName, lstDestFields.ItemData(i))) = lstDestFields.ItemData(i)
      iDelNum = iDelNum + 1
      iDelRec(iDelNum) = i
    End If
  Next
  
  For i = 1 To iDelNum
    lstDestFields.RemoveItem iDelRec(i) - i + 1
  Next
  bWasFirstField = False
  lstDestFields_Click
End Sub

Private Sub lstDestFields_Click()
  Dim iType As Integer, iAggr As Integer

  bTextOff = True

  cmdRemoveFields.Enabled = (lstDestFields.SelCount > 0)
  cmbAggregation.Enabled = (lstDestFields.SelCount = 1)
  txtFieldName.Enabled = (lstDestFields.SelCount = 1)
  If bWasFirstField Then
    If txtFieldName.Text <> sPrevName Or cmbAggregation.ListIndex <> iPrevAggr Then
      iType = DataFields(sPrevName).Type
      iAggr = cmbAggregation.ItemData(cmbAggregation.ListIndex)
      RemoveField DataFields, DataSrcs, sPrevName
      AddSortedField DataFields, DataSrcs, txtFieldName.Text, iPrevInd, iAggr, iType
    End If
  End If
  bWasFirstField = (lstDestFields.SelCount = 1)
  If bWasFirstField Then
    sPrevName = lstDestFields.List(lstDestFields.ListIndex)
    iPrevInd = lstDestFields.ItemData(lstDestFields.ListIndex)
    txtFieldName.Text = sPrevName
    cmbAggregation.ListIndex = MakeAggregationIndex(DataFields(lstDestFields.ListIndex + 1).AggregationFunction)
    iPrevAggr = cmbAggregation.ListIndex
  Else
    txtFieldName.Text = ""
  End If
  
  bTextOff = False
End Sub

Private Sub lstSrcFields_Click()
  cmdAddFields.Enabled = (lstSrcFields.SelCount > 0)
End Sub

Private Sub txtFieldName_Change()
  If Not bTextOff Then
    lstDestFields.List(lstDestFields.ListIndex) = txtFieldName.Text
  End If
End Sub

Private Function AddSortedItem(ListCtrl As ListBox, sItem As String, iItem As Integer) As Integer
  Dim i As Integer, ub As Integer

  If ListCtrl.ListCount = 0 Then
    ListCtrl.AddItem sItem
    ListCtrl.ItemData(0) = iItem
    AddSortedItem = 0
    Exit Function
  End If
  
  For i = 0 To ListCtrl.ListCount - 1
    If iItem < ListCtrl.ItemData(i) Then
      ListCtrl.AddItem sItem, i
      ListCtrl.ItemData(i) = iItem
      AddSortedItem = i
      Exit Function
    End If
  Next
  
  ListCtrl.AddItem sItem
  ListCtrl.ItemData(ListCtrl.ListCount - 1) = iItem
  AddSortedItem = ListCtrl.ListCount - 1
End Function

Private Sub AddSortedField(DF As MapXLib.Fields, SrcArray() As Integer, ByVal sName As String, ByVal iInd As Integer, ByVal iAggr As Integer, ByVal iType As Integer)
  Dim DF2 As New MapXLib.Fields, bWas As Boolean, i As Integer, iAddInd As Integer

  If DF.Count = 0 Then
    DF.Add iInd, sName, iAggr, iType
    SrcArray(1) = iInd
    Exit Sub
  End If

  bWas = False
  For i = 1 To DF.Count
    If Not bWas Then
      If iInd < SrcArray(i) Then
        DF2.Add iInd, sName, iAggr, iType
        bWas = True
        iAddInd = i
      End If
    End If
    DF2.Add SrcArray(i), DF(i).Name, DF(i).AggregationFunction, DF(i).Type
  Next
  
  If Not bWas Then
    DF2.Add iInd, sName, iAggr, iType
    SrcArray(DF.Count + 1) = iInd
  Else
    For i = DF.Count To iAddInd Step -1
      SrcArray(i + 1) = SrcArray(i)
    Next
    SrcArray(iAddInd) = iInd
  End If
  
  Set DF = DF2
End Sub

Private Function FindFieldInd(DF As MapXLib.Fields, ByVal sField As String) As Integer
  Dim i As Integer

  For i = 1 To DF.Count
    If DF(i).Name = sField Then
      FindFieldInd = i
      Exit Function
    End If
  Next
  FindFieldInd = 0
End Function

Private Sub RemoveField(DF As MapXLib.Fields, SrcArray() As Integer, ByVal sField As String)
  Dim iInd As Integer, i As Integer

  iInd = FindFieldInd(DF, sField)
  DF.Remove sField
  
  For i = iInd To DF.Count
    SrcArray(i) = SrcArray(i + 1)
  Next
End Sub

Private Function MakeFieldType(ByVal iType As Integer) As Integer
  Select Case iType
    Case dbDate, dbText, dbBoolean
      MakeFieldType = miTypeString
    Case dbInteger, dbLong, dbCurrency, dbSingle, dbDouble, dbByte
      MakeFieldType = miTypeNumeric
  End Select
End Function

Private Function MakeAggregationIndex(ByVal iAggr As Integer) As Integer
  Select Case iAggr
    Case miAggregationAverage
      MakeAggregationIndex = 1
    Case miAggregationSum
      MakeAggregationIndex = 0
    Case miAggregationIndividual
      MakeAggregationIndex = 2
    Case miAggregationCount
      MakeAggregationIndex = 3
  End Select
End Function