[讨论]怎样提高VB+SQL数据处理速度

laoxie_198

我用VB将CAD图形中的图元信息写入到SQL中，当数据量大的时候感觉特慢，请问有什么方法优化吗？下面是我的代码：

Option Explicit

Dim acadApp As AcadApplication     

Dim acadDoc As AcadDocument       

'Dim acaddoc As AcadModelSpace
Const LB_ITEMFROMPOINT = &H1A9

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
        (ByVal hWnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Any) As Long
Private Sub Command1_Click()
'On Error Resume Next

    Set acadApp = GetObject(, "AutoCAD.Application.16")
    If Err Then
      MsgBox "AUTOCAD图形软件未打开！"
      End
    End If
   

    If Err Then
        Err.Clear
        ' 创建一个新的AutoCAD应用程序对象
        Set acadApp = CreateObject("AutoCAD.Application.16")
       
        If Err Then
            MsgBox Err.Description
            Exit Sub
        End If
    End If
   
    ' 显示AutoCAD应用程序
    acadApp.Visible = True
    Set acadDoc = acadApp.ActiveDocument
    Dim cn As New ADODB.Connection
    acadDoc.SendCommand "zoom" & vbCr & "e" & vbCr

Frame1.Visible = False
Frame2.Visible = False
Command1.Visible = False
Command2.Visible = False
Line2.Visible = False
Line3.Visible = False
Line1.Visible = False
 Dim gdp As New ADODB.Recordset
 Dim gdpp As New ADODB.Recordset
 Dim gdeo As New ADODB.Recordset
 Dim gdpv As New ADODB.Recordset
 Dim gdv33 As New ADODB.Recordset
 Dim gdv3 As New ADODB.Recordset
 Dim gdlp As New ADODB.Recordset
 Dim gg01 As New ADODB.Recordset
 Dim gg03 As New ADODB.Recordset
 Dim tdsyz As String, tdzl As String, qsxz As String, sjyt As String
 Dim sqllj As String, gdv3lj As String, gg01lj As String, gg03lj As String, gdplj As String
 Dim gdlplj, gdpvlj As String
 Dim ftype(0 To 2) As Integer
 Dim fdata(0 To 2) As Variant
 Dim gdsx As Variant
 Dim maxvid, maxvidd As Long, vid As Long, eoid As Long, pid As Long
 Dim maxga01 As String, newga01 As String
 Dim maxpid As Long, newpid As Long, maxvn As Long, newvn As Long
 Dim zdpx(), zdpxgd(), t() As Variant '宗地排序数组
 Dim jfmj As Double '街坊面积
 Dim ltime As String
 Dim djh, zdh, jfh As String
 Dim zds As Integer '宗地数
 sjyt = Trim(Text7.Text)
 tdsyz = Trim(Text6.Text)
 qsxz = Trim(Text8.Text)
 
 ltime = Date + Time
 ftype(0) = 0: fdata(0) = "LWPOLYLINE"
 ftype(1) = 8: fdata(1) = "界址线"
 ftype(2) = 70: fdata(2) = 1
 'ftype(2) = 70: fdata(2) = 1
 Dim ddzb() As Double '顶点坐标
 Dim dds, mode, jzds As Integer
 Dim zb As Variant
 Dim i As Integer
 sqllj = "provider=sqloledb.1;password=" & Text4.Text & " ;persist security info=true;user id=" & Trim(Text3.Text) & ";initial catalog=" & Text2.Text & " ;data source=" & Text1.Text & ""
 cn.Open sqllj
 jfh = Trim(Text5.Text)
   gdv3lj = "select maxvid=max(vid) from gdv3"
  gdv3.Open gdv3lj, cn, adOpenForwardOnly, adLockBatchOptimistic
  Do While Not gdv3.EOF
    maxvid = gdv3.Fields("maxvid")
    gdv3.MoveNext
  Loop
gdv3.Close

