|
|
Private Sub cmdCreate_Click()
Dim CADAppobj As AcadApplication
Dim CADDocument As AcadDocument
Dim LayerObj As AcadLayer
Dim PointObj As AcadPoint
Dim TextObj As AcadText
Dim Location(0 To 2) As Double
Dim textPoint(0 To 2) As Double
Dim sysVarName As String
Dim sysVarData As Integer
Dim strSQL As String
Dim strFile As String
Dim strName As String
Dim rs As ADODB.Recordset
Dim rsType As ADODB.Recordset
Dim I As Integer
Dim J As Integer
On Error GoTo EndForm
If m_CurLandType 0 Then
'创建文件
Screen.MousePointer = vbHourglass
DoEvents
strName = cboLandType.Text & "样点"
' strFile = App.Path & "\" & strName & ".dwg"
Set CADAppobj = New AcadApplication
CADAppobj.Documents.Close
Set CADDocument = CADAppobj.Documents.Add
Set LayerObj = CADDocument.Layers.Add(strName)
CADDocument.ActiveLayer = LayerObj
CADDocument.Activate
sysVarName = "PDMODE"
sysVarData = 2
CADDocument.SetVariable sysVarName, sysVarData
SetForegroundWindow Me.hwnd
SetAPIFocus Me.hwnd
'写入数据
J = 1
pBar.Max = 1
strSQL = "Select * From Ext_Type_Define Where Table_ID=1"
Set rsType = m_Cnn.Execute(strSQL)
Do While Not rsType.EOF
strSQL = "Select Samples_ID,Sam_Code,Sam_CoordX,Sam_CoordY From Samples_" & _
rsType!Type_ID & " Where Land_Type_ID=" & m_CurLandType & " Order by Samples_ID"
Set rs = m_Cnn.Execute(strSQL)
pBar.Max = rs.RecordCount + pBar.Max
rsType.MoveNext
Loop
rsType.MoveFirst
Do While Not rsType.EOF
strSQL = "Select Samples_ID,Sam_Code,Sam_CoordX,Sam_CoordY From Samples_" & _
rsType!Type_ID & " Where Land_Type_ID=" & m_CurLandType & " Order by Samples_ID"
Set rs = m_Cnn.Execute(strSQL)
For I = 1 To rs.RecordCount
If Not IsNull(rs!Sam_CoordX) And Not IsNull(rs!Sam_CoordY) Then
Location(0) = rs!Sam_CoordX
Location(1) = rs!Sam_CoordY
Location(2) = 0
Set PointObj = CADDocument.ModelSpace.AddPoint(Location)
PointObj.Color = acRed
textPoint(0) = Location(0) + 25
textPoint(1) = Location(1) - 28
textPoint(2) = 0
Set TextObj = CADDocument.ModelSpace.AddText(CStr(rs!sam_Code), textPoint, 50)
TextObj.Color = acGreen
End If
pBar.Visible = True
pBar.Value = pBar.Value + 1
Label3.Visible = True
Label3.Caption = "已转出:" & J & "个样点"
J = J + 1
rs.MoveNext
Next I
rsType.MoveNext
Loop
MsgBox "共转出" & J - 1 & "个样点", vbInformation, "提示"
CADDocument.SaveAs Text2.Text
txtCreate.Text = txtCreate.Text & "成功创建" & Text2.Text & vbCrLf
CADAppobj.Quit
DoEvents
Screen.MousePointer = vbDefault
End If
Exit Sub
EndForm:
txtCreate.Text = txtCreate.Text & "！ERROR 失败创建" & strFile & vbCrLf & "Record=" & J
End Sub
提示：compile error can't find project or library错误怎么解决，我是菜鸟，请高手指点。 |
|
置顶卡
