module1.bas

工程中人工提取图形属性非常麻烦。该程序自动将AutoCAD中的图形属性提取出来

Attribute VB_Name = "Module1"
Public AcadApp As AcadApplication
Public AcadDoc As Object
Public moSpace As Object
Public paSpace As Object
Public ExcelApp As Object
Public ExcelSheet As Object
Public WorkSheets As Object
Public Blag As Integer

Public Pt1 As Variant
Public P(0 To 2) As Double
Public H As Double
Public PntNm As String
Public returnObj As AcadObject
Public BasePnt As Variant

Public PageCount As Integer
'定义全局变量车号，车位面积
Public Nm As String
Public Area As Double


Sub Main()
On Error Resume Next
''检测并打开AUTOCAD2004
Set AcadApp = GetObject(, "AutoCAD.Application.16")
If Err Then
  Err.Clear
  Set AcadApp = CreateObject("AutoCAD.Application.16")

  If Err Then
     MsgBox Err.Description
     Exit Sub
  End If
End If
Set AcadDoc = AcadApp.ActiveDocument
Set moSpace = AcadDoc.ModelSpace
Set paSpace = AcadDoc.PaperSpace
AcadApp.Visible = True
AcadApp.WindowState = acMax


''检测并打开excel表格
'    Dim xlApp As Excel.Application
'    Set xlApp = GetObject(, "excel.Application")
    
    
    
Set ExcelApp = GetObject(, "Excel.Application")
If Err Then
  Err.Clear
  Set ExcelApp = CreateObject("Excel.Application")

  If Err Then
     MsgBox Err.Description
     Exit Sub
  End If
End If

Set ExcelSheet = ExcelApp.WorkSheets.Add
ExcelSheet.Active
ExcelSheet.Name = "普通工程测量成果表"

'Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets("Sheet1")
ExcelApp.Visible = True
ExcelApp.WindowState = acMax
'    If Err Then
'    Err.Clear
'    Set xl = CreateObject("Excel.Sheet")
'       If Err Then
'          MsgBox Err.Description
'          Exit Sub
'          MsgBox " Excel 应用程序没有运行。请启动 Excel 并重新运行程序。"
'        Exit Sub
'        End If
'    End If

FrmMain.Show

End Sub



' 磅换算成毫米
Function PToM(ByVal Points As Double) As Double
    PToM = Points * 0.3527778
End Function

Function PointAndNameToExcel(ByVal Nm As String, ByVal S1 As Variant, ByVal S2 As Variant) As Variant

With ExcelSheet.Application
'If Blag = 1 Then
.ActiveCell.Value = Nm
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = S1
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = S2
.ActiveCell.Offset(1, -2).Activate
'Blag = 2
'ElseIf Blag = 2 Then

'.ActiveCell.Offset(1, -1).Activate
'Blag = 1
'End If

End With


End Function
Function PointAndNameToTemplate(ByVal Nm As String, ByVal S1 As Variant, ByVal S2 As Variant, ByVal H As Double) As Variant

With ExcelSheet.Application
'If Blag = 1 Then
.ActiveCell.Value = Nm
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = S1
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = S2
.ActiveCell.Offset(1, -2).Activate
'Blag = 2
'ElseIf Blag = 2 Then

'.ActiveCell.Offset(1, -1).Activate
'Blag = 1
'End If

End With


End Function
Function StringsToTemplate(ByVal Nm As String, ByVal Area As Double) As Variant

With ExcelSheet.Application
'If Blag = 1 Then
.ActiveCell.Value = Nm
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = Area
.ActiveCell.Offset(1, -1).Activate

'Blag = 2
'ElseIf Blag = 2 Then

'.ActiveCell.Offset(1, -1).Activate
'Blag = 1
'End If

End With


End Function
Function PointToExcel(ByVal S1 As Variant, ByVal S2 As Variant) As Variant

With ExcelSheet.Application
'If Blag = 1 Then
.ActiveCell.Value = S1
.ActiveCell.Offset(0, 1).Activate
.ActiveCell.Value = S2
.ActiveCell.Offset(1, -1).Activate
'Blag = 2
'ElseIf Blag = 2 Then

'.ActiveCell.Offset(1, -1).Activate
'Blag = 1
'End If

End With


End Function
Function NameToExcel(ByVal Nm As String) As Variant

