form1.frm

用VB实现把Oracle与Sql SERver 2000实时同步

   Do Until rst.EOF
       strRtn = strRtn & "    " & rst.Fields("COLUMN_NAME") & " "
       tmpStr = rst.Fields("DATA_TYPE")
       strType = tmpStr
       Select Case tmpStr
           Case "CHAR"
                 strType = "CHAR"
           Case "VARCHAR2"
                 If Val(rst.Fields("DATA_LENGTH")) < 8000 Then
                    strType = "VARCHAR"
                 Else
                    strType = "TEXT"
                 End If
           Case "LONG"
                 If Val(rst.Fields("DATA_LENGTH")) < 8000 Then
                    strType = "VARCHAR"
                 Else
                    strType = "TEXT"
                 End If
           Case "RAW"
                 If Val(rst.Fields("DATA_LENGTH")) < 8000 Then
                    strType = "VARBINARY"
                 Else
                    strType = "IMAGE"
                 End If
           Case "LONG RAW"
                 If Val(rst.Fields("DATA_LENGTH")) < 8000 Then
                    strType = "VARBINARY"
                 Else
                    strType = "IMAGE"
                 End If
           Case "NUMBER"
                 strType = "DECIMAL"
           Case "DATE"
                 strType = "DATETIME"
       End Select
      strRtn = strRtn & strType
      If strType <> "DATETIME" Then
         strRtn = strRtn & "("
         If Not IsNull(rst.Fields("DATA_PRECISION")) Then
            strRtn = strRtn & rst.Fields("DATA_PRECISION") & "," & rst.Fields("DATA_SCALE")
         Else
            strRtn = strRtn & rst.Fields("DATA_LENGTH")
         End If
         strRtn = strRtn & ")"
      End If
      rst.MoveNext
      If Not rst.EOF Then
         strRtn = strRtn & "," & vbCrLf
      End If
   Loop
   strRtn = strRtn & ");" & vbCrLf
   SQLCreateTable = strRtn
End Function

'------------------------------------------------------------------------------------------------------
'   Create DTS Task for the TableName
'------------------------------------------------------------------------------------------------------


Public Sub Task_Sub(ByVal oPackage As Object, Owner As String, TableName As String, TaskNo As Integer)

    Dim oTask As DTS.Task
    Dim oLookup As DTS.Lookup

    Dim oCustomTask1 As DTS.DataPumpTask2
    Set oTask = oPackage.Tasks.New("DTSDataPumpTask")
    oTask.Name = "DTSTask_DTSDataPumpTask_" & TaskNo
    Set oCustomTask1 = oTask.CustomTask

    oCustomTask1.Name = "DTSTask_DTSDataPumpTask_" & TaskNo
    oCustomTask1.Description = "DTS Task " & TaskNo
    oCustomTask1.SourceConnectionID = 1
    oCustomTask1.SourceSQLStatement = "select * from " & Owner & "." & TableName
    oCustomTask1.DestinationConnectionID = 2
    oCustomTask1.DestinationObjectName = TableName
    oCustomTask1.ProgressRowCount = 1000
    oCustomTask1.MaximumErrorCount = 0
    oCustomTask1.FetchBufferSize = 1
    oCustomTask1.UseFastLoad = True
    oCustomTask1.InsertCommitSize = 0
    oCustomTask1.ExceptionFileColumnDelimiter = "|"
    oCustomTask1.ExceptionFileRowDelimiter = vbCrLf
    oCustomTask1.AllowIdentityInserts = False
    oCustomTask1.FirstRow = 0
    oCustomTask1.LastRow = 0
    oCustomTask1.FastLoadOptions = 2
    oCustomTask1.ExceptionFileOptions = 1
    oCustomTask1.DataPumpOptions = 0
    
    Call DTS_CustomTask(oCustomTask1)
    oPackage.Tasks.Add oTask
    Set oCustomTask1 = Nothing
    Set oTask = Nothing
End Sub
Private Sub DTS_CustomTask(oTask As DTS.DataPumpTask2)
    
    Dim oTransform As DTS.Transformation2
       
    Set oTransform = _
        oTask.Transformations.New("DTS.DataPumpTransformCopy")
    oTransform.Name = "CopyColumns"
    oTransform.TransformFlags = _
        DTSTransformFlag_AllowLosslessConversion
    oTask.Transformations.Add oTransform
    Set oTransform = Nothing
End Sub

End Sub

Private Sub Command2_Click()

End Sub

Private Sub Command4_Click()

Dim rst As New ADODB.Recordset
   With oraCon
      .Provider = "OraOLEDB.Oracle.1"
      .Properties("User ID") = Text1.Text
      .Properties("Password") = Text2.Text
      .Properties("Data Source") = Text3.Text
      .Properties("Persist Security Info") = True
      .Open
   End With

   With rst
      .Source = "select * from all_views where view_name<>'SYSTEM' order by owner,view_name"
      '.Source = "select * from all_views "
      .ActiveConnection = oraCon
      .CursorType = adOpenKeyset
      .LockType = adLockOptimistic
      .Open
   End With

   RefreshGrid rst
   FillTabList rst
   rst.Close

   Command1.Enabled = False

