frmmodifydata.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

lstAppData.ListItems.Clear

If CustomLayers(Index).RelationCount > 0 Then
    

    Data1.DatabaseName = CustomLayers(Index).Relation(0).Database
    lstAppData.ListItems.Clear
    
    Data1.RecordSource = "select * from " & CustomLayers(Index).Relation(0).Table & " where SID=" & RecModify.Fields("SID").ValueAsString
    Data1.Refresh
    
    If Not Data1.Recordset.EOF Then
    
    For lpointer = 0 To Data1.Recordset.Fields.Count - 1
        If Data1.Recordset.Fields(lpointer).Name <> "SID" Then
            Set ListX = lstAppData.ListItems.Add(Key:=Data1.Recordset.Fields(lpointer).Name, text:=Data1.Recordset.Fields(lpointer).Name)
            ListX.ListSubItems.Add Key:="Attribut", text:=CStr(Format(Data1.Recordset.Fields(lpointer).Value))
        End If
    Next
    
    End If
        
End If

End Sub
Private Sub AppDataRefresh()
'--------------------------------------------------------------------------------------
'扩展数据更新
'--------------------------------------------------------------------------------------
If lstAppData.SelectedItem Is Nothing Then
    txtType = ""
    txtLength = ""
    txtField = ""
    txtNumber = ""
    txtText = ""
    fraInput.Enabled = False
Else
    
    txtField = lstAppData.SelectedItem.text
    fraInput.Enabled = True
    txtText.Visible = False
    txtData.Visible = False
    cmbText.Visible = False
    txtNumber.Visible = False
    cmdPic.Visible = False
    
    lstSelect.Clear
    Select Case Data1.Recordset.Fields(txtField).Type
        Case dbLong
            txtType = "长整型"
            txtNumber.Visible = True
            txtNumber.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshAppAutoComplete(txtField)
        
        Case dbInteger
            txtType = "整型"
            txtNumber.Visible = True
            txtNumber.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshAppAutoComplete(txtField)
        
        Case dbSingle
            txtType = "单精度浮点数"
            txtNumber.Visible = True
            txtNumber.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshAppAutoComplete(txtField)
        
        Case dbDouble
            txtType = "双精度浮点数"
            txtNumber.Visible = True
            txtNumber.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshAppAutoComplete(txtField)
        
        Case dbFloat
            txtType = "浮点数"
            txtNumber.Visible = True
            txtNumber.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshAppAutoComplete(txtField)
        
        Case dbText
            txtType = "字符串"
            If CustomLayers(Index).PictureField <> lstAppData.SelectedItem.text Then
                If fnGetRuleString(txtField) Then
                    cmbText.Visible = True
                    txtText.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
                Else
                    txtText.Visible = True
                    txtText.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
                    Call RefreshAppAutoComplete(txtField)
                End If
            Else
                cmdPic.Visible = True
                txtText.text = lstAppData.SelectedItem.ListSubItems("Attribut").text
                
            End If
        
        Case dbDate
            txtType = "日期"
            txtData.Visible = True
            If IsNull(Data1.Recordset.Fields(txtField).Value) Then
                txtData.Value = Date
            Else
                txtData.Value = CDate(Format(Data1.Recordset.Fields(txtField).Value))
            End If
            Call RefreshAppAutoComplete(txtField)
            
        Case Else
            txtType = "其他类型"
            txtNumber = ""
            txtText = ""
            fraInput.Enabled = False
    End Select
    
End If


End Sub
Private Sub MapDataRefresh()
'--------------------------------------------------------------------------------------
'基本数据更新
'--------------------------------------------------------------------------------------
If lstMapData.SelectedItem Is Nothing Then
    txtType = ""
    txtLength = ""
    txtField = ""
    
    txtNumber = ""
    
    txtText = ""
    fraInput.Enabled = False
