form1.frm

此为在图像处理中的定位程序,其中在图像上的输入即坐标获取方面有比较好的优势

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "定位"
   ClientHeight    =   7905
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8340
   LinkTopic       =   "Form1"
   ScaleHeight     =   7905
   ScaleWidth      =   8340
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command6 
      Caption         =   "修改居委会名称"
      Height          =   975
      Left            =   4800
      TabIndex        =   6
      Top             =   1680
      Width           =   3015
   End
   Begin VB.CommandButton Command5 
      Caption         =   "街道的名称变换"
      Height          =   855
      Left            =   960
      TabIndex        =   5
      Top             =   5640
      Width           =   2895
   End
   Begin VB.CommandButton Command4 
      Caption         =   "乡村: 街道乡 、 区界"
      Height          =   975
      Left            =   960
      TabIndex        =   4
      Top             =   4200
      Width           =   2895
   End
   Begin VB.TextBox Text1 
      Height          =   375
      Left            =   1800
      TabIndex        =   3
      Text            =   "Text1"
      Top             =   6840
      Width           =   1335
   End
   Begin VB.CommandButton Command3 
      Caption         =   "新村: 街道乡 、 区界"
      Height          =   855
      Left            =   960
      TabIndex        =   2
      Top             =   2880
      Width           =   2775
   End
   Begin VB.CommandButton Command1 
      Caption         =   "居委会加：街道乡 、 区界"
      Height          =   855
      Left            =   960
      TabIndex        =   1
      Top             =   1800
      Width           =   2775
   End
   Begin VB.CommandButton Command2 
      Caption         =   "街道加：区界"
      Height          =   855
      Left            =   960
      TabIndex        =   0
      Top             =   600
      Width           =   2775
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Public wz As String
Public dwfunction As String




Private Function getmaplayer(ByVal mapname As String, pFClass As IFeatureClass, pSDEWorkspace As IWorkspace) As Boolean
On Error GoTo e
    Dim pFWorkspace As IFeatureWorkspace
    Set pFWorkspace = pSDEWorkspace
    Set pFClass = pFWorkspace.OpenFeatureClass(mapname)
    getmaplayer = True
    Exit Function
e:
    Set pFClass = Nothing
    getmaplayer = False
End Function




Private Function get_jd(pPoint As IPoint, pSDEWorkspace As IWorkspace) As String
On Error GoTo e
    
    Dim pSFilter As ISpatialFilter
    Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Set pSFilter = New SpatialFilter
    Set pSFilter.Geometry = pPoint
    'pSFilter.GeometryField = "shape"
    pSFilter.SpatialRel = esriSpatialRelWithin

    getmaplayer "街道", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(pSFilter, True)
       
    Dim pF As IFeature
    Set pF = pFCursor.NextFeature
    If pF Is Nothing Then
       get_jd = "未明确"
       Exit Function
    End If
    get_jd = pF.Value(pFClass.FindField("名称"))

e:


End Function










Private Function get_qj(pPoint As IPoint, pSDEWorkspace As IWorkspace) As String
On Error GoTo e
    
    Dim pSFilter As ISpatialFilter
    Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Set pSFilter = New SpatialFilter
    Set pSFilter.Geometry = pPoint
    'pSFilter.GeometryField = "shape"
    pSFilter.SpatialRel = esriSpatialRelWithin
'    Dim pFW As IFeatureWorkspace
'    Set pFW = pSDEWorkspace
'    Set pFClass = pFW.OpenFeatureClass("行政区划")
    getmaplayer "行政区划", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(pSFilter, True)
       
    Dim pF As IFeature
    Set pF = pFCursor.NextFeature
    If pF Is Nothing Then
       get_qj = "未明确"
       Exit Function
    End If
    get_qj = pF.Value(pFClass.FindField("名称"))

e:


End Function




Public Function getsdeWorkspace() As IWorkspace 'sde

    Dim strServer As String
    Dim strInstance As String
    Dim strDatabase As String
    Dim strUser As String
    Dim strPassword As String
    Dim strVersion As String
    Dim strDataPath As String
    Dim strPath As String
    
    strPath = App.Path & "\config.ini"
     strServer = GetProfile(strPath, "sde", "ServerName")
    strInstance = GetProfile(strPath, "sde", "instance")
    strDatabase = GetProfile(strPath, "sde", "DatabaseName")
    strUser = GetProfile(strPath, "sde", "UserName")
    strPassword = GetProfile(strPath, "sde", "Password")
    strVersion = "SDE.DEFAULT"
    
    
    Set getsdeWorkspace = OpenSDEWorkspace(strServer, strInstance, strDatabase, strUser, strPassword, strVersion)
    
    