With ExcelSheet.Application
'If Blag = 1 Then
.ActiveCell.Value = Nm
.ActiveCell.Offset(1, 0).Activate

'Blag = 2
'ElseIf Blag = 2 Then

'.ActiveCell.Offset(1, -1).Activate
'Blag = 1
'End If

End With


End Function

Sub Get_String()

    AcadDoc.Utility.GetEntity returnObj, BasePnt, "Select an object"
    
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Sub
    Else
        returnObj.Update
        PntNm = returnObj.TextString
        
'        MsgBox "The object type is: " & returnObj.EntityName, , "GetEntity Example"
        returnObj.Update
    End If
    
  
End Sub
Sub Get_NmandArea()

    AcadDoc.Utility.GetEntity returnObj, BasePnt, "Select an object"
    
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Sub
    Else
        returnObj.Update
        Nm = returnObj.TextString
        
'        MsgBox "The object type is: " & returnObj.EntityName, , "GetEntity Example"
        returnObj.Update
    End If
    
        AcadDoc.Utility.GetEntity returnObj, BasePnt, "Select an object"
    
    If Err <> 0 Then
        Err.Clear
        MsgBox "Program ended.", , "GetEntity Example"
        Exit Sub
    Else
        returnObj.Update
        Area = returnObj.TextString
        
'        MsgBox "The object type is: " & returnObj.EntityName, , "GetEntity Example"
        returnObj.Update
    End If
    
  
End Sub
Sub Get_Point()
   Pt1 = AcadDoc.Utility.GetPoint(, vbCrLf & "First point: ")
   P(0) = Pt1(0): P(1) = Pt1(1)

End Sub


Function Load_Template(ByVal PageCount As Integer)
 
Dim I As Integer
Dim Myrange As Object
Dim J As Integer
Dim RowCount As Integer

With ExcelSheet.Application

RowCount = (PageCount - 1) * 47

''设置行高
.WorkSheets(1).Rows(1 + RowCount).RowHeight = 30
.WorkSheets(1).Rows(2 + RowCount).RowHeight = 24
For I = 3 + RowCount To 18 + RowCount
.WorkSheets(1).Rows(I).RowHeight = 12
Next I
For I = 44 + RowCount To 47 + RowCount
.WorkSheets(1).Rows(I).RowHeight = 24
Next I

''设置列宽
For J = 3 To 5
.WorkSheets(1).Columns(J).ColumnWidth = 10
Next J
.WorkSheets(1).Columns(1).ColumnWidth = 10
.WorkSheets(1).Columns(2).ColumnWidth = 10
.WorkSheets(1).Columns(6).ColumnWidth = 22

'设置对齐方式和边框

 If PageCount = 1 Then
     Set Myrange = .WorkSheets(1).Range("A2:F47")
ElseIf PageCount = 2 Then
     Set Myrange = .WorkSheets(1).Range("A49:F94")
ElseIf PageCount = 3 Then
     Set Myrange = .WorkSheets(1).Range("A96:F141")
ElseIf PageCount = 4 Then
     Set Myrange = .WorkSheets(1).Range("A143:F188")
ElseIf PageCount = 5 Then
     Set Myrange = .WorkSheets(1).Range("A190:F235")
ElseIf PageCount = 6 Then
     Set Myrange = .WorkSheets(1).Range("A237:F282")
ElseIf PageCount = 7 Then
     Set Myrange = .WorkSheets(1).Range("A284:F329")
ElseIf PageCount = 8 Then
     Set Myrange = .WorkSheets(1).Range("A331:F376")
ElseIf PageCount = 9 Then
     Set Myrange = .WorkSheets(1).Range("A378:F423")
ElseIf PageCount = 10 Then
     Set Myrange = .WorkSheets(1).Range("A425:F470")
Else
   MsgBox ("数据太多!无法处理,详情与软件作者联系!谢谢使用!")

End If

With Myrange
.Font.Size = 10
'.HorizontalAlignment = xlHAlignCenter
'.VerticalAlignment = xlVAlignCenter
.Borders.LineStyle = xlContinuous
'.Borders.Weight = xlThin
'.BorderAround xlContinuous, xlThin
End With
'With .WorkSheets(1).Range("A44:F47")
'.Font.Size = 10
'.HorizontalAlignment = xlHAlignCenter
'.VerticalAlignment = xlVAlignCenter
'.Borders.LineStyle = xlContinuous
'.Borders.Weight = xlThin
'End With