Else
    
    txtField = lstMapData.SelectedItem.text
    lstSelect.Clear
    fraInput.Enabled = True
    txtText.Visible = False
    txtData.Visible = False
    cmbText.Visible = False
    txtNumber.Visible = False
    cmdPic.Visible = False
    Select Case RecModify.Fields(txtField).Type
            
        Case moLong
            txtType = "长整型"
            txtNumber.Visible = True
            txtNumber.text = lstMapData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshMapAutoComplete(txtField)
        
        Case moDouble
            txtType = "双精度浮点数"
            txtNumber.Visible = True
            txtNumber.text = lstMapData.SelectedItem.ListSubItems("Attribut").text
            
        Case moString
            txtType = "文字/字符串"
            
            If fnGetRuleString(txtField) Then
                cmbText.Visible = True
                txtText.text = lstMapData.SelectedItem.ListSubItems("Attribut").text
            Else
                txtText.Visible = True
                txtText.text = lstMapData.SelectedItem.ListSubItems("Attribut").text
                Call RefreshMapAutoComplete(txtField)
            End If
            
        Case moDate
            txtType = "日期"
            txtData.Visible = True
            txtText.text = lstMapData.SelectedItem.ListSubItems("Attribut").text
            Call RefreshMapAutoComplete(txtField)
            
        Case Else
            txtType = "其他类型"
            txtNumber = ""
            txtText = ""
            fraInput.Enabled = False
    End Select
    
End If


End Sub
Private Function fnGetRuleString(strField As String) As Boolean
'-----------------------------------------------------------------------------------------
'获取LayerName.fld文件中的值约束条件
'此条件用一限制某字段的取值范围
'-----------------------------------------------------------------------------------------

Dim strValue1 As String
Dim strValue2 As String
On Error GoTo NoFileErr
Open CustomLayers(Index).strPath & "\" & CustomLayers(Index).strName & ".fld" For Input As #2
Dim bFlag As Boolean
bFlag = False
Do Until EOF(2)
    Input #2, strValue1
    Input #2, strValue2
    If Trim(strValue1) = strField Then
        bFlag = True
        Exit Do
    End If
Loop

If Not bFlag Then
    fnGetRuleString = False
Else
    Dim lSeekNow As Long
    Dim lSeekLast As Long
    lSeekNow = 0
    cmbText.Clear
    Do
        lSeekLast = lSeekNow
        lSeekNow = InStr(lSeekLast + 1, strValue2, ";")
        If lSeekNow > 0 Then
            cmbText.AddItem Mid(strValue2, lSeekLast + 1, lSeekNow - lSeekLast - 1)
            
        Else
            cmbText.AddItem Mid(strValue2, lSeekLast + 1)
            Exit Do
        End If
    Loop
    
    fnGetRuleString = True
End If


Close
Exit Function
NoFileErr:
fnGetRuleString = False


End Function
Private Sub RefreshAppAutoComplete(strFieldName As String)
'-----------------------------------------------------------------------------------------
'调集扩展数据的数据库中已有数据作为参考
'-----------------------------------------------------------------------------------------

Dim tmpRecord As MapObjects2.Recordset
Dim ExistValue As New MapObjects2.Strings
Dim tmpTable As New Table

tmpTable.Database = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & CustomLayers(Index).Relation(0).Database
tmpTable.Name = CustomLayers(Index).Relation(0).Table
Set tmpRecord = tmpTable.Records

lstSelect.Clear
tmpRecord.MoveFirst

Do Until tmpRecord.EOF
    ExistValue.Add CStr(Trim(tmpRecord.Fields(strFieldName).Value))
    tmpRecord.MoveNext
    If ExistValue.Count > 100 Then Exit Do
    DoEvents
Loop

Dim lpValue As Long
For lpValue = 0 To ExistValue.Count2 - 1
    If ExistValue(lpValue) <> "" Then lstSelect.AddItem ExistValue(lpValue)
    DoEvents
Next lpValue

Set tmpRecord = Nothing
Set ExistValue = Nothing
Set tmpTable = Nothing


End Sub

Private Sub RefreshMapAutoComplete(strFieldName As String)
'-----------------------------------------------------------------------------------------
'调集扩展数据的数据库中已有数据作为参考
'-----------------------------------------------------------------------------------------

Dim tmpRecord As MapObjects2.Recordset
Dim ExistValue As New MapObjects2.Strings
Dim tmpTable As New Table

tmpTable.Database = "dBASE 5.0; database=" & CustomLayers(Index).strPath
tmpTable.Name = CustomLayers(Index).strName
Set tmpRecord = tmpTable.Records

lstSelect.Clear
tmpRecord.MoveFirst

Do Until tmpRecord.EOF
    ExistValue.Add CStr(Trim(tmpRecord.Fields(strFieldName).Value))
    tmpRecord.MoveNext
    If ExistValue.Count > 100 Then Exit Do
    DoEvents
Loop

Dim lpValue As Long
For lpValue = 0 To ExistValue.Count2 - 1
    If ExistValue(lpValue) <> "" Then lstSelect.AddItem ExistValue(lpValue)
    DoEvents
Next lpValue

Set tmpRecord = Nothing
Set ExistValue = Nothing
Set tmpTable = Nothing

