怎样用VB.NET获取已经打开的Excel对象
可以用GetObject获得首个打开的Excel对象。但我看到说明，它现在用NEW关键字创建类的实例—对象。抛弃了原来的CreatObject函数。那么怎样不用GetObject函数来获取首个打开的Excel对象？好像是用捕捉进程什么的？具体这方面我不会，还请各位高手帮忙写个代码，在此先谢谢各位！
黄玉宏 二○○八年十月二十五日
给个例子您看看
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
