Autocad与excel,txt,mdb文件通讯小结。
1、与excel通讯接口Function ReturnxlSheet() As Worksheet
Dim xlApp As Object ' This Line ,Not set Excel , run Excel
'Dim xlsheet As Object
' 发生错误时跳到下一个语句继续执行
On Error Resume Next
' 连接Excel应用程序
Set xlApp = GetObject(, "Excel.Application")
' Debug.Print Err.Number
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Add
End If
' 返回当前活动的工作表
Set ReturnxlSheet = xlApp.ActiveSheet
End Function
主程序要点：
sub main()
Dim xlSheet As Worksheet
Set xlSheet = ReturnxlSheet
end sub
SQL-TXT方法
Function CAdToText(InputFileName)
Dim LineData As AcadLine, ArcData As AcadArc
Close #1
Open InputFileName For Output As #1
Write #1, "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12"
Write #1, m1, m2, m3, m4, m5, m6, m7, m8, m9
Next ent
Close #1
End Function
Function SQLRecordsetFromTxt(InputFileName As String) As ADODB.Recordset
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "DRIVER={Microsoft Text Driver (*.txt; *.csv)};DBQ=d:\", "", ""
rs.Open " " & InputFileName, conn, 1, 3
Set RecordsetToExcel = rs
End Function
主程序:
Sub Main()
abc = "select"
abc = abc & " m7,m2,m4,m5,m6 from temp.txt where m1 = 'AcDbText' "
Set rsText = SQLRecordFromTxt(abc)
End Sub
，厉害 谢谢楼主分享！ MDB方法
Private Function CreateConnection(AccessDbName As String) As ADODB.Connection
Dim ConStr As String, Cnn As ADODB.Connection
Set Cnn = New ADODB.Connection
With Cnn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
C & AccessDbName
Cnn.Open ConStr
End With
Set CreateConnection = Cnn
End Function
Sub lll()
Dim Cnn As ADODB.Connection
Set Cnn = CreateConnection("E:\MyDrawing\MyDrawing\mdb\HG20592.mdb")
Dim Rst As ADODB.Recordset
Set Rst = New ADODB.Recordset
Dim Sql As String
Sql = " select a.*,b.cl22 from "
Sql = Sql & "带颈对焊法兰 as a Inner Join 螺柱A as b"
Sql = Sql & " on a.法兰规格 = b.法兰规格 "
Sql = Sql & "where a.法兰规格 = '150-2.5' and b.法兰规格 = '150-2.5'"
Rst.Open Sql, Cnn
With Rst.Fields
For jj = 0 To .Count - 1
Debug.Print jj, .Item(jj)
Next jj
End With
End Sub
Sub llll()
Dim Cnn As ADODB.Connection
Set Cnn = CreateConnection("E:\MyDrawing\MyDrawing\mdb\HG20592.mdb")
Dim Rst As ADODB.Recordset
Set Rst = New ADODB.Recordset
Dim Sql As String
Sql = " select a.*,b.Bl611 from "
'Sql = " select a.*,b.* from "
Sql = Sql & "板式平焊法兰 as a Inner Join 螺栓B as b"
Sql = Sql & " on a.法兰规格 = b.法兰规格 "
Sql = Sql & "where a.法兰规格 = '65-1.6' and b.法兰规格 = '65-1.6'"
Rst.Open Sql, Cnn
With Rst.Fields
For jj = 0 To .Count - 1
Debug.Print jj, .Item(jj)
Next jj
End With
End Sub
本帖最后由 作者 于 2008-7-30 16:34:52 编辑
SQL-EXCELFunction InCadGetSqlExcelRecordset(Sql As String, InputFileName) As ADODB.Recordset
Dim Rst As New ADODB.Recordset
Set Cnn = New ADODB.Connection
Cnn.Open "Provider = MicroSoft.Jet.OLEDB.4.0; Extended Properties = Excel 8.0; Data Source = " & InputFileName
Rst.Open Sql, Cnn, adOpenStatic
Set InCadGetSqlExcelRecordset = Rst
End Function
Function FromSheetReturnxlSheet(SheetName As String) As Worksheet
Dim xlApp As Application 'As Object ' This Line ,Not set Excel , run Excel
'Dim xlsheet As Object
' 发生错误时跳到下一个语句继续执行
On Error Resume Next
' 连接Excel应用程序
Set xlApp = GetObject(, "Excel.Application")
' Debug.Print Err.Number
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Add
End If
' 返回当前活动的工作表
'xlApp.ActiveWorkbook.Sheets (SheetName)
Set FromSheetReturnxlSheet = xlApp.ActiveWorkbook.Sheets(SheetName)
End Function
Sub ll()
Dim Rst As ADODB.Recordset
Dim Sql As String
Sql = "Select distinct m1 from "
Set Rst = InCadGetSqlExcelRecordset(Sql, "d:\ls.xls")
Dim xlSheetAs Worksheet
Set xlSheet = FromSheetReturnxlSheet("Sheet3")
xlSheet.Range("a:z").ClearContents
xlSheet.Cells(1, 1).CopyFromRecordset Rst
End Sub
顶版主 <p>支持版主，希望以后能多向你请教，呵呵！</p> 谢谢你，版主！！！ <p>好东东</p><p></p> <p>不错不错，内容好极了，我就不用一个一个的找了</p> 不错的东西