End Sub
Private Sub SaveData()

'-----------------------------------------------------------------------------------------
'保存数据到list
'-----------------------------------------------------------------------------------------

Dim lpointer As Long

If txtField <> "" Then
    For lpointer = 1 To lstMapData.ListItems.Count
        If txtField = lstMapData.ListItems(lpointer).text Then
            If txtData.Visible Then
                lstMapData.ListItems(lpointer).ListSubItems("Attribut").text = Format(txtData.Value)
            Else
                If txtText.Visible Then
                    lstMapData.ListItems(lpointer).ListSubItems("Attribut").text = txtText
                Else
                    lstMapData.ListItems(lpointer).ListSubItems("Attribut").text = txtNumber
                End If
            End If
            
            Exit For
        End If
    
    Next lpointer
    
    If lpointer > lstMapData.ListItems.Count Then
        For lpointer = 1 To lstAppData.ListItems.Count
            If txtField = lstAppData.ListItems(lpointer).text Then
                If txtData.Visible Then
                    lstAppData.ListItems(lpointer).ListSubItems("Attribut").text = Format(txtData.Value)
                Else
                    If txtNumber.Visible Then
                        lstAppData.ListItems(lpointer).ListSubItems("Attribut").text = txtNumber
                    Else
                        lstAppData.ListItems(lpointer).ListSubItems("Attribut").text = txtText
                    End If
                End If
            
                Exit For
            End If
        Next lpointer
    End If
End If


End Sub
Private Sub ActiveBar21_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
Select Case Tool.Name
    Case "cmdMulti"
        
        Call frmMultiRelation.InitForm(CLng(strID), True, Index)
        
        frmMultiRelation.Show vbModal
        
        Call SetPriceFromMultiRelate
        
    Case "cmdSave"
        Call SaveData
        If fnUpdataAppData Then ' And fnUpdataMapData
            AddAllRelation
            Unload Me
        Else
            MsgBox "不能更新数据库，这可能是数据共享造成的，请关闭其他访问此数据库的程序然后再试。", vbExclamation, "注意"
        End If
    Case "cmdResume"
        If MsgBox("数据将恢复初始值，你刚才所作的修改将全部丢失，是否继续？", vbQuestion + vbOKCancel) = vbOK Then
            Call InitForm(Index)
        End If
        
    Case "cmdExit"
        Call Me.Hide
End Select
    
End Sub
Private Sub SetPriceFromMultiRelate()

Dim lpList As Long
Dim dblPrice

For lpList = 1 To lstAppData.ListItems.Count
    
    If lstAppData.ListItems(lpList).text = "监测点地价" Then
        
        dblPrice = frmFormula.GetCurrentPrice(CLng(strID))
        
        If dblPrice >= 0 Then
            lstAppData.ListItems(lpList).ListSubItems("Attribut").text = frmMain.Get2Decimal(CStr(dblPrice))
        End If
    
    End If
Next lpList

End Sub

Private Sub cmbText_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Private Sub cmdPic_Click()
frmImportPic.InitForm (txtText.text)
frmImportPic.Show vbModal
End Sub
Private Sub Form_Unload(Cancel As Integer)
AddAllRelation
End Sub

Private Sub lstAppData_Click()
If Not lstAppData.SelectedItem Is Nothing Then
    Call SaveData
    Call AppDataRefresh
End If

End Sub
Private Sub lstMapData_Click()
If Not lstMapData.SelectedItem Is Nothing Then
    Call SaveData
    Call MapDataRefresh
End If

End Sub
Private Sub lstSelect_Click()
If lstSelect.ListIndex >= 0 Then
    If txtText.Visible Then
        txtText = lstSelect.List(lstSelect.ListIndex)
    Else
        If txtNumber = lstSelect.List(lstSelect.ListIndex) Then
            txtNumber = lstSelect.List(lstSelect.ListIndex)
        Else
            txtData.Value = CDate(lstSelect.List(lstSelect.ListIndex))
        End If
    End If
End If

End Sub
Private Function ImportPicture(strPictureName As String) As String
Dim lSeek As Long
Dim FileName As String
lSeek = InStrRev(strPictureName, "\")
If lSeek > 0 Then
    FileName = Mid(strPictureName, lSeek + 1)
Else
    FileName = strPictureName
End If

If Dir(fnCompletePath("data\宗地图\" & FileName)) <> "" Then
    ImportPicture = ""
Else
    FileCopy strPictureName, fnCompletePath("data\宗地图\" & FileName)
    ImportPicture = FileName
End If


End Function