connectdatabase.bas

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

Attribute VB_Name = "basConnectDatabase"
'---------------------------------------------------------------------------------
'模块名称：连接数据库
'功能名称：
'版　　本：
'开发时间：
'修改时间：
'开发人员：
'----------------------------------------------------------------------------------


Option Explicit

'

Public x1 As Double '外省
Public y1 As Double

Public x2 As Double '未明确
Public y2 As Double

Public x3 As Double '上海2
Public y3 As Double
'
Public p_width As Double '宽
Public p_heigth As Double '高
'
Public pFClass_qj As IFeatureClass
Public pFClass_jd As IFeatureClass
Public pFClass_xinc As IFeatureClass
Public pFClass_xiangc As IFeatureClass
Public pFClass_jwh As IFeatureClass
Public pFClass_DOORNUMPOINT As IFeatureClass



Public Sub Getfeatureclass(pSDEWorkspace As IWorkspace)
    getmaplayer "行政区划", pFClass_qj, pSDEWorkspace
    getmaplayer "街道", pFClass_jd, pSDEWorkspace
    
    getmaplayer "新村", pFClass_xinc, pSDEWorkspace
    getmaplayer "乡村", pFClass_xiangc, pSDEWorkspace
    getmaplayer "居委会", pFClass_jwh, pSDEWorkspace
    getmaplayer "DOORNUMPOINT", pFClass_DOORNUMPOINT, pSDEWorkspace
End Sub



Public 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




Public Sub GetErrorPointXY()
On Error GoTo e
    
    
    Dim pQuery As IQueryFilter
    Dim pFCursor As IFeatureCursor
    Dim pF As IFeature
    Dim minx As Double
    Dim miny As Double
    Dim maxx As Double
    Dim maxy As Double
    
    Set pQuery = New QueryFilter
    pQuery.WhereClause = "编号=20"
    Set pFCursor = pFClass_qj.Search(pQuery, True)
    Set pF = pFCursor.NextFeature
    
    If Not pF Is Nothing Then

        minx = pF.Shape.Envelope.XMin
        miny = pF.Shape.Envelope.YMin
        maxx = pF.Shape.Envelope.XMax
        maxy = pF.Shape.Envelope.YMax
        p_width = (maxx - minx) / 3
        p_heigth = maxy - miny
        
        x1 = minx
        x2 = minx + p_width
        x3 = minx + p_width * 2
        
        y1 = miny
        y2 = miny
        y3 = miny
        
    End If
e:
End Sub

Function GetProfile(strFileName As String, strSection As String, strname As String) As String
  Dim strCharB, strCharA
  Dim strSectionTemp As String
  Dim strNameTemp As String
  Dim strreturn As String
  
   strSectionTemp = ""
   strNameTemp = ""
   strreturn = ""
   On Error GoTo ErrSrchSection
   Open strFileName For Input As #1
     Do While Not EOF(1)
        strCharA = Input(1, #1)
        If strCharA = "[" Then
           Do While Not EOF(1)
             strCharB = Input(1, #1)
             If strCharB = "]" Then Exit Do
             strSectionTemp = strSectionTemp & strCharB
           Loop
        End If
        If strSectionTemp = strSection Then
          strCharA = Input(2, #1)
          Exit Do
        Else
          strSectionTemp = ""
        End If
     Loop
 On Error GoTo ErrReadFile
  
aa:
    strNameTemp = ""
    Do While Not EOF(1)
      strCharA = Input(1, #1)
      If strCharA <> "=" Then
        strNameTemp = strNameTemp & strCharA  '得到名称
      Else
        Exit Do
      End If
    Loop
        If strNameTemp = strname Then
       Line Input #1, strreturn  '如果找到与它匹配的字段名，就返回得到的值
    Else
       Line Input #1, strreturn  '如果未找到与它匹配的字段名，就继续找
       GoTo aa
    End If
    Close #1
    GetProfile = strreturn
    Exit Function
ErrReadFile:
  
ErrSrchSection:
     MsgBox "节点未找到", vbOKOnly
     GetProfile = ""
     Close #1
End Function












Public Function ReturnDataPath(dataDir As String) As String
  Dim sPath As String
  Dim iLastPos As Integer
  sPath = App.Path
  iLastPos = InStrL(sPath, "\")
  ReturnDataPath = Left(sPath, iLastPos) + "数据\" + dataDir
End Function


'
Public Function InStrL(inString As String, srchString As String) As Integer
  Dim iLastPos As Integer   'Set to 0 on initialization
  
  ' Check srchString -- a 0-length string will match every time
  If Len(srchString) Then
    ' Set iLastPos to the last matching position
    Dim iCurPos As Integer
    Do
      iLastPos = iCurPos
      iCurPos = InStr(iCurPos + 1, inString, srchString, vbTextCompare)
    Loop Until iCurPos = 0
  End If
  
  InStrL = iLastPos
End Function



Public Function OpenSDEWorkspace(ByVal Server As String, ByRef instance As String, ByVal Database As String, _
            ByVal user As String, ByVal password As String, ByVal version As String) As IWorkspace
            
On Error GoTo eh
    
    Dim pPropSet As IPropertySet
    Dim pSdeFact As IWorkspaceFactory

    Set pPropSet = New PropertySet
    With pPropSet
        .SetProperty "SERVER", Server
        .SetProperty "INSTANCE", instance
        .SetProperty "DATABASE", Database
        .SetProperty "USER", user
        .SetProperty "PASSWORD", password
        .SetProperty "VERSION", version
    End With

    Set pSdeFact = New SdeWorkspaceFactory
    Set OpenSDEWorkspace = pSdeFact.Open(pPropSet, 0)
    Exit Function
    
eh:
    MsgBox "通过ArcSDE引擎连接数据库失败！"
    End

End Function
Public Function openSQLServer(ByVal username As String, ByVal password As String, ByVal Database As String, ByVal Server As String) As ADODB.Connection
On Error GoTo eh
    Dim strConnection As String
    Set openSQLServer = New ADODB.Connection
    
    strConnection = "Provider=SQLOLEDB.1;" & _
            "Persist Security Info=False;" & _
            "User ID=" & username & _
            ";Initial Catalog = " & Database & _
            ";PWD=" & password & _
            ";Data Source=" & Server
            
   
    openSQLServer.Open strConnection
    Exit Function
    
eh:
    MsgBox "通过ADO连接数据库失败！"
    End

End Function
Public Function openoracleServer(ByVal username As String, ByVal password As String, ByVal Server As String) As ADODB.Connection
On Error GoTo eh
    Dim strConnection As String
    Set openoracleServer = New ADODB.Connection
    
    strConnection = "Provider=OraOLEDB.Oracle.1;User ID=" + username + ";Data Source=" + Server + ";password=" + password + ";Persist Security Info=true"
   ' strconn = "Provider=MSDAORA.1;Data Source=xfb;User ID=test;Password=test;Persist Security Info=True"
    openoracleServer.Open strConnection
    Exit Function
    
eh:
    MsgBox "通过ADO连接数据库失败！"
    End

End Function