|
#2
qlong07282008-10-27 10:17
给个例子您看看
Try Dim DS As System.Data.DataSet Dim MyCommand As System.Data.OleDb.OleDbDataAdapter Dim MyConnection As System.Data.OleDb.OleDbConnection Dim path, pathsheet, strsql As String Dim bing As New BindingSource If Len(Text1.Text) = 0 Then MsgBox("无此客户代码！", 48, Message_Title) TextBox1.Focus() Exit Sub End If If Len(TextBox3.Text) = 0 Then MsgBox("Excel表名不能空！", 48, Message_Title) TextBox3.Focus() Exit Sub End If If Len(TextBox2.Text) = 0 Then MsgBox("文件路径不能空！", 48, Message_Title) TextBox2.Focus() Exit Sub End If path = Dir(Trim(TextBox2.Text)) If path = "" Then MsgBox("无此文件！", 48, Message_Title) TextBox2.Focus() Exit Sub End If If Strings.Right(UCase(Trim(TextBox2.Text)), 3) <> "XLS" Then MsgBox("文件不是Excel文件！", 48, Message_Title) TextBox2.Focus() Exit Sub End If pathsheet = Trim(TextBox3.Text) & "$" MyConnection = New System.Data.OleDb.OleDbConnection("Provider=Microsoft.Jet.Oledb.4.0;Data Source=" + path + ";Extended Properties=Excel 8.0") MyCommand = New System.Data.OleDb.OleDbDataAdapter("select * from [" & pathsheet & "]", MyConnection) Label3.Text = "正在打开已经存在的Excel文件,请稍后......" Label3.Refresh() DS = New System.Data.DataSet() MyCommand.Fill(DS) Dim i As Integer If DS.Tables(0).Rows.Count = 0 Then MsgBox("Excel没有数据可导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If Dim STRdesc(DS.Tables(0).Rows.Count - 1) Dim STbhcb(DS.Tables(0).Rows.Count - 1) Dim STbherr As Boolean = False DataGridView2.Rows.Clear() For i = 0 To DS.Tables(0).Rows.Count - 1 Label3.Text = "正在检测Excel表格中的不符合规格的数据,请稍后......" & DS.Tables(0).Rows(i)("WP") Label3.Refresh() If DS.Tables(0).Rows(i)("WP") Is DBNull.Value Then MsgBox("WP列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If 'If DS.Tables(0).Rows(i)("O/C") Is DBNull.Value Then ' MsgBox("O/C列数据有空值，请修正后再导入！", 48, Message_Title) ' Label3.Text = "" ' TextBox2.Focus() ' Exit Sub 'End If 'If DS.Tables(0).Rows(i)("Order No") Is DBNull.Value Then ' MsgBox("Order No列数据有空值，请修正后再导入！", 48, Message_Title) ' Label3.Text = "" ' TextBox2.Focus() ' Exit Sub 'End If If DS.Tables(0).Rows(i)("Part No") Is DBNull.Value Then MsgBox("Part No列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub Else Dim dpdata As New DataSet Dim da As New SqlClient.SqlDataAdapter strsql = "select s_desc from s_dp_pn where s_part_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" da.SelectCommand = New SqlClient.SqlCommand(strsql, conn) da.Fill(dpdata, 0) If dpdata.Tables(0).Rows.Count = 0 Then Dim assydata As New DataSet strsql = "select s_desc from s_assy_pn where s_assy_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" da.SelectCommand = New SqlClient.SqlCommand(strsql, conn) da.Fill(assydata, 0) If assydata.Tables(0).Rows.Count = 0 Then Dim ckddata As New DataSet strsql = "select s_desc from s_ckd_pn where s_ckd_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" da.SelectCommand = New SqlClient.SqlCommand(strsql, conn) da.Fill(ckddata, 0) If ckddata.Tables(0).Rows.Count = 0 Then STbherr = True DataGridView2.Rows.Insert(0) DataGridView2.Rows(0).Cells(0).Value = UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) 'MsgBox("无" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "产品编号，请维护产品编号后再导入！", 48, Message_Title) 'Label3.Text = "" 'TextBox2.Focus() 'Exit Sub Else STRdesc(i) = ckddata.Tables(0).Rows(0)("s_desc") STbhcb(i) = 3 End If Else STRdesc(i) = assydata.Tables(0).Rows(0)("s_desc") STbhcb(i) = 2 End If Else STRdesc(i) = dpdata.Tables(0).Rows(0)("s_desc") STbhcb(i) = 1 End If End If If DS.Tables(0).Rows(i)("Order Date") Is DBNull.Value Then MsgBox("Order Date列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If If DS.Tables(0).Rows(i)("Order Quantity") Is DBNull.Value Then MsgBox("Order Quantity列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If If DS.Tables(0).Rows(i)("Currency") Is DBNull.Value Then MsgBox("Currency列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If If DS.Tables(0).Rows(i)("Unit Of Price") Is DBNull.Value Then MsgBox("Unit Of Price列数据有空值，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If Next If STbherr Then Panel6.Visible = True Panel3.Enabled = False MsgBox("列表中的产品编号没有，请维护产品编号后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If Dim STRmodel, STRbz, STRph, STRworder As String Dim STRdate As Date RS_query.Tables(0).Clear() For i = 0 To DS.Tables(0).Rows.Count - 1 Label3.Text = "正在导入数据,请稍后......" & DS.Tables(0).Rows(i)("Part No") Label3.Refresh() RS_query.Tables(0).Rows.Add() RS_query.Tables(0).Rows(i).Item(0) = UCase(Trim(TextBox1.Text)) RS_query.Tables(0).Rows(i).Item(1) = UCase(Trim(DS.Tables(0).Rows(i)("WP"))) If DS.Tables(0).Rows(i)("Work Order") Is DBNull.Value Then If DS.Tables(0).Rows(i)("Order No") Is DBNull.Value Then MsgBox("Work Order和Order No列数据不能同时空，请修正后再导入！", 48, Message_Title) Label3.Text = "" TextBox2.Focus() Exit Sub End If STRworder = UCase(Trim(DS.Tables(0).Rows(i)("Order No"))) Else If DS.Tables(0).Rows(i)("Work Order") = "" Then STRworder = UCase(Trim(DS.Tables(0).Rows(i)("Order No"))) Else STRworder = UCase(Trim(DS.Tables(0).Rows(i)("Work Order"))) End If End If RS_query.Tables(0).Rows(i).Item(2) = STRworder 'RS_query.Tables(0).Rows(i).Item(3) = UCase(Trim(DS.Tables(0).Rows(i)("Work Order"))) RS_query.Tables(0).Rows(i).Item(3) = UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) RS_query.Tables(0).Rows(i).Item(4) = STRdesc(i) RS_query.Tables(0).Rows(i).Item(5) = Val(DS.Tables(0).Rows(i)("Order Quantity")) RS_query.Tables(0).Rows(i).Item(6) = Val(DS.Tables(0).Rows(i)("Unit Of Price")) STRdate = Mid(DS.Tables(0).Rows(i)("Order Date"), 1, 4) & "-" & Mid(DS.Tables(0).Rows(i)("Order Date"), 5, 2) & "-" & Mid(DS.Tables(0).Rows(i)("Order Date"), 7, 2) RS_query.Tables(0).Rows(i).Item(7) = STRdate RS_query.Tables(0).Rows(i).Item(8) = UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) If DS.Tables(0).Rows(i)("Item Specification") Is DBNull.Value Then STRmodel = "" Else STRmodel = Replace(DS.Tables(0).Rows(i)("Item Specification"), "'", "") End If RS_query.Tables(0).Rows(i).Item(9) = UCase(Trim(STRmodel)) If DS.Tables(0).Rows(i)("O/C") Is DBNull.Value Then STRph = "" Else STRph = DS.Tables(0).Rows(i)("O/C") End If RS_query.Tables(0).Rows(i).Item(10) = UCase(Trim(STRph)) If DS.Tables(0).Rows(i)("Description") Is DBNull.Value Then STRbz = "" Else STRbz = DS.Tables(0).Rows(i)("Description") End If RS_query.Tables(0).Rows(i).Item(11) = UCase(Trim(STRbz)) If STbhcb(i) = 1 Then SQLtile = "update s_dp_pn set s_unit_prince='" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "',s_currency='" & UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) & "',s_model='" & UCase(Trim(STRmodel)) & "' " & _ "where s_part_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" End If If STbhcb(i) = 2 Then SQLtile = "update s_assy_pn set s_unit_prince='" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "',s_currency='" & UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) & "',s_model='" & UCase(Trim(STRmodel)) & "' " & _ "where s_assy_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" End If If STbhcb(i) = 3 Then SQLtile = "update s_ckd_pn set s_unit_prince='" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "',s_currency='" & UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) & "',s_model='" & UCase(Trim(STRmodel)) & "' " & _ "where s_ckd_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'" End If Dim CMDbh As New SqlClient.SqlCommand(SQLtile, conn) CMDbh.ExecuteNonQuery() Dim adddata As New DataSet Dim da As New SqlClient.SqlDataAdapter strsql = "select s_part_no from s_po where s_po_no='" & STRworder & "' and s_part_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "' and s_fty_id='" & UCase(Trim(TextBox1.Text)) & "'" da.SelectCommand = New SqlClient.SqlCommand(strsql, conn) da.Fill(adddata, 0) If adddata.Tables(0).Rows.Count = 0 Then SQLtile = "insert into s_po(s_fty_id,s_po_id,s_po_no,s_part_no,s_desc,s_qty,s_unit_price,s_po_date,s_currency,s_model,s_order,s_remarks,s_czr,s_czrq) " & _ "values ('" & UCase(Trim(TextBox1.Text)) & "','" & UCase(Trim(DS.Tables(0).Rows(i)("WP"))) & "','" & STRworder & "','" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "', " & _ "'" & STRdesc(i) & "','" & Val(DS.Tables(0).Rows(i)("Order Quantity")) & "','" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "','" & STRdate & "','" & UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) & "','" & UCase(Trim(STRmodel)) & "', " & _ "'" & STRph & "','" & STRbz & "','" & Username & "','" & Dtdate & "')" 'cn.Execute("insert into s_po(s_fty_id,s_po_id,s_po_no,s_part_no,s_desc,s_qty,s_unit_price,s_po_date,s_currency,s_model,s_order,s_remarks,s_czr,s_czrq)" & _ ' " values ('" & UCase(Trim(DS.Tables(0).Rows(i)("FTY_ID"))) & "','" & UCase(Trim(DS.Tables(0).Rows(i)("WP"))) & "','" & STRworder & "','" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "'," & _ ' "'" & STRdesc(i) & "','" & Val(DS.Tables(0).Rows(i)("Order Quantity")) & "','" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "','" & STRdate & "','" & UCase(Trim(DS.Tables(0).Rows(i)("Currency"))) & "','" & UCase(Trim(STRmodel)) & "'," & _ ' "'" & STRph & "','" & STRbz & "','" & Username & "','" & Dtdate & "')") Else SQLtile = "update s_po set s_qty='" & Val(DS.Tables(0).Rows(i)("Order Quantity")) & "',s_unit_price='" & Val(DS.Tables(0).Rows(i)("Unit Of Price")) & "',s_czr='" & Username & "', s_czrq='" & Dtdate & "' " & _ "where s_po_no='" & STRworder & "' and s_part_no='" & UCase(Trim(DS.Tables(0).Rows(i)("Part No"))) & "' and s_fty_id='" & UCase(Trim(TextBox1.Text)) & "'" End If Dim CMDsave As New SqlClient.SqlCommand(SQLtile, conn) CMDsave.ExecuteNonQuery() Next Label3.Text = "" MsgBox("数据导入完毕！", 48, Message_Title) Catch ex As Exception MessageBox.Show(ex.ToString, Message_Title, MessageBoxButtons.OK, MessageBoxIcon.Warning) Call RSlog(ex.ToString, "Frm_po(Butq_Click)") RS_query.Tables(0).Clear() Label3.Text = "" End Try |
可以用GetObject获得首个打开的Excel对象。但我看到说明，它现在用NEW关键字创建类的实例—对象。抛弃了原来的CreatObject函数。那么怎样不用GetObject函数来获取首个打开的Excel对象？
好像是用捕捉进程什么的？具体这方面我不会，还请各位高手帮忙写个代码，在此先谢谢各位！
黄玉宏 二○○八年十月二十五日
