SQL在首尾相连中的应用

Question

数据源
x1 y1 z1 x2 y2 z2
440.82 560.29 0 855.33 234.42 0
855.33 234.42 0 1215.14 570.8 0
1215.14 570.8 0 1600.19 766.32 0
1600.19 766.32 0 1560.21 972.36 0
1560.21 972.36 0 1029.97 1056.45 0
1029.97 1056.45 0 539.71 921.9 0
539.71 921.9 0 440.82 560.29 0
经过以下程序处理
  For ii = 1 To gg.RecordCount
    gg.MoveFirst
    CC = 3
    a1 = gg.Fields(CC + 3):  a2 = gg.Fields(CC + 4)
    
    a3 = gg.Fields(CC + 0):  a4 = gg.Fields(CC + 1)
    Sql = " Select  m1,m2,m3,x1,y1,z1,x2,y2,z2 from Temp.txt "
    Sql = Sql & " where x1 = " & a1 & " and y1 = " & a2
    Sql = Sql & " and x2 <> " & a3 & " and y2 <> " & a4
    'Debug.Print Sql
    Set gg = RecordsetToExcel(Sql)
'    Debug.Print gg.RecordCount
    If gg.RecordCount = 0 Then
      Sql = " Select  m1,m2,m3,x2,y2,z2,x1,y1,z1 from Temp.txt "
      Sql = Sql & " where x2 = " & a1 & " and y2 = " & a2
      Sql = Sql & " and x1 <> " & a3 & " and y1 <> " & a4
      'Debug.Print Sql
      Set gg = RecordsetToExcel(Sql)
    End If
    'Debug.Print gg.RecordCount
    With xlSheet
      '.Range("A:Z").ClearContents
      .Cells(ii + 1, 1).CopyFromRecordset gg '复制符合条件的记录
    End With
Next ii结果如下x1 y1 z1 x2 y2 z2
855.33 234.42 0 1215.14 570.8 0
1215.14 570.8 0 1600.19 766.32 0
1600.19 766.32 0 1560.21 972.36 0
1560.21 972.36 0 1029.97 1056.45 0
1029.97 1056.45 0 539.71 921.9 0
539.71 921.9 0 440.82 560.29 0
440.82 560.29 0 855.33 234.42 0

Answer 1

Function CadToTxtForLineAndArc(InputFileName)
  Dim LineData As AcadLine, ArcData As AcadArc
  Close #1  Open InputFileName For Output As #1
  
  Write #1, "m1", "m2", "m3", "x1", "y1", "z1", "x2", "y2", "z2", "m10", "m11", "m12"
  
  Dim Ent As AcadEntity
  Dim lineObj As AcadLine, textObj As AcadText, arcObj As AcadArc
  For Each Ent In ThisDrawing.ModelSpace
    m1 = Ent.ObjectName
    m2 = Ent.ObjectID
    m3 = Ent.Layer
    
    Select Case Ent.ObjectName
          Case "AcDbLine"
            Set lineObj = Ent
              With lineObj
                    x1 = Round(.StartPoint(0), 2)
                    y1 = Round(.StartPoint(1), 2)
                    z1 = Round(.StartPoint(2), 2)
                    x2 = Round(.EndPoint(0), 2)
                    y2 = Round(.EndPoint(1), 2)
                    z2 = Round(.EndPoint(2), 2)
                
              End With
          Case "AcDbArc"
            Set arcObj = Ent
              With arcObj
                    x1 = Round(.StartPoint(0), 2)
                    y1 = Round(.StartPoint(1), 2)
                    z1 = Round(.StartPoint(2), 2)
                    x2 = Round(.EndPoint(0), 2)
                    y2 = Round(.EndPoint(1), 2)
                    z2 = Round(.EndPoint(2), 2)
              End With
    End Select    Write #1, m1, m2, m3, x1, y1, z1, x2, y2, z2
    
  Next Ent
  
  Close #1End Function