End Function

Public Function getConnection() As ADODB.Connection 'sde
  Dim ServerName As String
    Dim password As String
    Dim DatabaseName As String
    Dim username As String
    Dim strPath As String
    
    strPath = App.Path & "\config.ini"
    ServerName = GetProfile(strPath, "database", "ServerName")
    DatabaseName = GetProfile(strPath, "database", "DatabaseName")
    username = GetProfile(strPath, "database", "UserName")
    password = GetProfile(strPath, "database", "Password")
    
    
    Set getConnection = openoracleServer(username, password, ServerName)
    
    
    
    
End Function







Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub


Private Function getwz(address As String) As String

If InStr(address, "上海市") Then
    getwz = "上海"
    Exit Function
End If

If Not InStr(address, "上海") Then
    If InStr(address, "省") Then
        getwz = "外省"
        Exit Function
    End If
End If

getwz = "未明确"

End Function


Private Sub Command1_Click()


  Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim pPoint As IPoint
    Dim parea As IArea
    Dim qj As String
    Dim jd As String
    Dim i  As Integer
    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "居委会", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    i = 0
    Do Until pF Is Nothing
        DoEvents
        i = i + 1
        Text1.Text = CStr(i)
        Set pPoint = pF.ShapeCopy
        qj = get_qj(pPoint, pSDEWorkspace)
        jd = get_jd(pPoint, pSDEWorkspace)
        pF.Value(pFClass.FindField("区界")) = qj
        pF.Value(pFClass.FindField("街道乡")) = jd
        pF.Store
        Set pF = pFCursor.NextFeature
    Loop
    MsgBox "完成！！！！"
    
End Sub



Private Sub Command2_Click()
    
    Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim pPoint As IPoint
    Dim parea As IArea
    Dim qj As String
    Dim i  As Integer

    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "街道", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    i = 0
    Do Until pF Is Nothing
        Set parea = pF.ShapeCopy
        Set pPoint = parea.Centroid
        i = i + 1
        Text1.Text = CStr(i)
        qj = get_qj(pPoint, pSDEWorkspace)
        pF.Value(pFClass.FindField("区界")) = qj
        pF.Store
        Set pF = pFCursor.NextFeature
    Loop
    MsgBox "完成！！！！"
End Sub





Private Sub Command3_Click()
 Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim pPoint As IPoint
    Dim parea As IArea
    Dim qj As String
    Dim jd As String
    Dim i  As Integer
    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "新村", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    i = 0
    Do Until pF Is Nothing
        DoEvents
        i = i + 1
        Text1.Text = CStr(i)
        Set pPoint = pF.ShapeCopy
        qj = get_qj(pPoint, pSDEWorkspace)
        jd = get_jd(pPoint, pSDEWorkspace)
        pF.Value(pFClass.FindField("区界")) = qj
        pF.Value(pFClass.FindField("街道乡")) = jd
        pF.Store
        Set pF = pFCursor.NextFeature
    Loop
    MsgBox "完成！！！！"
End Sub


Private Sub Command4_Click()
 Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim pPoint As IPoint
    Dim parea As IArea
    Dim qj As String
    Dim jd As String
    Dim i  As Integer
    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "乡村", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    i = 0
    Do Until pF Is Nothing
        DoEvents
        i = i + 1
        Text1.Text = CStr(i)
        Set pPoint = pF.ShapeCopy
        qj = get_qj(pPoint, pSDEWorkspace)
        jd = get_jd(pPoint, pSDEWorkspace)
        pF.Value(pFClass.FindField("区界")) = qj
        pF.Value(pFClass.FindField("街道乡")) = jd
        pF.Store
        Set pF = pFCursor.NextFeature
    Loop
    MsgBox "完成！！！！"
End Sub




Private Sub Command5_Click()
 Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim qjcollect As New Collection
    Dim i  As Integer
    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "行政区划", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    i = 0
    Do Until pF Is Nothing
        DoEvents
        qjcollect.Add pF.Value(pFClass.FindField("名称"))
        Set pF = pFCursor.NextFeature
    Loop
    
    getmaplayer "街道", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    Do Until pF Is Nothing
        DoEvents

        For i = 1 To qjcollect.Count
            If InStr(pF.Value(pFClass.FindField("名称")), qjcollect.Item(i)) = 1 Then
                pF.Value(pFClass.FindField("名称")) = Mid(pF.Value(pFClass.FindField("名称")), Len(qjcollect.Item(i)) + 1)
                Exit For
            End If
        Next i
       
        pF.Store
        Set pF = pFCursor.NextFeature
    Loop
    
    
    
    
    
    MsgBox "完成！！！！"
