[编程交流] 从ACAD中绘制矩形

Set appAutoCAD = CreateObject("AutoCAD.Application")

myDrawing.Application.Visible = False

_RECTANGLE 0.0,0.0 10.0,10.0
;end of script

Sub WriteToTextFile1()
   Dim iFileNumber                        As Long
   Dim strFileName                        As String
   iFileNumber = FreeFile()
   strFileName = "C:\scr\test.scr"         'name and location of the script file
   Open strFileName For Output As #iFileNumber
   For r = 1 To 2                          'row number of data
   Print #iFileNumber, "rectangle"
   x1 = Cells(r, 1).Value
   y1 = Cells(r, 2).Value
   x2 = Cells(r, 3).Value
   y2 = Cells(r, 4).Value
   Print #iFileNumber, x1 & "," & y1  'first point of rectangel
   Print #iFileNumber, x2 & "," & y2  'second point of rectangle
   Next
   Close #iFileNumber
End Sub

Private Sub CommandButton1_Click()
Pi = 3.14159265358979
UserForm1.Hide
pt1 = ThisDrawing.Utility.GetPoint(, "Pick Lower Left Corner:")
pt2 = ThisDrawing.Utility.PolarPoint(pt1, 0, Val(TextBox1.Text))
pt3 = ThisDrawing.Utility.PolarPoint(pt2, Pi / 2, Val(TextBox2.Text))
pt4 = ThisDrawing.Utility.PolarPoint(pt1, Pi / 2, Val(TextBox2.Text))
ThisDrawing.ModelSpace.AddLine pt1, pt2
ThisDrawing.ModelSpace.AddLine pt2, pt3
ThisDrawing.ModelSpace.AddLine pt3, pt4
ThisDrawing.ModelSpace.AddLine pt4, pt1
ThisDrawing.ModelSpace.AddCircle pt1, Val(TextBox2.Text) / 2
End Sub

Option Explicit
'---------------------------------------------------------------'
' Notes:
' 1. requires settings: Tools -> Options -> General tab -> Error 
trapping field -> check "Break on Unhandled errors"
' 2. requires reference to Microsoft Excel XX.0 Object Library
'---------------------------------------------------------------'
' written by Sccadmember
' Date: Aug/04/06
' [url]http://discussion.autodesk.com/thread.jspa?threadID=489202[/url]
' Just thought I would post this because I have been looking for a working 
VBA file open dialog box
' solution for awhile. 'I'm an old autolisped making the jump to VBA and I 
have seen and read
' various solutons for the equivalent getfiled 'autolisp function but I never 
had much luck with them.
' This one worked for me it uses the Win API to do the job.
'---------------------------------------------------------------'
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'---------------------------------------------------------------'
Public Function ShowOpen(Filter As String, _
InitialDir As String, _
DialogTitle As String) As String
Dim OFName As OPENFILENAME
'Set the structure size
OFName.lStructSize = Len(OFName)
'Set the owner window
OFName.hwndOwner = 0
'Set the filter
OFName.lpstrFilter = Filter
'Set the maximum number of chars
OFName.nMaxFile = 255
'Create a buffer
OFName.lpstrFile = Space(254)
'Create a buffer
OFName.lpstrFileTitle = Space$(254)
'Set the maximum number of chars
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = InitialDir
'Set the dialog title
OFName.lpstrTitle = DialogTitle
'no extra flags
OFName.flags = 0
'Show the 'Open File' dialog
If GetOpenFileName(OFName) Then
ShowOpen = Trim(OFName.lpstrFile)
Else
ShowOpen = ""
End If
End Function
'---------------------------------------------------------------'
Function IsExcelRunning() As Boolean
Dim xlApp As Excel.Application
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
IsExcelRunning = (Err.Number = 0)
Set xlApp = Nothing
Err.Clear
End Function
Sub CreateDxfDocuments()
' To read data from specific Excel range
Dim xlApp As Excel.Application
Dim blnIsOK As Boolean
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
blnIsOK = IsExcelRunning()
If blnIsOK Then
Set xlApp = GetObject(, "Excel.Application")
Else
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.UserControl = True
End If
Dim xlFileName As String
Dim Filter As String
Dim InitialDir As String
Dim DialogTitle As String
Filter = "Excel Files (*.xlsx)" + Chr$(0) + "*.xlsx" + Chr$(0) + _
"All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
InitialDir = ThisDrawing.GetVariable("dwgprefix")
DialogTitle = "Open an Excel file"
xlFileName = ShowOpen(Filter, InitialDir, DialogTitle)
' to avoid using code above try hard coded file path,
' set full path of your Excel file here:
' xlFileName = "C:\Users\User\myxlFile.xlsx"
xlApp.Application.ScreenUpdating = False
' open file for read
Set xlBook = xlApp.Workbooks.Open(xlFileName)
Set xlSheet = xlBook.Worksheets("Sheet1") ' desired sheet name , same if use 
xlBook.Worksheets(1)
xlSheet.Activate
Dim xlrange As Excel.Range
Set xlrange = xlSheet.Range("A1:H4") ' range address we interested in
xlrange.Select
   Dim cols As Long
   Dim rows As Long
   cols = xlrange.Columns.Count
   rows = xlrange.rows.Count
Dim rangeValue As Variant
rangeValue = xlrange.Value2
' clean up memory
   xlBook.Close False
 Set xlBook = Nothing
   xlApp.Quit
 Set xlApp = Nothing
 'DoEvents
' end of work with Excel,
' go to Autocad then
MsgBox "Back to AutoCAD"
''--------------------------------------------------------
Dim dxfname As String
dxfname = "-Sample.dxf"
Dim ptCoordinates As New Collection
  Dim i, j
  For i = LBound(rangeValue, 1) To UBound(rangeValue, 1)
  ReDim ptarray(LBound(rangeValue, 2) To UBound(rangeValue, 2)) As 
Double
  For j = LBound(rangeValue, 2) To UBound(rangeValue, 2)
  ptarray(j) = rangeValue(i, j)
  Next j
  ptCoordinates.Add ptarray, CStr(i) & dxfname
  Next i
  Dim docMgr As AcadDocuments
  Set docMgr = Application.Documents
Dim item As Variant
Dim num As Integer
num = 1
For Each item In ptCoordinates
Dim acDoc As AcadDocument
ReDim dblPoints(LBound(item) To UBound(item)) As Double
For i = LBound(item) To UBound(item)
dblPoints(i) = CDbl(item(i))
Next i
Set acDoc = docMgr.Add()
Dim lwPoly As AcadLWPolyline
Set lwPoly = acDoc.ModelSpace.AddLightWeightPolyline(dblPoints)
lwPoly.Closed = True
acDoc.Application.ZoomExtents
acDoc.SaveAs ThisDrawing.GetVariable("dwgprefix") & CStr(num) & 
dxfname, ac2007_dxf
acDoc.Close
num = num + 1
Next item
MsgBox "Done"
End Sub
'---------------------------------------------------------------'