vb 提高效率 包括访问数据库效率

先看代码Private Sub Command3_Click()
Dim myDGN As DesignFile
Set myDGN = OpenDesignFile("D:\wei\友爱南路.dwg")
myDGN.SaveAs "D:\wei\友爱南路.dgn", True, msdDesignFileFormatV8
Set myDGN = OpenDesignFile("D:\wei\友爱南路.dgn")
  
  '修改层名
   Dim lvl As Level
   Set lvl = myDGN.Levels("KZD")
   lvl.Name = "层1"
   Set lvl = myDGN.Levels("JMD")
   lvl.Name = "层2"
   Set lvl = myDGN.Levels("DLDW")
   lvl.Name = "层3"
   Set lvl = myDGN.Levels("DLSS")
   lvl.Name = "层4"
   Set lvl = myDGN.Levels("GXYZ")
   lvl.Name = "层5"
   Set lvl = myDGN.Levels("SXSS")
   lvl.Name = "层6"
   Set lvl = myDGN.Levels("JJ")
   lvl.Name = "层7"
   Set lvl = myDGN.Levels("DMTZ")
   lvl.Name = "层8"
   Set lvl = myDGN.Levels("ZBTZ")
   lvl.Name = "层9"   myDGN.Levels.RewriteDim pEle As Element
Dim pEleenum As ElementEnumeratorSet pEleenum = myDGN.DefaultModelReference.Scan()Dim xlConn As New ADODB.ConnectionDim strConn As String
Dim xlRs As New ADODB.Recordset
  
'连接数据库的字符串
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= 'D:\wei2\zhou3\最终对应表改.xls';Extended Properties='Excel 8.0;HDR=yes;IMEX=1'"
'打开Excel连接
xlConn.Open strConn
  '循环选择集
   While pEleenum.MoveNext
    Set pEle = pEleenum.Current
    Set xlRs = New ADODB.Recordset
  
  '像打开数据库一样，使用SQL语言，打开名称为“sheet1”的工作表
    xlRs.Open "select 中心编码,中心线型,中心线宽,中心色索引 from [sheet1$] where CASS地物编码 LIKE '" + myGetXData(pEle, "SOUTH") + "'", xlConn, adOpenStatic, adLockReadOnly
    
    If Len(xlRs("中心编码")) <> 0 Then
       pEle.Color = xlRs("中心色索引")
       pEle.LineWeight = xlRs("中心线宽")
       pEle.Rewrite
   End If
     xlRs.Close
   Wend
  MsgBox "OK!"
  xlConn.Close
  Set pEle = Nothing
  Set pEleenum = Nothing
myDGN.Save
 
myDGN.Close
Set xlRs = Nothing
Set xlConn = Nothing
Set myDGN = Nothing
End Sub这段代码运行2分29秒，速度有点慢了，感觉上是遍历的元素过多几万个应该有，而且每次循环都要执行SQL访问Excel表，不知道能否提高下这个访问的效率