gdplj = "select maxpid=max(pid), js=count(pid) from gdp"
gdp.Open gdplj, cn, adOpenForwardOnly, adLockBatchOptimistic
If Not gdp.EOF Then
If gdp.Fields("js") > 0 Then
 maxpid = gdp.Fields("maxpid")
 Else
 maxpid = 0
 End If
End If
gdp.Close

 gg01.Open "select maxga01=max(ga01)from gg01 where ga01 like '200%'", cn, adOpenForwardOnly, adLockBatchOptimistic
 If Not gg01.EOF Then
   'If gg01.Fields("maxga01") <> Null Then
    maxga01 = gg01.Fields("maxga01")
  ' Else
  ' maxga01 = "2007320506100000"
  ' End If
  
 End If
  gg01.Close
 
   newga01 = pdga01(maxga01)
  gdeo.Open "select * from gdeo where description like  " & jfh & " ", cn, adOpenForwardOnly, adLockBatchOptimistic
 If Not gdeo.EOF Then
    eoid = gdeo.Fields("eoid")
    Else
    MsgBox "数据库中没有本街坊信息、请查实！“"
    End
  End If
 gdeo.Close

   gdv3lj = "select maxvn=max(vn) , js =count(vn)from gdv3 where eoid=" & eoid & " and vt='100' and vid in (select pvid from gdpv where pid in (select lpid from  gdlp where isvirtual=0))"

  gdv3.Open gdv3lj, cn, adOpenForwardOnly, adLockBatchOptimistic
  If Not gdv3.EOF Then
   If gdv3.Fields("js") > 0 Then
    maxvn = gdv3.Fields("maxvn")
    End If
    'gdv3.MoveNext
  End If
gdv3.Close

 i = 0
On Error Resume Next
   Dim xzj As AcadSelectionSet
   If Not IsNull(acadDoc.SelectionSets.Item("st")) Then
     Set xzj = acadDoc.SelectionSets.Item("st")
     xzj.Delete
     End If
  Set xzj = acadDoc.SelectionSets.Add("st") '新建选择集
  'MsgBox xzj.Name
  xzj.Select acSelectionSetAll, , , ftype, fdata '选择宗地
  ReDim zdpxgd(xzj.count - 1, 3)
  'ReDim zdpxgd(xzj.Count - 1, 1)
  ReDim t(xzj.count - 1, 3)
  If xzj.count = 0 Then
   MsgBox "没有界址线!"
   End
 Else
  Dim ty As AcadEntity
  For Each ty In xzj
   If ty.Close = True Then
  dds = (UBound(ty.Coordinates) + 1) / 2
  zb = ty.Coordinates
  jfmj = ty.Area
    ReDim ddzb(dds * 3 - 1)
    ReDim sjzb(dds - 1, 1)
    For i = 0 To dds - 1
    'MsgBox ty.Coordinates(2 * i)
    ddzb(3 * i) = zb(2 * i)
    ddzb(3 * i + 1) = zb(2 * i + 1)
    ddzb(3 * i + 2) = 0
    sjzb(i, 0) = zb(2 * i)
    sjzb(i, 1) = zb(2 * i + 1)
    Next i
gdsx = tqjfh(ddzb)
zdh = gdsx(0)
tdzl = gdsx(1)
 If zdh <> "" Then
 jfh = Trim(Text5.Text)
 djh = jfh + zdh
 'newpid = maxpid + 1
zdpxgd(zds, 0) = zdh
zdpxgd(zds, 1) = ddzb
zdpxgd(zds, 2) = jfmj
zdpxgd(zds, 3) = tdzl
zds = zds + 1
End If
Else
 MsgBox "本宗地界址线没有封闭！请检查!"
 End If
  Next
  End If
  '以上提取宗地号和宗地界址线坐标表。
  '以下对宗地号由大到小排序。
  Dim sd, sdd, j, ii As Integer
