vb_db_draft
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