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

laoxie_198 发表于 2008-4-22 07:06:00

我用VB将CAD图形中的图元信息写入到SQL中，当数据量大的时候感觉特慢，请问有什么方法优化吗？下面是我的代码： Option ExplicitDim acadApp As AcadApplication     Dim acadDoc As AcadDocument       'Dim acaddoc As AcadModelSpace Const LB_ITEMFROMPOINT = &H1A9Private 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" & vbCrFrame1.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.Closegdplj = "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 SubFunction 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) + hmEnd 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 FunctionPrivate 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 发表于 2008-4-27 19:15:00

不了解，帮顶

页: [1]

明经CAD社区's Archiver

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