分享
 
 
 

vb_db_draft

王朝vb·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有