form1.frm

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

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "定位"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command1 
      Caption         =   "定位"
      Height          =   615
      Left            =   1080
      TabIndex        =   0
      Top             =   960
      Width           =   2295
   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 Sub Command1_Click()

Dim doend As Boolean
doend = True

Do Until Not doend

    doend = dw
Loop

MsgBox "定位完成！！！", vbInformatiossn, "系统提示："
    
    
    
End Sub


Private Function dw() As Boolean
    Dim sqlstr As String

    Dim yearnumber As Integer
    
    Dim layername As String
    Dim pPoint As IPoint
    
    
    Dim m_SqlRecord As New Recordset '
    Dim locate As New Recordset '
    
    Dim cmd As New ADODB.Command
    Dim para1 As New ADODB.Parameter
    Dim para2 As New ADODB.Parameter
    Dim id As String
    Dim str As String
    Dim res  As Integer
    Dim valueProgressBar As Long
    
    dw = False
    
    
    
    Dim pSDEWorkspace As IWorkspace
    Dim pSQLServer As New ADODB.Connection
    
    
    Set pSDEWorkspace = getsdeWorkspace
    Set pSQLServer = getConnection
    
    
    
    Getfeatureclass pSDEWorkspace
    GetErrorPointXY
    
    

    m_SqlRecord.MaxRecords = 5000
    m_SqlRecord.Open "select * from tbxAppeal  where sfdw='未定位' and not (appealDate is null) order by appealcode ", pSQLServer, adOpenDynamic, adLockOptimistic
    Do Until m_SqlRecord.EOF
        DoEvents
On Error GoTo errordo '存储过程 有错
        Set cmd = New ADODB.Command
        Set cmd.ActiveConnection = pSQLServer
        cmd.CommandText = "searchLocationStr2"
        cmd.CommandType = adCmdStoredProc ' &H4'adCmdStoredProc
        cmd.Parameters.Append cmd.CreateParameter("id", adBSTR, adParamInput, 200, m_SqlRecord.Fields("appealcode").Value)
        cmd.Parameters.Append cmd.CreateParameter("str", adBSTR, adParamInput, 200, m_SqlRecord.Fields("eventoccuraddress").Value)
        cmd.Parameters.Append cmd.CreateParameter("res", adInteger, adParamOutput, 10, 0)
        cmd.Execute
        res = cmd("res")
        cmd.Cancel

        wz = ""

        If res <> 0 Then
            If Not get_point_location(m_SqlRecord.Fields("appealcode").Value, m_SqlRecord.Fields("eventoccuraddress").Value, pPoint, pSQLServer, pSDEWorkspace) Then
              
                If IsNull(m_SqlRecord.Fields("eventoccuraddress").Value) Then
                   wz = getwz("")
                Else
                   wz = getwz(m_SqlRecord.Fields("eventoccuraddress").Value)
                End If
                Set pPoint = GetErrorPoint
                dwfunction = "未明确"
            End If
        Else
errordo:
            If IsNull(m_SqlRecord.Fields("eventoccuraddress").Value) Then
                 wz = getwz("")
            Else
                 wz = getwz(m_SqlRecord.Fields("eventoccuraddress").Value)
            End If
            Set pPoint = GetErrorPoint
            dwfunction = "未明确"
        End If


        layername = ""
        yearnumber = 0
On Error GoTo datacheck
      '  On Error Resume Next
        If Not IsNull(m_SqlRecord.Fields("appealDate").Value) Then '
           If IsDate(m_SqlRecord.Fields("appealDate").Value) Then
              yearnumber = Year(m_SqlRecord.Fields("appealDate").Value)
              If yearnumber <= 2015 And yearnumber >= 1996 Then
                 '算图层名
                 layername = getlayername(yearnumber)
              End If
           End If
        End If
datacheck:
         If layername = "" Then layername = getlayername(2000)
        If layername <> "" Then
            If AddFeature("所有信访事件", m_SqlRecord.Fields("appealcode").Value, m_SqlRecord, pPoint, layername, pSQLServer, pSDEWorkspace) Then
               m_SqlRecord.Fields("sfdw").Value = "已定位"
               m_SqlRecord.Update
               dw = True
            End If '全部图层
        End If
        m_SqlRecord.MoveNext
    Loop
    On Error GoTo 0
    m_SqlRecord.Close
    
    
    Set pFClass_qj = Nothing
    Set pFClass_jd = Nothing
    Set pFClass_xinc = Nothing
    Set pFClass_xiangc = Nothing
    Set pFClass_jwh = Nothing
    Set pFClass_DOORNUMPOINT = Nothing
        
    
    Exit Function
    
e:
    MsgBox "定位失败！！！" & m_SqlRecord.Fields("appealcode").Value, vbCritical, "系统提示："
    
    
    
    
End Function



Private Function GetErrorPoint() As IPoint

    Dim pPoint As IPoint
    Dim x As Double
    Dim y As Double
    
    
    Randomize
    If wz = "外省" Then
        x = x1 + Rnd() * p_width
    ElseIf wz = "未明确" Then
        x = x2 + Rnd() * p_width
    ElseIf wz = "上海" Then
        x = x3 + Rnd() * p_width
    End If
    Randomize
    y = y1 + Rnd() * p_heigth
    
    
    Set pPoint = New Point
    pPoint.PutCoords x, y

    Set GetErrorPoint = pPoint



End Function