Sub Main()
  CadToTxtForLineAndArc ("D:\Temp.txt")
      Dim gg As ADODB.Recordset
    Dim Sql As String
    Dim a1 As String, a2 As String
    ii = 2
    Sql = " Select  m1,m2,m3,x1,y1,z1,x2,y2,z2 from temp.txt "
    Set gg = RecordsetToExcel(Sql)  Dim xlSheet  Set xlSheet = ConnectExcel("Sheet2")
 With xlSheet
    .Range("a:z").ClearContents
    cc1 = 3
    .Cells(1, 1 + cc1) = "x1": .Cells(1, 2 + cc1) = "y1": .Cells(1, 3 + cc1) = "z1":
    cc1 = 6
    .Cells(1, 1 + cc1) = "x2": .Cells(1, 2 + cc1) = "y2": .Cells(1, 3 + cc1) = "z2":
    .Range("A2").CopyFromRecordset gg
 End With
 
  Set xlSheet = ConnectExcel("Sheet1")
  ii = 2
 With xlSheet
    .Range("a:z").ClearContents
    cc1 = 3
    .Cells(1, 1 + cc1) = "x1": .Cells(1, 2 + cc1) = "y1": .Cells(1, 3 + cc1) = "z1":
    cc1 = 6
    .Cells(1, 1 + cc1) = "x2": .Cells(1, 2 + cc1) = "y2": .Cells(1, 3 + cc1) = "z2":
    gg.MoveFirst
    Debug.Print gg.RecordCount, gg.Fields(0), gg.Fields(1)
    .Cells(ii, 1).CopyFromRecordset gg
 End With
  
  For ii = 1 To gg.RecordCount
    gg.MoveFirst
    CC = 3
    a1 = gg.Fields(CC + 3):  a2 = gg.Fields(CC + 4)
    
    a3 = gg.Fields(CC + 0):  a4 = gg.Fields(CC + 1)
    Sql = " Select  m1,m2,m3,x1,y1,z1,x2,y2,z2 from Temp.txt "
    Sql = Sql & " where x1 = " & a1 & " and y1 = " & a2
    Sql = Sql & " and x2 <> " & a3 & " and y2 <> " & a4
    'Debug.Print Sql
    Set gg = RecordsetToExcel(Sql)
'    Debug.Print gg.RecordCount
    If gg.RecordCount = 0 Then
      Sql = " Select  m1,m2,m3,x2,y2,z2,x1,y1,z1 from Temp.txt "
      Sql = Sql & " where x2 = " & a1 & " and y2 = " & a2
      Sql = Sql & " and x1 <> " & a3 & " and y1 <> " & a4
      'Debug.Print Sql
      Set gg = RecordsetToExcel(Sql)
    End If
    'Debug.Print gg.RecordCount
    With xlSheet
      '.Range("A:Z").ClearContents
      .Cells(ii + 1, 1).CopyFromRecordset gg '复制符合条件的记录
    End With