For i = 1 To zds - 1
  For j = i - 1 To zds - 1
   sd = Val(zdpxgd(i - 1, 0))
   sdd = Val(zdpxgd(j, 0))
  If sd > sdd Then
    t(i, 0) = zdpxgd(i - 1, 0)
    t(i, 1) = zdpxgd(i - 1, 1)
    t(i, 2) = zdpxgd(i - 1, 2)
    t(i, 3) = zdpxgd(i - 1, 3)
    zdpxgd(i - 1, 0) = zdpxgd(j, 0)
    zdpxgd(i - 1, 1) = zdpxgd(j, 1)
    zdpxgd(i - 1, 2) = zdpxgd(j, 2)
    zdpxgd(i - 1, 3) = zdpxgd(j, 3)
    zdpxgd(j, 0) = t(i, 0)
    zdpxgd(j, 1) = t(i, 1)
    zdpxgd(j, 2) = t(i, 2)
    zdpxgd(j, 3) = t(i, 3)
    End If
 Next j
 Next i
  '宗地号由小到大排序完毕。
 ' newga01 = pdga01(maxga01)
 '新增宗地数据开始上传
Bar1.Top = 1300
  Bar1.Width = 2500
  Bar1.Left = 1000
  Bar1.Min = 0
  Bar1.Max = zds
 For ii = 0 To zds - 1
  'newpid = maxpid + 1