End Sub






Private Sub List1_DblClick()

Dim rst As New ADODB.Recordset
   Dim strSQL As String
   Dim tmpStr As String
   List2.AddItem (List1.List(List1.ListIndex))
   
   If Check1.Value = 1 Then
      With rst
         .Source = "select * from " & List1.List(List1.ListIndex)
         .ActiveConnection = oraCon
         .CursorType = adOpenKeyset
         .LockType = adLockOptimistic
         .Open
      End With
   
      RefreshGrid rst
      rst.Close
   End If
   
   tmpStr = List1.List(List1.ListIndex)
   strSQL = "SELECT COLUMN_ID, COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE "
   strSQL = strSQL & "FROM SYS.ALL_TAB_COLUMNS WHERE TABLE_NAME="
   strSQL = strSQL & "'" & Mid(tmpStr, InStr(1, tmpStr, ".", vbTextCompare) + 1) & "'"
   strSQL = strSQL & " and OWNER='" & Mid(tmpStr, 1, InStr(1, tmpStr, ".", vbTextCompare) - 1) & "'"
   With rst
      .Source = strSQL
      .ActiveConnection = oraCon
      .CursorType = adOpenKeyset
      .LockType = adLockOptimistic
      .Open
   End With
   
   rst.MoveFirst
   RefreshPropGrid rst
   
   rst.Close
   
   PropGrid.Visible = True
   SQLScriptList.Visible = False


End Sub

Private Sub RefreshGrid(rst As ADODB.Recordset)
   
   Dim fld As ADODB.Field
   On Error Resume Next
   
   FlxGrid1.Clear
   
   rst.MoveFirst
   
   If rst.EOF Then
      Exit Sub
   End If
   With FlxGrid1
       .Redraw = False
       .Clear
       .FixedCols = 0
       .FixedRows = 0
       .Cols = rst.Fields.Count
       rst.MoveLast
       .Rows = rst.RecordCount + 1
       .Row = 0
       .Col = 0
   
       For Each fld In rst.Fields
          .Text = fld.Name
          .ColAlignment(.Col) = 1
          .ColWidth(.Col) = Me.TextWidth(fld.Name & "AA")
          If .Col < rst.Fields.Count - 1 Then
             .Col = .Col + 1
          End If
       Next
       rst.MoveFirst
       Do Until rst.EOF
          .Row = .Row + 1
          .Col = 0
          For Each fld In rst.Fields
             If Not (IsNull(fld.Value)) Then
             
             .Text = fld.Value
             If .ColWidth(.Col) < Me.TextWidth(fld.Value & "AA") Then
                .ColWidth(.Col) = Me.TextWidth(fld.Value & "AA")
             End If
             End If
             If .Col < rst.Fields.Count - 1 Then
                .Col = .Col + 1
             End If
          Next
          rst.MoveNext
       Loop
       .FixedRows = 1
       .Redraw = True
   End With
End Sub


Private Sub FillTabList(rst As ADODB.Recordset)
    rst.MoveFirst
    Do Until rst.EOF
       List1.AddItem (Trim(rst.Fields("Owner").Value) & "." & Trim(rst.Fields("View_Name").Value))
       rst.MoveNext
    Loop
End Sub
Private Sub RefreshPropGrid(rst As ADODB.Recordset)
   
   Dim fld As ADODB.Field
   
'   On Error Resume Next
   PropGrid.Clear
   If rst.EOF Then
      Exit Sub
   End If
   With PropGrid
       .Redraw = False
       .Clear
       .FixedCols = 0
       .FixedRows = 0
       .Cols = rst.Fields.Count
       rst.MoveLast
       .Rows = rst.RecordCount + 1
       .Row = 0
       .Col = 0
   
       For Each fld In rst.Fields
          .Text = fld.Name
          .ColAlignment(.Col) = 1
          .ColWidth(.Col) = Me.TextWidth(fld.Name & "AA")
          If .Col < rst.Fields.Count - 1 Then
             .Col = .Col + 1
          End If
       Next
       rst.MoveFirst
       Do Until rst.EOF
          .Row = .Row + 1
          .Col = 0
          For Each fld In rst.Fields
             If Not (IsNull(fld.Value)) Then
                .Text = fld.Value
             If .ColWidth(.Col) < Me.TextWidth(fld.Value & "AA") Then
                .ColWidth(.Col) = Me.TextWidth(fld.Value & "AA")
             End If
             End If
             If .Col < rst.Fields.Count - 1 Then
                .Col = .Col + 1
             End If
          Next
          rst.MoveNext
       Loop
       .FixedRows = 1
       .Redraw = True
   End With
   
End Sub