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

|