Set Myrange = ExcelSheet.Application.WorkSheets(1).Cells(44 + RowCount, 6)
'Myrange.Borders(xlEdgeTop) = xlLineStyleNone
'Myrange.Borders(xlEdgeTop).LineStyle = xlLineStyleNone



''合并单元格
With .WorkSheets(1)
For I = 3 + RowCount To 18 + RowCount Step 2
  For J = 1 To 6
  If J = 2 Then
  If Not I = 17 + RowCount Then
  .Range(.Cells(I + 1, J), .Cells(I + 2, J)).MergeCells = True
  End If
  
  ElseIf J <> 2 Then
  .Range(.Cells(I, J), .Cells(I + 1, J)).MergeCells = True
  End If
  Next J
Next I

.Range(.Cells(44 + RowCount, 2), .Cells(44 + RowCount, 3)).MergeCells = True
.Range(.Cells(44 + RowCount, 2), .Cells(44 + RowCount, 4)).MergeCells = True
.Range(.Cells(44 + RowCount, 2), .Cells(44 + RowCount, 5)).MergeCells = True
.Range(.Cells(45 + RowCount, 2), .Cells(45 + RowCount, 3)).MergeCells = True
.Range(.Cells(46 + RowCount, 2), .Cells(46 + RowCount, 3)).MergeCells = True
.Range(.Cells(47 + RowCount, 2), .Cells(47 + RowCount, 3)).MergeCells = True
.Range(.Cells(44 + RowCount, 6), .Cells(45 + RowCount, 6)).MergeCells = True
.Range(.Cells(44 + RowCount, 6), .Cells(46 + RowCount, 6)).MergeCells = True
.Range(.Cells(44 + RowCount, 6), .Cells(47 + RowCount, 6)).MergeCells = True
'.Range(.Cells(44, 6)).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
End With



'第一行内容及格式

 If PageCount = 1 Then
     Set Myrange = .WorkSheets(1).Range("A1:F1")
ElseIf PageCount = 2 Then
     Set Myrange = .WorkSheets(1).Range("A48:F48")
ElseIf PageCount = 3 Then
     Set Myrange = .WorkSheets(1).Range("A95:F95")
ElseIf PageCount = 4 Then
     Set Myrange = .WorkSheets(1).Range("A142:F142")
ElseIf PageCount = 5 Then
     Set Myrange = .WorkSheets(1).Range("A189:F189")
ElseIf PageCount = 6 Then
     Set Myrange = .WorkSheets(1).Range("A236:F236")
ElseIf PageCount = 7 Then
     Set Myrange = .WorkSheets(1).Range("A283:F283")
ElseIf PageCount = 8 Then
     Set Myrange = .WorkSheets(1).Range("A330:F330")
ElseIf PageCount = 9 Then
     Set Myrange = .WorkSheets(1).Range("A377:F377")
ElseIf PageCount = 10 Then
     Set Myrange = .WorkSheets(1).Range("A424:F424")
Else
   MsgBox ("数据太多!无法处理,详情与软件作者联系!谢谢使用!")
End If

With Myrange
.Borders.LineStyle = xlLineStyleNone
.Font.Name = "宋体"
.Font.Color = RGB(0, 0, 200)
.Font.Size = 14
.MergeCells = True
'.HorizontalAlignment = xlHAlignCenter
'.VerticalAlignment = xlVAlignCenter
.Value = "普通工程测量成果表"
End With

Set Myrange = Nothing

'第二行内容
With .WorkSheets(1)
.Cells(2 + RowCount, 1).Value = "点号"
.Cells(2 + RowCount, 2).Value = "距离"
.Cells(2 + RowCount, 3).Value = "横坐标（Y）"
.Cells(2 + RowCount, 4).Value = "纵坐标（X）"
.Cells(2 + RowCount, 5).Value = "高程（H）"
.Cells(2 + RowCount, 6).Value = "备注"
End With

