作者：未知 来源：月光软件站 加入时间：2005-2-28　月光软件站

Option Explicit
'db info
Private conn As Connection
Private odbc As String
Private user As String
Private pwd As String
Private connToDb As Boolean
Private xlsPath As String
Private xlApp As Excel.Application
Private xlBook As Excel.Workbook
Private xlSheet As Excel.Worksheet

Private Sub Command1_Click()
On Error GoTo errh:
If Not connToDb Then
    MsgBox "ÇëÏÈÁ¬½ÓÊý¾Ý¿â"
    Exit Sub
End If
Dim fname As String

fname = List1.Text
operation fname

Exit Sub
errh:
    Unload Me
End Sub
Private Function getTable() As String
Dim i As Integer

End Function
Private Sub Command2_Click()

Set conn = New Connection
conn.Open odbc, user, pwd

connToDb = True
Label5.Caption = "Connecting...."

End Sub

Private Sub Command3_Click()
findXls (Trim(Text1.Text))
End Sub

Private Function findXls(path As String) As BookmarkEnum
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fld As Folder
Set fld = fso.GetFolder(path)
Dim f As File
Dim i As Integer
For Each f In fld.Files
    If (getExt(f.ShortName)) Then
        List1.AddItem f.Name
    End If
Next
If Not fld Is Nothing Then Set fld = Nothing
If Not fso Is Nothing Then Set fso = Nothing
MsgBox " Çë´Ó×óÏ·½Ñ¡Ôñ´ý²Ù×÷µÄXLSÎļþ"
End Function

Private Function getExt(str As String) As Boolean
If LCase(Mid(str, Len(str) - 2)) = "xls" Then
    getExt = True
Else
    getExt = False
End If
End Function

Private Sub Dir1_Change()
Text1.Text = Dir1.path
End Sub

Private Sub Drive1_Change()
Dir1.path = Drive1.Drive
End Sub

Private Sub Form_Load()
On Error GoTo errh:
odbc = Trim(Text2.Text)
user = Trim(Text3.Text)
pwd = Trim(Text4.Text)
Drive1.Drive = "e:\"
Exit Sub
errh:
    MsgBox Err.Description
'    connToDb = False
    releaseResource
End Sub

Private Sub Form_Unload(Cancel As Integer)
releaseResource
End Sub

Private Function releaseResource() As Boolean
If Not conn Is Nothing Then Set conn = Nothing
If Not xlBook Is Nothing Then Set xlBook = Nothing
If Not xlApp Is Nothing Then Set xlApp = Nothing
End Function

Private Function operation(fname As String) As Boolean
'´ò¿ªExcelÎļþ
Dim path As String
On Error GoTo errh:

path = Trim(Text1.Text) & "\" & fname

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(path)
Set xlSheet = xlBook.Worksheets(1)
Dim i As Integer
Dim j As Integer
Dim sql As String

Dim tableName As String
tableName = xlSheet.Cells(1, "A").Value
Dim fields As String
'set data count
Label9.Caption = xlSheet.UsedRange.Rows.Count - 1
Label11.Caption = ""
DoEvents
fields = genFields()
Dim pkFields As String
pkFields = Trim(xlSheet.Cells(2, "A").Value)
Dim b As Boolean
'Dim sql As String
For i = 2 To xlSheet.UsedRange.Rows.Count
    b = testDataExists(tableName, fields, i)
    If b = True Then
        sql = updateSql(tableName, fields, i)
    Else
        sql = insertSql(tableName, fields, i)
    End If

    conn.Execute sql
    Label11.Caption = i - 1
   
    DoEvents
Next i
   
xlBook.Saved = True
If Not xlBook Is Nothing Then xlBook.Close
If Not xlApp Is Nothing Then Set xlApp = Nothing

MsgBox "±í :" & tableName & " µÄ²Ù×÷ÒÑÍê³É"

List2.AddItem List1.Text
List1.RemoveItem List1.ListIndex
Exit Function

errh:
    xlBook.Saved = True
    If Not xlBook Is Nothing Then xlBook.Close
    If Not xlApp Is Nothing Then Set xlApp = Nothing
    If Not conn Is Nothing Then Set conn = Nothing
    MsgBox Err.Description & "¶ÔÓ¦µÄexcel ÐкÅÊÇ £º" & i
    Unload Me

End Function

Private Function testDataExists() As Boolean
Dim j As Integer

End Function

Private Function insertSql(tableName As String, fields As String, i As Integer) As String
    insertSql = "INSERT INTO " & tableName & " " & fields & " VALUES " & genValues(i)
End Function

Private Function genFields() As String
Dim j As Integer
Dim field As String
For j = 2 To xlSheet.UsedRange.Columns.Count
    If Len(field) = 0 Then
        field = xlSheet.Cells(1, j).Value
        
    Else
        field = field & "," & xlSheet.Cells(1, j).Value
    End If
Next j
field = "(" & field & ")"
genFields = field
End Function

Private Function genValues(i As Integer) As String
Dim j As Integer
Dim valueStr As String
Dim fieldValue As String

For j = 2 To xlSheet.UsedRange.Columns.Count
    fieldValue = Trim(xlSheet.Cells(i, j).Value)
    'if field value is "" then set it as null (for oracle)
'    If Len(fieldValue) = 0 Then
'        fieldValue = "null"
'    End If
    If Len(valueStr) = 0 Then
        If Len(fieldValue) = 0 Then
            valueStr = "null"
        ElseIf IsDate(fieldValue) Then
        'operation for date
            valueStr = convertDateToOracleString(fieldValue)
        Else
            valueStr = "'" & fieldValue & "'"
        End If
    Else
        If Len(fieldValue) = 0 Then
            valueStr = valueStr & "," & "null"
        ElseIf IsDate(fieldValue) Then
            valueStr = valueStr & "," & convertDateToOracleString(fieldValue)
        Else
            valueStr = valueStr & "," & "'" & fieldValue & "'"
        End If
    End If
Next j
valueStr = "(" & valueStr & ")"
genValues = valueStr
End Function

Private Function convertDateToOracleString(str As String) As String
Dim ret As String
ret = "TO_DATE('" & str & "','yyyy-mm-dd')"
convertDateToOracleString = ret
End Function

相关软件：