Next ii
 
  
End SubFunction RecordsetToExcel(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
  'Sheet1.Range("A2").CopyFromRecordset rsEnd FunctionFunction ConnectExcel(InputSheetName As String) As Object
   Dim xlApp As Object
   On Error Resume Next
   Set xlApp = GetObject(, "Excel.Application")
   Set ConnectExcel = xlApp.ActiveWorkbook.Sheets(InputSheetName)
End FunctionSub abab()
  Set ee = ConnectExcel("Sheet1")
  Dim lineObj As AcadLine
  Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
  For ii = 2 To 8
    For jj = 0 To 2
      With ee
        
        pp(jj) = .Cells(ii, jj + 4).Value
        ppp(jj) = .Cells(ii, jj + 7).Value
        Debug.Print pp(jj), ppp(jj)
      End With
    Next jj
    Set lineObj = ThisDrawing.ModelSpace.AddLine(pp, ppp)
  Next ii
End Sub

Answer 2

Function CadToTxtForLineAndArc(InputFileName)
  Dim LineData As AcadLine, ArcData As AcadArc
  Close #1  Open InputFileName For Output As #1
  
  Write #1, "m1", "m2", "m3", "x1", "y1", "z1", "x2", "y2", "z2", "m10", "m11", "m12", "m13", "m14", "m15"
  
  Dim Ent As AcadEntity
  Dim lineObj As AcadLine, textObj As AcadText, arcObj As AcadArc
  For Each Ent In ThisDrawing.ModelSpace
    m1 = Ent.ObjectName
    m2 = Ent.Handle
    m3 = Ent.Layer
    
    Select Case Ent.ObjectName
          Case "AcDbLine"
            Set lineObj = Ent
              With lineObj
                    x1 = Round(.StartPoint(0), 2)
                    y1 = Round(.StartPoint(1), 2)
                    z1 = Round(.StartPoint(2), 2)
                    x2 = Round(.EndPoint(0), 2)
                    y2 = Round(.EndPoint(1), 2)
                    z2 = Round(.EndPoint(2), 2)
                
              End With
          Case "AcDbArc"
            Set arcObj = Ent
              With arcObj
                    x1 = Round(.StartPoint(0), 2)
                    y1 = Round(.StartPoint(1), 2)
                    z1 = Round(.StartPoint(2), 2)
                    x2 = Round(.EndPoint(0), 2)
                    y2 = Round(.EndPoint(1), 2)
                    z2 = Round(.EndPoint(2), 2)
                    m10 = Round(.Center(0), 2)
                    m11 = Round(.Center(1), 2)
                    m12 = Round(.Center(2), 2)
                    m13 = Round(.StartAngle, 2)
                    m14 = Round(.EndAngle, 2)
                    m15 = Round(.Radius, 2)
                    
              End With
    End Select    Write #1, m1, m2, m3, x1, y1, z1, x2, y2, z2, m10, m11, m12, m13, m14, m15
    
  Next Ent
  
  Close #1End Function
Sub Main()
  CadToTxtForLineAndArc ("D:\Temp.txt")
      Dim gg As ADODB.Recordset
    Dim Sql As String
    Dim a1 As String, a2 As String
    ii = 2
    Sql = " Select  m1,m2,m3,x1,y1,z1,x2,y2,z2 from temp.txt "
    Set gg = RecordsetToExcel(Sql)  Dim xlSheet  Set xlSheet = ConnectExcel("Sheet2")
 With xlSheet
    .Range("a:z").ClearContents
    
    cc1 = 3
    .Cells(1, 1 + cc1) = "x1": .Cells(1, 2 + cc1) = "y1": .Cells(1, 3 + cc1) = "z1":
    cc1 = 6
    .Cells(1, 1 + cc1) = "x2": .Cells(1, 2 + cc1) = "y2": .Cells(1, 3 + cc1) = "z2":
    
'    .Range("A2").CopyFromRecordset gg
 End With
 
  Set xlSheet = ConnectExcel("Sheet1")
  ii = 2
 With xlSheet
    .Range("a:z").ClearContents
    .Cells(1, 1) = "m1": .Cells(1, 2) = "m2": .Cells(1, 3) = "m3":
    cc1 = 3
    .Cells(1, 1 + cc1) = "x1": .Cells(1, 2 + cc1) = "y1": .Cells(1, 3 + cc1) = "z1":
    cc1 = 6
    .Cells(1, 1 + cc1) = "x2": .Cells(1, 2 + cc1) = "y2": .Cells(1, 3 + cc1) = "z2":
    gg.MoveFirst
    .Cells(ii, 1).CopyFromRecordset gg
    .Cells(1, 15) = "rr":
 End With
  
  For ii = 1 To gg.RecordCount
    gg.MoveFirst
    CC = 3
    a1 = gg.Fields(CC + 3):  a2 = gg.Fields(CC + 4)
    
    a3 = gg.Fields(CC + 0):  a4 = gg.Fields(CC + 1)
    Sql = " Select  m1,m2,m3,x1,y1,z1,x2,y2,z2,m10,m11,m12 , m13, m14, m15 from Temp.txt "
    Sql = Sql & " where x1 = " & a1 & " and y1 = " & a2
    Sql = Sql & " and x2 <> " & a3 & " and y2 <> " & a4
    Set gg = RecordsetToExcel(Sql)    If gg.RecordCount = 0 Then
      Sql = " Select  m1,m2,m3,x2,y2,z2,x1,y1,z1,m10,m11,m12, m13, m14, m15 from Temp.txt "
      Sql = Sql & " where x2 = " & a1 & " and y2 = " & a2
      Sql = Sql & " and x1 <> " & a3 & " and y1 <> " & a4
      Set gg = RecordsetToExcel(Sql)
    End If
    'Debug.Print gg.RecordCount
    With xlSheet
      .Cells(ii + 1, 1).CopyFromRecordset gg '复制符合条件的记录
    End With
Next ii
 
  
End SubFunction RecordsetToExcel(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
  'Sheet1.Range("A2").CopyFromRecordset rsEnd FunctionFunction ConnectExcel(InputSheetName As String) As Object
   Dim xlApp As Object
   On Error Resume Next
   Set xlApp = GetObject(, "Excel.Application")
   Set ConnectExcel = xlApp.ActiveWorkbook.Sheets(InputSheetName)
End FunctionSub abab()
  Set ee = ConnectExcel("Sheet1")
  Dim lineObj As AcadLine, arcObj As AcadArc
  Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, pppp(0 To 2) As Double
  Dim app(0 To 2) As Double
  With ee
    For ii = 2 To 21
      Select Case Trim(.Cells(ii, 1))
        Case "AcDbLine"
          Debug.Print .Cells(ii, 2)
          Set lineObj = ThisDrawing.HandleToObject(.Cells(ii, 2))
          For jj = 0 To 2
            pp(jj) = .Cells(ii, jj + 4).Value
            ppp(jj) = .Cells(ii, jj + 7).Value
          Next jj
          lineObj.StartPoint = pp: lineObj.EndPoint = ppp
          lineObj.color = 1
        Case "AcDbArc"
          Set arcObj = ThisDrawing.HandleToObject(.Cells(ii, 2))  
            arcObj.Delete   
      End Select
    Next ii
  End With
End Sub
Function ReturnExcelRecordset(Sql) As ADODB.Recordset
   Dim cnn As New ADODB.Connection
   Dim rs As New ADODB.Recordset
   Dim ws As Worksheet
   Dim myWbName As String, mySheet As String
   Dim CnnStr As String ', Sql As String, n As Integer
   CnnStr = "Provider=microsoft.jet.oledb.4.0;" _
        & "Extended Properties=Excel 8.0;" _
        & "Data Source=" & "d:\ls.xls"
    'cnn.Open CnnStr
    'Sql = " Select  * from [sheet1$]  where lcase(a2) in ('doc','xls','jpg','wmf') "
    rs.Open Sql, CnnStr, adOpenKeyset, adLockOptimistic
    
    Set ReturnExcelRecordset = rs
    'rs.Close
    Set rs = Nothing
    'Set CnnStr = Nothing
    'Set ws = Nothing
End FunctionSub bb()
    Dim gg As ADODB.Recordset, g As ADODB.Recordset
    Sql = " Select  x1,y1,z1,x2,y2,z2,rr from [sheet1$] "
    Sql = Sql & " where m1 = 'AcDbArc' "    Set gg = ReturnExcelRecordset(Sql)
    gg.MoveFirst    For ii = 0 To gg.RecordCount - 1
      'Debug.Print gg(0), gg(1), gg(2), gg(3), gg(4), gg(5)
      ThisDrawing.SendCommand "fillet" & Chr(10) & "R" + Chr(10) & Trim(Str(gg(6))) & Chr(10) & Chr(10)
      Debug.Print "fillet" & Chr(10) & "R" + Chr(10) & Str(gg(6)) & Chr(10) & Chr(10)
      Sql = " Select  m2 as mm from [sheet1$] "
      Sql = Sql & " where m1 = 'AcDbLine'"
      Sql = Sql & " and x2 = " & gg(0)
      Sql = Sql & " and y2 = " & gg(1)
      Sql = Sql & " and z2 = " & gg(2)
      Sql = Sql & " union all "
      
      Sql = Sql & " Select  m2 from [sheet1$] "
      Sql = Sql & " where m1 = 'AcDbLine'"
      Sql = Sql & " and x1 = " & gg(3)
      Sql = Sql & " and y1 = " & gg(4)
      Sql = Sql & " and z1 = " & gg(5)
      
      'Debug.Print Sql
      Set ggg = ReturnExcelRecordset(Sql)
      ggg.MoveFirst
      cccc = "fillet" + Chr(10)
      For jj = 0 To ggg.RecordCount - 1
        cccc = cccc & "(handent " & Chr(34) & ggg(0) & Chr(34) & ")" & Chr(10)
        ggg.MoveNext
      Next jj
      'Debug.Print cccc
      '''
      
            ThisDrawing.SendCommand cccc
      
      ''
      gg.MoveNext
    Next ii
    
End Sub