''末尾内容填充
With .WorkSheets(1)
.Cells(44 + RowCount, 1).Value = "工程名称"
.Cells(45 + RowCount, 1).Value = "工程编号"
.Cells(45 + RowCount, 4).Value = "填表人"
.Cells(46 + RowCount, 1).Value = "测绘单位"
.Cells(46 + RowCount, 3).Value = "北京华星勘查新技术公司"
.Cells(46 + RowCount, 4).Value = "校对人"
.Cells(47 + RowCount, 1).Value = "主任工程师"
.Cells(47 + RowCount, 4).Value = "日  期"

End With

'设置打印格式
'黑白打印
.WorkSheets("Sheet1").PageSetup.BlackAndWhite = True
'.WorkSheets("Sheet1").PageSetup.PaperSize = xlPaperA4


'页边距
With .WorkSheets(1).PageSetup
    .LeftMargin = ExcelSheet.Application.CentimetersToPoints(1.9)
    .RightMargin = ExcelSheet.Application.CentimetersToPoints(1.9)
    .TopMargin = ExcelSheet.Application.CentimetersToPoints(2)
    .BottomMargin = ExcelSheet.Application.CentimetersToPoints(2)
    .HeaderMargin = ExcelSheet.Application.CentimetersToPoints(1.3)
    .FooterMargin = ExcelSheet.Application.CentimetersToPoints(1.3)
End With


End With


End Function

Sub Example_GetString()
    ' This example demonstrates different ways of returning a string
    ' entered by a user.
    
    Dim returnString As String
    
    ' Prompt & Input cannot contain blanks
    returnString = AcadDoc.Utility.GetString(False, "Enter text (a space or <enter> terminates input): ")
    MsgBox "The string entered was '" & returnString & "'", , "GetString Example"
    
    ' Prompt & Input can contain blanks
    returnString = AcadDoc.Utility.GetString(True, "Enter text (<enter> terminates input):")
    MsgBox "The string entered was '" & returnString & "'", , "GetString Example"
    
    ' Prompt & Input can contain blanks, but not an empty string
    Dim NoNull As Integer
    NoNull = 1    ' Disallow null
    AcadDoc.Utility.InitializeUserInput NoNull
    returnString = AcadDoc.Utility.GetString(True, "Enter text (<enter> terminates input): ")
    MsgBox "The string entered was '" & returnString & "'", , "GetString Example"

End Sub
Sub Example_PickAuto()
    ' This example reads and modifies the preference value that controls
    ' automatic windowing at the Select Objects prompt.
    ' When finished, this example resets the preference value back to
    ' its original value.
    
    Dim ACADPref As AcadPreferencesSelection
    Dim originalValue As Variant, newValue As Variant
    
    ' Get the selection preferences object
    Set ACADPref = AcadDoc.Application.Preferences.Selection
    
    ' Read and display the original value
    originalValue = ACADPref.PickAuto
    MsgBox "The PickAuto preference is set to: " & originalValue

    ' Modify the PickAuto preference by toggling the value
    ACADPref.PickAuto = Not (ACADPref.PickAuto)
    newValue = ACADPref.PickAuto
    MsgBox "The PickAuto preference has been set to: " & newValue

    ' Reset the preference back to its original value
    '
    ' * Note: Comment out this last section to leave the change to
    '         this preference in effect
    ACADPref.PickAuto = originalValue
    MsgBox "The PickAuto preference was reset back to: " & originalValue
End Sub
Sub Example_PickAdd()
    ' This example reads and modifies the preference value that controls
    ' whether objects are added to the selection set using the SHIFT key.
    ' When finished, this example resets the preference value back to
    ' its original value.
    
    Dim ACADPref As AcadPreferencesSelection
    Dim originalValue As Variant, newValue As Variant
    
    ' Get the selection preferences object
    Set ACADPref = AcadDoc.Application.Preferences.Selection
    
    ' Read and display the original value
    originalValue = ACADPref.PickAdd
    MsgBox "The PickAdd preference is set to: " & originalValue

    ' Modify the PickAdd preference by toggling the value
    ACADPref.PickAdd = Not (ACADPref.PickAdd)
    newValue = ACADPref.PickAdd
    MsgBox "The PickAdd preference has been set to: " & newValue

    ' Reset the preference back to its original value
    '
    ' * Note: Comment out this last section to leave the change to
    '         this preference in effect
    ACADPref.PickAdd = originalValue
    MsgBox "The PickAdd preference was reset back to: " & originalValue
End Sub