End Sub








Private Sub Command6_Click()


Dim ptopop As ITopologicalOperator


 Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim qjcollect As New Collection
    Dim i  As Integer
    Dim pSDEWorkspace As IWorkspace
    Set pSDEWorkspace = getsdeWorkspace


    getmaplayer "居委会", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Search(Nothing, True)
    Set pF = pFCursor.NextFeature
    Do Until pF Is Nothing
        DoEvents
        
        
        'i = InStr(pF.Value(pFClass.FindField("名称")), "镇")
        'i = InStr(pF.Value(pFClass.FindField("名称")), "乡")
        i = InStr(pF.Value(pFClass.FindField("名称")), "村民委员会")
        
       ' Debug.Print pF.Value(pFClass.FindField("名称"))
        
        If i <> 0 Then
        
'            Debug.Print pF.Value(pFClass.FindField("名称"))
'            Debug.Print Mid(pF.Value(pFClass.FindField("名称")), 1, Len(pF.Value(pFClass.FindField("名称"))) - 5)
'            findzheng Mid(pF.Value(pFClass.FindField("名称")), 1, Len(pF.Value(pFClass.FindField("名称"))) - 5), pF.ShapeCopy, pSDEWorkspace
'
'
            
            pF.Value(pFClass.FindField("名称")) = Mid(pF.Value(pFClass.FindField("名称")), Len(pF.Value(pFClass.FindField("名称"))) - 4)
            'pF.Value(pFClass.FindField("街道乡")) = Mid(pF.Value(pFClass.FindField("名称")), 1, 4)
            pF.Store
           
           
           
            'If i = 1 Then
           ' ElseIf i = 2 Then
            'ElseIf i = 3 Then
'               Debug.Print Mid(pF.Value(pFClass.FindField("名称")), 1, 3)
'              pF.Value(pFClass.FindField("名称")) = Mid(pF.Value(pFClass.FindField("名称")), 4)
'              pF.Value(pFClass.FindField("街道乡")) = Mid(pF.Value(pFClass.FindField("名称")), 1, 3)
'              pF.Store
            'ElseIf i = 4 Then
            '  Debug.Print Mid(pF.Value(pFClass.FindField("名称")), 1, 4)
'              pF.Value(pFClass.FindField("名称")) = Mid(pF.Value(pFClass.FindField("名称")), 5)
'              pF.Value(pFClass.FindField("街道乡")) = Mid(pF.Value(pFClass.FindField("名称")), 1, 4)
'              pF.Store
            'Else
            'End If
        End If
        Set pF = pFCursor.NextFeature
    Loop
    
    
    
    
    
    MsgBox "完成！！！！"
End Sub




Private Sub findzheng(Name As String, pGeom As IGeometry, pSDEWorkspace As IWorkspace)


 Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pfilter As IQueryFilter
    Dim pF As IFeature
    Dim pPoint As IPoint

   


    getmaplayer "乡村", pFClass, pSDEWorkspace
    
    Set pfilter = New QueryFilter
    pfilter.WhereClause = "名称='" & Name & "'"
    
    Set pFCursor = pFClass.Search(pfilter, True)
    Set pF = pFCursor.NextFeature
    If Not pF Is Nothing Then Exit Sub
    Debug.Print "-------------------"
   ' Debug.Print Name
   ' Addjd Name, pGeom, pSDEWorkspace
    
    
 '   MsgBox "完成！！！！"


End Sub










Private Sub Addjd(Name As String, pGeom As IGeometry, pSDEWorkspace As IWorkspace)  '加点
'On Error GoTo e

Dim ptopop As ITopologicalOperator

    Dim pFClass As IFeatureClass
    Dim pFCursor As IFeatureCursor
    Dim pFBuffer As IFeatureBuffer
    Dim pfeature As IFeature
    getmaplayer "乡村", pFClass, pSDEWorkspace
    Set pFCursor = pFClass.Insert(True)
    Set pFBuffer = pFClass.CreateFeatureBuffer
    
    
'    Set ptopop = pGeom
'    Set pFBuffer.Shape = ptopop.Buffer(20)
'
    Set pFBuffer.Shape = pGeom
    
    Set pfeature = pFBuffer

    pfeature.Value(pFClass.FindField("名称")) = Name

    pFCursor.InsertFeature pFBuffer




End Sub