Bar1.Value = ii
 
  djh = jfh + zdpxgd(ii, 0)
  gdplj = "select * from gdp where pid in (select ga33 from gg01 where ga18 = '" & djh & "' )"
  gdp.Open gdplj, cn, adOpenDynamic, adLockPessimistic
  If gdp.EOF Then
  'cn.Execute "set identity_insert gdp on"
  'cn.Execute "insert into gdp  values( " & newpid & ", '100' ,'" & zdpxgd(ii, 0) & " '," & eoid & " ,0,0,0,0.0,0.0,0,0.0, 0,'" & ltime & " '," & zdpxgd(ii, 2) & ",1)"
  cn.Execute "insert into gdp  values( '100' ,'" & zdpxgd(ii, 0) & " '," & eoid & " ,0,0,0,0.0,0.0,0,0.0, 0,'" & ltime & " '," & zdpxgd(ii, 2) & ",1)"
  gdpp.Open "select maxpid=max(pid) from gdp ", cn, adOpenDynamic, adLockPessimistic
  If Not gdpp.EOF Then
     newpid = gdpp.Fields("maxpid")
  End If
  gdpp.Close
  cn.Execute "insert into gdlp values(" & newpid & ",'" & sjyt & "','" & tdsyz & "','" & newga01 & "',1,0,0.0,0.0,1)"
  'cn.Execute "insert into gg01 values( '" & newga01 & " ','0','','','" & Left(djh, 6) & " ','" & Mid(djh, 7, 3) & " ','" & Mid(djh, 10, 3) & " ','" & zdh & " ','" & ltime & " ','002','','','','','','','','','','','','" & djh & " ',' ',' ',' ','0','0',' ',' ',' ',' ','Y',0,0,'',0," & maxpid + 1 & ",' Y ',0,0,0,'" & jmj & "',0,'','0',0)"
  gg01.Open "select * from gg01", cn, adOpenDynamic, adLockPessimistic
 ' If gg01 Then
   gg01.AddNew
    gg01.Fields("ga01") = newga01
    gg01.Fields("ga02") = "0"
    gg01.Fields("ga03") = tdsyz
    gg01.Fields("ga031") = Left(djh, 6)
    gg01.Fields("ga032") = Mid(djh, 7, 3)
    gg01.Fields("ga033") = Mid(djh, 10, 3)
    gg01.Fields("ga034") = zdpxgd(ii, 0)
    gg01.Fields("ga04") = ""
    gg01.Fields("ga05") = ltime
    gg01.Fields("ga051") = "002"
    gg01.Fields("ga06") = ""
    gg01.Fields("ga07") = ""
    gg01.Fields("ga08") = zdpxgd(ii, 3)
    gg01.Fields("ga09") = ""
    'gg01.Fields("ga10") = ""
    gg01.Fields("ga11") = ""
    gg01.Fields("ga12") = ""
    gg01.Fields("ga13") = ""
    gg01.Fields("ga14") = ""
    gg01.Fields("ga15") = ""
    gg01.Fields("ga16") = "1"
    gg01.Fields("ga17") = ""
    gg01.Fields("ga18") = Left(djh, 6) + Mid(djh, 7, 3) + Mid(djh, 10, 3) + zdpxgd(ii, 0)
    gg01.Fields("ga19") = ""
    gg01.Fields("ga21") = Null
    gg01.Fields("ga22") = Null
    gg01.Fields("ga23") = 0
    gg01.Fields("ga24") = Val(sjyt)
    gg01.Fields("ga25") = ""
    gg01.Fields("ga251") = ""
    gg01.Fields("ga26") = ""
    gg01.Fields("ga27") = ""
    gg01.Fields("ga28") = "Y"
    gg01.Fields("ga29") = ""
    gg01.Fields("ga30") = 0
    gg01.Fields("ga31") = ""
    gg01.Fields("ga32") = "N"
    gg01.Fields("ga33") = newpid
    gg01.Fields("ga34") = "Y"
    gg01.Fields("ga35") = Null
    gg01.Fields("ga36") = Null
    gg01.Fields("ga37") = Null
    gg01.Fields("ga221") = zdpxgd(ii, 2)
    gg01.Fields("ga222") = Null
    gg01.Fields("ga38") = Null
    gg01.Fields("ga39") = Null
    gg01.Fields("ga381") = Null
   gg01.Update
   gg01.MoveNext
  'End If
  
  gg01.Close
 
  zb = zdpxgd(ii, 1)
 jzds = (pdws(zb) + 1) / 3
  For i = 0 To jzds - 1
 ' For i = 0 To zdpxgd(ii, 1).cone
  gdv3lj = "select * from gdv3 where x=" & zb(3 * i + 1) & " and y= " & zb(3 * i) & " and vt=100"
  gdv3.Open gdv3lj, cn, adOpenForwardOnly, adLockBatchOptimistic
 
  If Not gdv3.EOF Then
    vid = gdv3.Fields("vid")
    newvn = gdv3.Fields("vn")
  Else
     vid = maxvid + 1
     newvn = maxvn + 1
     maxvn = maxvn + 1
      cn.Execute "set identity_insert gdv3 on"
      cn.Execute "insert into gdv3  values ( " & eoid & ",' " & newvn & "'," & zb(3 * i + 1) & "," & zb(3 * i) & ",0,2,1,1,0,'" & ltime & "',100)"
  End If
   gdv33.Open "select maxvid=max(vid) from gdv3 ", cn, adOpenForwardOnly, adLockBatchOptimistic
   If Not gdv33.EOF Then
     maxvidd = gdv33.Fields("maxvid")
     If maxvidd > maxvid Then
        vid = maxvidd
     End If
     maxvid = maxvidd
     End If
     gdv33.Close
  
   ' cn.Execute "set identity_insert gdeov on"
     
    cn.Execute "insert into gdpv  values (" & newpid & "," & i + 1 & "," & vid & ")"
    cn.Execute "insert into gg03 values (" & newga01 & "," & i + 1 & "," & i + 1 & " ," & newvn & ",null,4,null,null,2,3,null)"
  ' maxvid = maxvid + 1
   'maxvn = maxvn + 1
  gdv3.Close
  Next
 
  maxpid = maxpid + 1
  newga01 = pdga01(newga01)
   'MsgBox ty.ObjectName

   End If 'If gdp.EOF Then
   gdp.Close
  Next
  MsgBox "数据上传完毕！"
  End
  End
   
   
   
   
End Sub

