Option Explicit

Dim myConnSrc As New ADODB.Connection
Dim myConnDes As New ADODB.Connection
Dim myCommandSrc As New ADODB.Command
Dim myCommandDes As New ADODB.Command
Dim myRsSrc As New ADODB.Recordset
Dim myRsDes As New ADODB.Recordset

Private Sub CommandButton1_Click()

    On Error GoTo HandleError

    Dim errMess As String   'エラーメッセージ表示用

    '元のDB接続
    errMess = "元のDB"
    myConnSrc.Provider = "ASAProv"
    myConnSrc.ConnectionString = "Data Source=" + Cells(4, 3).Value
    myConnSrc.Open
    
    '先のDB接続
    errMess = "先のDB"
    myConnDes.Provider = "ASAProv"
    myConnDes.ConnectionString = "Data Source=" + Cells(4, 4).Value
    myConnDes.Open
    
    '終了
    Cells(6, 3).Value = "接続成功"
    Exit Sub

HandleError:
    Cells(6, 3).Value = errMess + "に接続失敗"
    Call CommandButton4_Click
    Exit Sub

End Sub

Private Sub CommandButton2_Click()
    
'    On Error GoTo HandleError
    
    Dim cAffected As Long
    Dim SQLString As String
    
    myConnSrc.BeginTrans
    SQLString = "Select * from " + Cells(10, 3).Value
    myRsSrc.Open SQLString, myConnSrc, adOpenDynamic, adLockBatchOptimistic

    If myRsSrc.BOF And myRsSrc.EOF Then
        MsgBox "レコードが空です。"
    Else
        'シートクリア
        Sheets("データ").Cells.Clear
        Sheets("データ").Cells.NumberFormatLocal = "@"
        
        Dim iLoop As Integer
        'フィールド名を列挙
        For iLoop = 0 To myRsSrc.Fields.Count - 1
            Sheets("データ").Cells(3, iLoop + 2).Value = myRsSrc(iLoop).Name
        Next
        
        Dim iCount As Integer
        iCount = 4
        Do Until myRsSrc.EOF
            '1 レコード毎の処理
            For iLoop = 0 To myRsSrc.Fields.Count - 1
            Sheets("データ").Cells(iCount, iLoop + 2).Value = myRsSrc(iLoop).Value
            Next
            iCount = iCount + 1
            myRsSrc.MoveNext
        Loop
    End If
    myConnSrc.CommitTrans
    myRsSrc.Close
    MsgBox "読み込みが完了しました"
    Exit Sub

HandleError:
    myRsSrc.Close
    MsgBox "読み込みに失敗しました。"
    Exit Sub

End Sub


Private Sub CommandButton3_Click()
    
    On Error GoTo HandleError
    
    Dim cAffected As Long
    Dim SQLString As String
    
    myConnDes.BeginTrans
    SQLString = "Select * from " + Cells(10, 3).Value
    myRsDes.Open SQLString, myConnDes, adOpenDynamic, adLockBatchOptimistic

    Dim iLoop As Integer
    Dim iCount As Integer
    iCount = 4
    Do Until Sheets("データ").Cells(iCount, 2).Value = ""
        '1 レコード毎の処理
        SQLString = "INSERT INTO " + Cells(10, 3).Value + " ("
        SQLString = SQLString + Sheets("データ").Cells(3, 2).Value
        'フィールド名部分
        For iLoop = 1 To myRsDes.Fields.Count - 1
            SQLString = SQLString + "," + Sheets("データ").Cells(3, iLoop + 2).Value
        Next
        
        'データ部分
        SQLString = SQLString + ") VALUES ("
        If CStr(Sheets("データ").Cells(iCount, 2).Value) <> "" Then
            If IsDigit(Sheets("データ").Cells(iCount, 2).Value) Then
                SQLString = SQLString + CStr(Sheets("データ").Cells(iCount, 2).Value)
            Else
                SQLString = SQLString + "'" + CStr(Sheets("データ").Cells(iCount, 2).Value) + "'"
            End If
        Else
            SQLString = SQLString + "''"
        End If
        
        For iLoop = 1 To myRsDes.Fields.Count - 1
            If CStr(Sheets("データ").Cells(iCount, iLoop + 2).Value) <> "" Then
                If IsDigit(CStr(Sheets("データ").Cells(iCount, iLoop + 2).Value)) Then
                    SQLString = SQLString + "," + CStr(Sheets("データ").Cells(iCount, iLoop + 2).Value)
                Else
                    SQLString = SQLString + ",'" + CStr(Sheets("データ").Cells(iCount, iLoop + 2).Value) + "'"
                End If
            Else
                SQLString = SQLString + "," + "''"
            End If
        Next
        SQLString = SQLString + ")"
        myConnDes.Execute SQLString
        Cells(17, 3).Value = SQLString
        iCount = iCount + 1
    Loop
    
    myConnDes.CommitTrans
    myRsDes.Close
    MsgBox "書き込みが完了しました"
    Exit Sub

HandleError:
    MsgBox "書き込みに失敗しました。"
    Cells(17, 3).Value = SQLString
    myRsDes.Close
    Exit Sub

End Sub


Private Sub CommandButton4_Click()
'    myRsSrc.Close

    If myConnSrc <> Null Then
        myConnSrc.Close
    End If
    If myConnDes <> Null Then
        myConnDes.Close
    End If
    Exit Sub

End Sub