datafilter.frm

给一个房地产公司开发的数据库过滤程序ADO

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "数据库过滤程序"
   ClientHeight    =   3570
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6525
   LinkTopic       =   "Form1"
   ScaleHeight     =   3570
   ScaleWidth      =   6525
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "打开数据库"
      Height          =   495
      Left            =   2640
      TabIndex        =   3
      Top             =   240
      Width           =   2655
   End
   Begin VB.CommandButton Command2 
      Caption         =   "过滤数据(只有一个号码相同既算相同)"
      Default         =   -1  'True
      Height          =   495
      Left            =   2640
      TabIndex        =   0
      Top             =   1080
      Width           =   2655
   End
   Begin MSComDlg.CommonDialog dlgCommonDialog 
      Left            =   1920
      Top             =   840
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label Label3 
      Caption         =   "李树永 QQ:8231763,手机:[phone]"
      Height          =   255
      Left            =   960
      TabIndex        =   2
      Top             =   3240
      Width           =   5055
   End
   Begin VB.Label Label2 
      Height          =   615
      Left            =   1080
      TabIndex        =   1
      Top             =   1800
      Width           =   4335
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
   Option Explicit
   Dim sFile As String
   
Private Sub Command1_Click()
   
    With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.mdb)|*.mdb"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With

End Sub

Private Sub Command2_Click()
  Dim strLong As String
    
     Label2.Caption = "正在进行转化"
     Dim connPub  As New ADODB.Connection
     Dim strConn As String
     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sFile & ";Persist Security Info=False"
    connPub.Open strConn
    If connPub.State <> adStateOpen Then
        MsgBox "数据打开失败,请检查输入文件名是否正确"
        Label2.Caption = ""
        Set connPub = Nothing
        Exit Sub
    End If
    Dim rstBoult As New ADODB.Recordset
    Dim n As Long, i As Long, j As Long
    Dim iTelnum As Long
    iTelnum = 0
    n = 10000
    Dim arBoult() As String
    ReDim arBoult(10000) As String
    rstBoult.Open "select 联系电话 from 筛子", connPub
    Do Until rstBoult.EOF
        If Not IsNull(rstBoult!联系电话) Then
            strLong = Trim(rstBoult!联系电话)
            i = InStr(strLong, " ")
            Do Until i = 0
                arBoult(iTelnum) = Left(strLong, i - 1)
                iTelnum = iTelnum + 1
                If iTelnum > (n - 10) Then
                    n = n + 1000
                    ReDim Preserve arBoult(n) As String
                End If
                
                
                strLong = Mid(strLong, i)
                strLong = Trim(strLong)
                i = InStr(strLong, " ")
            Loop
                
                arBoult(iTelnum) = strLong
                iTelnum = iTelnum + 1

                If iTelnum > (n - 10) Then
                    n = n + 1000
                    ReDim Preserve arBoult(n) As String
                End If

            
        End If
        rstBoult.MoveNext
    Loop
    '已提取完筛子的代码,所以关闭记录集,节省内存
    rstBoult.Close
    Set rstBoult = Nothing
    '打开要检查的表
    Dim rstCheck As New ADODB.Recordset
    rstCheck.Open "select * from 要检查的表", connPub
    Dim rstSame As New ADODB.Recordset
    Dim rstDiff As New ADODB.Recordset
    rstSame.Open "select * from 同号表", connPub, adOpenDynamic, adLockOptimistic
    rstDiff.Open "select * from 不同号表", connPub, adOpenDynamic, adLockOptimistic
   
    Dim arSmall(10) As String
    Dim iSmall As Long
  
    Do Until rstCheck.EOF
        If Not IsNull(rstCheck!联系电话) Then
            strLong = rstCheck!联系电话
            ''''''''''''
            '将要检查表的一个记录中的多个电话号码存入一个数组,并记录个数
                        i = InStr(strLong, " ")
              iSmall = 0
            Do Until i = 0
                arSmall(iSmall) = Left(strLong, i - 1)
                iSmall = iSmall + 1
                strLong = Mid(strLong, i)
                strLong = Trim(strLong)
                i = InStr(strLong, " ")
            Loop
                arSmall(iSmall) = strLong
                iSmall = iSmall + 1

            ''''''''''
            '分查找在arsmall中的号码是否与大数组中的号码相同
            For i = 0 To iSmall - 1
                '
                For j = 0 To iTelnum - 1
                    If arSmall(i) = arBoult(j) Then
                        '存储到相同表
                        rstSame.AddNew
                        rstSame!记录性质 = rstCheck!记录性质
                        rstSame!物业名称 = rstCheck!物业名称
                        rstSame!物业地址 = rstCheck!物业地址
                        rstSame!建筑面积 = rstCheck!建筑面积
                        rstSame!所在楼层 = rstCheck!所在楼层
                        rstSame!楼层总数 = rstCheck!楼层总数
                        rstSame!联系电话 = rstCheck!联系电话
                        rstSame!手机 = rstCheck!手机
                        rstSame!发布日期 = rstCheck!发布日期
                        rstSame!交易价格 = rstCheck!交易价格
                        rstSame!所在区 = rstCheck!所在区
                        rstSame!联系人 = rstCheck!联系人
                        rstSame!房型 = rstCheck!房型
                        rstSame!电子邮件 = rstCheck!电子邮件
                        
                        rstSame.Update
                        GoTo lisypro
                    End If
                    
                Next j
            Next i
        End If
        '存储到不相同表
                        rstDiff.AddNew
                        rstDiff!记录性质 = rstCheck!记录性质
                        rstDiff!物业名称 = rstCheck!物业名称
                        rstDiff!物业地址 = rstCheck!物业地址
                        rstDiff!建筑面积 = rstCheck!建筑面积
                        rstDiff!所在楼层 = rstCheck!所在楼层
                        rstDiff!楼层总数 = rstCheck!楼层总数
                        rstDiff!联系电话 = rstCheck!联系电话
                        rstDiff!手机 = rstCheck!手机
                        rstDiff!发布日期 = rstCheck!发布日期
                        rstDiff!交易价格 = rstCheck!交易价格
                        rstDiff!所在区 = rstCheck!所在区
                        rstDiff!联系人 = rstCheck!联系人
                        rstDiff!房型 = rstCheck!房型
                        rstDiff!电子邮件 = rstCheck!电子邮件
                        
                        rstDiff.Update

        
        '
lisypro:
        rstCheck.MoveNext
    Loop
    
    
    
    '''
    Label2.Caption = "转化完毕."
End Sub