|
我用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
|
发表于 2008-4-22 07:06:00
置顶卡
变色卡
显身卡