Private Function get_point_location(id As String, ByVal address As String, pPoint As IPoint, pSQLServer As ADODB.Connection, pSDEWorkspace As IWorkspace) As Boolean

    Dim locate As New Recordset '
    Dim pQuery As IQueryFilter
    Dim pfeature As IFeature
    Dim pFCursor As IFeatureCursor
    Dim wherestr As String
    
    wherestr = ""
    locate.Open "select * from bap_address  where a6='" + id + "'  ", pSQLServer, adOpenDynamic, adLockOptimistic
    If Not locate.EOF Then

       Dim fclass As IFeatureClass
       Set fclass = getmapname(locate.Fields("a1").Value)

       Set pQuery = New QueryFilter
       If dwfunction = "DOORNUMPOINT" Then
          If IsNull(locate!a2) Then
             get_point_location = False
             Exit Function
          End If
          If Not IsNull(locate!a3) Then
             If IsNumeric(locate!a3) Then
                wherestr = "路名='" + locate!a2 + "' and 门牌号码=" + CStr(locate!a3) + ""
             Else
                If Not IsNull(locate!a4) Then
                   If IsNumeric(locate!a4) Then
                      wherestr = "路名='" + locate!a2 + "' and 门牌号码=" + CStr(locate!a4) + ""
                   End If
                End If
             End If
          Else
             If Not IsNull(locate!a4) Then
                If IsNumeric(locate!a4) Then
                   wherestr = "路名='" + locate!a2 + "' and 门牌号码=" + CStr(locate!a4) + ""
                End If
             End If
          End If
       Else
          wherestr = "名称='" + locate!a2 + "'"
       End If
       If wherestr = "" Then
          get_point_location = False
          Exit Function
       End If
       pQuery.WhereClause = wherestr
       Set pFCursor = fclass.Search(pQuery, True)
       Set pfeature = New Feature
       Set pfeature = pFCursor.NextFeature
                 
       If pfeature Is Nothing Then
          get_point_location = False
          Exit Function
       Else
          Dim features As Collection
          Dim pElement As IElement
          Dim parea As IArea
          
          Set features = New Collection
         
          Set pElement = New MarkerElement
          
         If Not pfeature Is Nothing Then
            Set pElement = New MarkerElement
            If fclass.ShapeType = 4 Then
                 Set parea = pfeature.Shape
                 pElement.Geometry = parea.Centroid
            Else
                 pElement.Geometry = pfeature.Shape
            End If

            
         End If

       End If
       
       Set pPoint = pElement.Geometry
       wz = "上海"
       get_point_location = True
       Exit Function

    Else
       get_point_location = False
       Exit Function
    End If
    

End Function





Private Function getmapname(id As Integer) As IFeatureClass


Dim layername As String

If id = 1 Then
    Set getmapname = pFClass_qj
    layername = "行政区划"
ElseIf id = 2 Then
    Set getmapname = pFClass_jd
    layername = "街道"
ElseIf id = 3 Then
    Set getmapname = pFClass_xinc
    layername = "新村"
ElseIf id = 4 Then
    Set getmapname = pFClass_xiangc
    layername = "乡村"
ElseIf id = 5 Then
    Set getmapname = pFClass_jwh
    layername = "居委会"
ElseIf id = 6 Then
    Set getmapname = pFClass_DOORNUMPOINT '"地址"
    layername = "DOORNUMPOINT" '"地址"
Else
    Set getmapname = Nothing
    layername = ""
End If

dwfunction = layername


End Function







Private Function AddFeature(FName As String, id As String, RsFind1 As Recordset, pPoint As IPoint, layername As String, pSQLServer As ADODB.Connection, pSDEWorkspace As IWorkspace) As Boolean   '加点
'On Error GoTo e
    AddFeature = False

    Dim pR As New ADODB.Recordset

    Dim pFClass As IFeatureClass
    Dim pFClass1 As IFeatureClass
    
    Dim pFCursor As IFeatureCursor
    Dim pFCursor1 As IFeatureCursor
    
    Dim pFBuffer As IFeatureBuffer
    Dim pFBuffer1 As IFeatureBuffer
    
    Dim pfeature As IFeature
    Dim pfeature1 As IFeature
    
    Dim stylename As String '分类
    Dim style1 As String '分类1
    Dim style2 As String '分类2
    Dim sort As String '专项
    Dim threateningId As Integer '扬言
    
    
    Dim style1_name As String
    Dim style2_name As String
    Dim sort_name As String
    Dim threatening_name As String
    
    '
    Dim renshu As Integer
    Dim xfgm As String
    
    Dim xfxs As String

    Dim address As String
    

    If Not getmaplayer(FName, pFClass, pSDEWorkspace) Then
        Exit Function
    End If
    If Not getmaplayer(layername, pFClass1, pSDEWorkspace) Then
        Exit Function
    End If


    If Not RsFind1 Is Nothing Then '
        If IsNull(RsFind1.Fields("appealCategoryCode").Value) Then
            stylename = "0"
            style1 = "0"
            style2 = "0"
        Else
            stylename = RsFind1.Fields("appealCategoryCode").Value
            
            style1 = Mid(stylename, 1, 1)
            style2 = Mid(stylename, 2, 2)
        End If
        
        
        If IsNull(RsFind1.Fields("appealSortId").Value) Then
            sort = "0"
        Else
            sort = CStr(RsFind1.Fields("appealSortId").Value)
        End If
       ' sort = CStr(RsFind1.fields("appealSortId").value)
        If IsNull(RsFind1.Fields("threateningId").Value) Then
            threateningId = 0
        Else
            threateningId = RsFind1.Fields("threateningId").Value
        End If