|
|
发表于 2006-8-10 19:05:00
|
显示全部楼层
运行正常，包括for m=8 to 30也可以，好像这个 pt1(0) = pt(0) + 488: pt1(1) = pt(1) - 884 - (1500 * kk): pt1(2) = 0等式只能计算22次，真的很奇怪！
完整的程序如下：
Private Sub CommandButton4_Click()
If (TextBox4.Text = "" Or TextBox5.Text = "") Then
MsgBox "请输入起始位置！"
Exit Sub
End If
Dim PathName As String
PathName = TextBox1.Text
On Error Resume Next
Set xlapp = GetObject(, "excel.application")
If Err Then
Err.Clear
Set xlapp = CreateObject("excel.application")
If Err Then
Err.Clear
MsgBox ("不能运行EXCEL，请检查是否安装了EXCEL")
Exit Sub
End If
End If
xlapp.Workbooks.Open PathName
Dim pt As Variant
Dim kk As Integer
kk = -1
Dim m As Integer
Dim textobject As AcadText
Dim ts As AcadTextStyle
Dim ts1 As AcadTextStyle
Dim tsna As String
Dim pt1(2) As Double
Dim pt2(2) As Double
Dim pt3(2) As Double
Dim pt4(2) As Double
Dim pt5(2) As Double
Dim pt6(2) As Double
Dim pt7(2) As Double
frmMain.Hide
pt = ThisDrawing.Utility.GetPoint(, "请输入插入点!")
For m = CInt(TextBox4.Text - 1) To CInt(TextBox5.Text - 1)
kk = kk + 1
pt1(0) = pt(0) + 488: pt1(1) = pt(1) - 884 - (1500 * kk): pt1(2) = 0
pt2(0) = pt(0) + 1662: pt2(1) = pt(1) - 890 - (1500 * kk): pt2(2) = 0
pt3(0) = pt(0) + 10548: pt3(1) = pt(1) - 752 - (1500 * kk): pt3(2) = 0
pt4(0) = pt(0) + 10589: pt4(1) = pt(1) - 1250 - (1500 * kk): pt4(2) = 0
pt5(0) = pt(0) + 10603: pt5(1) = pt(1) - 884 - (1500 * kk): pt5(2) = 0
pt6(0) = pt(0) + 25479: pt6(1) = pt(1) - 984 - (1500 * kk): pt6(2) = 0
pt7(0) = pt(0) + 26467: pt7(1) = pt(1) - 965 - (1500 * kk): pt7(2) = 0
Select Case (ComboBox2.Text)
Case Is = "中文"
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("a" & (m + 3)), pt1, 500)
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("b" & (m + 3)), pt2, 400)
Set ts = ThisDrawing.ActiveTextStyle
tsna = ts.fontFile
Set ts1 = ThisDrawing.ActiveTextStyle
ts1.fontFile = "HZTXT"
ThisDrawing.ActiveTextStyle = ts1
Set textobject = ThisDrawing.ModelSpace.AddText((xlapp.Worksheets("sheet1").range("d" & (m + 3)) & xlapp.Worksheets("sheet1").range("e" & (m + 3))), pt5, 500)
ThisDrawing.Regen acActiveViewport
ts.fontFile = tsna
ThisDrawing.ActiveTextStyle = ts
Set textobject = ThisDrawing.ModelSpace.AddText("0", pt6, 400)
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("g" & (m + 3)), pt7, 550)
Case Is = "中英文"
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("a" & (m + 3)), pt1, 500)
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("b" & (m + 3)), pt2, 400)
Set ts = ThisDrawing.ActiveTextStyle
tsna = ts.fontFile
Set ts1 = ThisDrawing.ActiveTextStyle
ts1.fontFile = "HZTXT"
ThisDrawing.ActiveTextStyle = ts1
Set textobject = ThisDrawing.ModelSpace.AddText((xlapp.Worksheets("sheet1").range("c" & (m + 3)) & xlapp.Worksheets("sheet1").range("d" & (m + 3))), pt3, 500)
ThisDrawing.Regen acActiveViewport
ts.fontFile = tsna
ThisDrawing.ActiveTextStyle = ts
Set textobject = ThisDrawing.ModelSpace.AddText((xlapp.Worksheets("sheet1").range("e" & (m + 3)) & " " & xlapp.Worksheets("sheet1").range("f" & (m + 3))), pt4, 300)
Set textobject = ThisDrawing.ModelSpace.AddText("0", pt6, 400)
Set textobject = ThisDrawing.ModelSpace.AddText(xlapp.Worksheets("sheet1").range("g" & (m + 3)), pt7, 550)
End Select
Next
xlapp.activeworkbook.Save
xlapp.Workbooks.Close
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing
End Sub |
|
置顶卡
