Autocad与excel,txt,mdb文件通讯小结。

兰州人 · 发表于 2008-7-30 08:51:00

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

兰州人 · 发表于 2008-7-30 08:56:00

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

fengche1915@ · 发表于 2018-3-23 09:24:42

，厉害

zhouzhiy · 发表于 2017-11-8 18:01:10

谢谢楼主分享！

兰州人 · 发表于 2008-7-30 09:00:00

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

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 09:10:00

本帖最后由作者于 2008-7-30 16:34:52 编辑

SQL-EXCEL

Function 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 [Sheet1$] "
Set Rst = InCadGetSqlExcelRecordset(Sql, "d:\ls.xls")
Dim xlSheet As Worksheet
Set xlSheet = FromSheetReturnxlSheet("Sheet3")
xlSheet.Range("a:z").ClearContents
xlSheet.Cells(1, 1).CopyFromRecordset Rst
End Sub

Function 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 [Sheet1$]  "
  Set Rst = InCadGetSqlExcelRecordset(Sql, "d:\ls.xls")
  Dim xlSheet  As Worksheet
  Set xlSheet = FromSheetReturnxlSheet("Sheet3")
  xlSheet.Range("a:z").ClearContents
  xlSheet.Cells(1, 1).CopyFromRecordset Rst
End Sub

xxxtttxxx · 发表于 2008-7-30 11:58:00

顶版主

大菜鸟 · 发表于 2008-8-6 18:10:00

支持版主，希望以后能多向你请教，呵呵！

idoo · 发表于 2008-8-17 22:05:00

谢谢你，版主！！！

style6301 · 发表于 2008-8-30 09:47:00

好东东

自在小子 · 发表于 2008-9-5 09:49:00

不错不错，内容好极了，我就不用一个一个的找了

自在小子 · 发表于 2008-9-5 09:49:00

不错的东西

账号		自动登录	找回密码
密码			注册

Autocad与excel,txt,mdb文件通讯小结。

评分