Function tqjfh(xxzb) As Variant  '提取宗地号、土地坐落
 On Error Resume Next
 Dim jfh(0 To 1) As String
  Dim zjxzj As AcadSelectionSet
     If Not IsNull(acadDoc.SelectionSets.Item("zjst")) Then
     Set zjxzj = acadDoc.SelectionSets.Item("zjst")
     zjxzj.Delete
     End If
  Set zjxzj = acadDoc.SelectionSets.Add("zjst") '新建选择集
  Dim ftype As Variant, fdata As Variant
  Call creatssetfilter(ftype, fdata, 0, "Text", 8, "宗地注记,土地座落")
  'ReDim gpCode(0 To 1) As Integer
    ''gpCode(0) = 0
    ''gpCode(1) = 8
   '' ReDim dataValue(0 To 1) As Variant
    ''dataValue(0) = "TEXT"
   '' dataValue(1) = "宗地注记"
   
   '' Dim groupCode As Variant, dataCode As Variant
   '' groupCode = gpCode
   '' dataCode = dataValue
   
    zjxzj.SelectByPolygon acSelectionSetWindowPolygon, xxzb, ftype, fdata
    If zjxzj.count = 0 Then
     MsgBox "没有宗地号，请检查！"
    ' End
     Else
    
    'zjxzj.SelectByPolygon acSelectionSetWindowPolygon, pointsArray, groupCode, dataCode
    If zjxzj.Item(0).Layer = "宗地注记" Then
       jfh(0) = zjxzj.Item(0).TextString  '
       jfh(1) = zjxzj.Item(1).TextString
       Else
       jfh(1) = zjxzj.Item(0).TextString  '
       jfh(0) = zjxzj.Item(1).TextString
       End If
      
  End If
 
  '以上提取街坊坐标和街坊号
tqjfh = jfh
zjxzj.Delete
End Function
Function pdga01(maxga01) As String '判断调查表号
Dim hm As String
hm = Val(Str$(Right(maxga01, 6)) + 1)
Select Case Len(hm)
  Case 1: hm = "00000" + hm
  Case 2: hm = "0000" + hm
  Case 3: hm = "000" + hm
  Case 4: hm = "00" + hm
  Case 5: hm = "0" + hm
  End Select
pdga01 = Left(maxga01, 10) + hm

End Function
Function pdws(mArray As Variant) As Integer
Dim i As Integer
Dim Ret As Integer
Dim ErrF As Boolean
Dim arrayrange As Integer
ErrF = False
On Error GoTo ErrHandle
'判断代入的参数是否为数组
If Not IsArray(mArray) Then
pdws = -1
Exit Function
End If
'VB中数组最大为60
For i = 1 To 60
'用UBound函数判断某一维的上界，如果大数组的实际维数时产生超出范围错误，
' 此时我们通过Resume Next 来捕捉错这个错误
Ret = UBound(mArray, i)
If ErrF Then Exit For
Next i
'最后返回
arrayrange = Ret
Exit Function
ErrHandle:
'Ret = i - 1
'ErrF = True
'Resume Next
pdws = Ret
End Function

Private Sub CommandButton2_Click()
End
End Sub

Private Sub Command2_Click()
End
End Sub
Public Sub creatssetfilter(ByRef filtertype As Variant, ByRef filterdata As Variant, ParamArray filter()) '选择集过滤器
If UBound(filter) Mod 2 = 0 Then
 MsgBox "filter 参数无效"
  Exit Sub
End If
Dim ftype() As Integer
Dim ftada() As Variant
Dim count As Integer
count = (UBound(filter) + 1) / 2
ReDim ftype(count - 1)
ReDim fdata(count - 1)
Dim i As Integer
For i = 0 To count - 1
  ftype(i) = filter(2 * i)
  fdata(i) = filter(2 * i + 1)
  Next i
  filtertype = ftype
  filterdata = fdata
End Sub

idoo

不了解，帮顶