学习VBA开发发生了一些问题，新人求教

CADLearner · 发表于 2020-9-2 10:40:00

本人在学习《VBA＆VB.NET开发基础与实例》一书中编写代码实现有一点问题。关键对于动态数组的实现有一点问题，图形的实现效果也与书中不同，本人希望能得到大佬的指点一下。因书中的模块都会在后面用到，所以希望能解决一下。http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTEwNjYzfDQyMzNmMjI5ZWRhMjBmNzllMzBiYmRkYjdhMmZjMWIyfDE2NTkwNzM4MDQ%3D&request=yes&_f=.dvbCad中实现的图形

ftylomc4ifu.jpg

书中实际实现的效果

ahhnkdcphdo.jpg

本帖以下内容被隐藏保护；需要你回复后，才能看到！

游客，如果您要查看本帖隐藏内容请回复

CADLearner · 发表于 2020-9-7 10:03:00

好的，问题现在已解决，多谢帮助。

sgwsssxm · 发表于 2020-9-7 10:23:00

这就是m_bFirstItem的问题了，我说的两个地方都改了，最后显示效果才能对上。

CADLearner · 发表于 2020-9-4 13:30:00

Option Explicit
Private m_verts() As Double
Private Sub Class_Initialize()
ReDim m_verts(1)
Dim m_bFirstItem As Boolean
m_bFirstItem = True
End Sub
Public Function Append(ByVal point As Variant)
Debug.Assert (VarType(point) = vbArray + vbDouble)
Debug.Assert (UBound(point) >= 1)
Dim m_bFirstItem As Boolean
If (m_bFirstItem) Then
      m_bFirstItem = False
Else
ReDim Preserve m_verts(UBound(m_verts) + 2)
End If
m_verts(UBound(m_verts) - 1) = point(0)
m_verts(UBound(m_verts)) = point(1)
End Function
Public Function InsertAt(ByVal i As Integer, ByVal point As Variant) As Boolean
Debug.Assert (VarType(point) = vbArray + vbDouble)
Debug.Assert (UBound(point) >= 1)
Dim m_bFirstItem As Boolean
If (m_bFirstItem) Then
If (i = 0) Then
      m_verts(0) = point(0)
      m_verts(1) = point(1)
      m_bFirstItem = False
Else
      InsertAt = False
      Exit Function
End If
Else
If (i  GetCount()) Then
      InsertAt = False
      Exit Function
Else
      ReDim Preserve m_verts(UBound(m_verts) + 2)
      If (i  GetCount()) Then
         Dim j As Integer
         For j = UBound(m_verts) To (i + 1) * 2 Step -1
            m_verts(j) = m_verts(j - 2)
         Next j
      End If

      m_verts(i * 2) = point(0)
      m_verts(i * 2 + 1) = point(1)
      InsertAt = True
End If
End If
End Function
Public Function GetCount() As Integer
Dim m_bFirstItem As Boolean
If (m_bFirstItem) Then
      GetCount = 0
Else
      GetCount = (UBound(m_verts) + 1) / 2
End If
End Function
Public Function RemoveLast() As Boolean
Dim m_bFirstItem As Boolean
If (GetCount() > 1) Then
      ReDim Preserve m_verts(UBound(m_verts) - 2)
      RemoveLast = True
ElseIf (GetCount() = 1) Then

      m_verts(0) = 0
      m_verts(1) = 0
      RemoveLast = True
      m_bFirstItem = True
Else
      RemoveLast = True
End If
End Function
Public Function RemoveAt(ByVal i As Integer) As Boolean
If (i  GetCount() - 1) Then
      RemoveAt = False
      Exit Function
Else
      If (i  GetCount() - 1) Then
         Dim j As Integer
         For j = i * 2 To UBound(m_verts) - 2
            m_verts(j) = m_verts(j + 2)
         Next j
      End If

      If (GetCount() = 1) Then
         m_verts(0) = 0
         m_verts(1) = 0
         m_bFirstItem = True
      Else
         ReDim Preserve m_verts(UBound(m_verts) - 2)
      End If
End If
End Function
Public Function SetPoints(ByVal points As Variant) As Boolean
Debug.Assert (VarType(points) = vbArray + vbDouble)
Debug.Assert (UBound(points) Mod 2 = 1)
ReDim m_verts(UBound(points))
Dim i As Integer
For i = 0 To UBound(points)
      m_verts(i) = points(i)
Next i
End Function
Public Function GetAt(ByVal i As Integer, ByRef point As Variant) As Boolean
If (i  GetCount() - 1) Then
      GetAt = False
      Exit Function
Else
      Dim vert(0 To 1) As Double
      SetPoint2d vert, m_verts(i * 2), m_verts(i * 2 + 1)
      point = vert
      GetAt = True
End If
End Function
Public Function SetAt(ByVal i As Integer, ByVal point As Variant) As Boolean
Debug.Assert (VarType(point) = vbArray + vbDouble)
Debug.Assert (UBound(point) = 1)
If (GetCount() = 0) Then
      SetAt = False
      Exit Function
Else
      If (i  GetCount() - 1) Then
         SetAt = False
         Exit Function
      Else
         m_verts(i * 2) = point(0)
         m_verts(i * 2 + 1) = point(1)
      End If
End If
End Function
Public Function ToArray() As Variant
ToArray = m_verts
End Function

CADLearner · 发表于 2020-9-4 13:26:00

Public Function AddPolygon(ByVal centerpoint As Variant, ByVal sideCount As Double, ByVal radius As Double, Optional width As Double = 0, Optional angle As Double = 0) As AcadLWPolyline
Dim math As New clsmath
Dim sideAngle As Double
      sideAngle = (2 * math.PI()) / sideCount

Dim verts As New cls2dPointArray
Dim i As Integer
Dim point(0 To 1) As Double
For i = 0 To 2 * (sideCount - 1)

      If i Mod 2 = 0 Then
         point(0) = centerpoint(0) + radius * Sin((i / 2) * sideAngle)
         verts.Append point
      Else
         point(1) = centerpoint(1) + radius * Cos((i / 2) * sideAngle)

      End If
Next i
Set AddPolygon = AddLWPolyline(verts.ToArray(), True, width)
AddPolygon.Rotate centerpoint, angle
AddPolygon.Update
End Function

mikewolf2k · 发表于 2020-9-3 09:49:00

这个代码应该相当简单，请直接把代码以代码方式贴出来方便别人查看。
回到问题本身，这个程序相当简单，既然是图形错误，估计就是坐标错误导致，自己先检查下坐标值。

CADLearner · 发表于 2020-9-4 10:24:00

Public Sub CreatePolygon()
Dim centerpoint(0 To 2) As Double
SetPoint3d centerpoint, 0, 0, 0

Dim mSpace As New clsModelSpace
mSpace.AddPolygon centerpoint, 6, 50
End Sub

CADLearner · 发表于 2020-9-4 10:25:00

Public Function SetPoint3d(ByRef point As Variant, ByVal x As Double, ByVal y As Double, ByVal z As Double)
Debug.Assert (VarType(point) = vbArray + vbDouble)
Debug.Assert (LBound(point) = 0 And UBound(point) = 2)
point(0) = x
point(1) = y
point(2) = z
End Function

CADLearner · 发表于 2020-9-4 13:29:00

Public Function AddLeaderByPolyline(ByVal startPoint As Variant, ByVal endPoint As Variant, Optional widthScale As Double = 0.3) As AcadLWPolyline
Debug.Assert (VarType(startPoint) = vbArray + vbDouble)
Debug.Assert (VarType(endPoint) = vbArray + vbDouble)
Debug.Assert (UBound(startPoint) = 1)
Debug.Assert (UBound(endPoint) = 1)

Dim verts As New cls2dPointArray
verts.Append startPoint
verts.Append endPoint

Set AddLeaderByPolyline = AddLWPolyline(verts.ToArray())

Dim length As Double
Dim math As New clsmath
length = math.GetDistanceBetween2Point(startPoint, endPoint)
AddLeaderByPolyline.SetWidth 0, length * widthScale, 0

End Function

CADLearner · 发表于 2020-9-4 13:29:00

Public Function AddLWPolyline(ByVal verts As Variant, Optional closed As Boolean = False, Optional width As Double = 0) As AcadLWPolyline
Debug.Assert (VarType(verts) = vbArray + vbDouble)
Debug.Assert (UBound(verts) > 2 And UBound(verts) Mod 2 = 1)
Set AddLWPolyline = ThisDrawing.ModelSpace.AddLightWeightPolyline(verts)
If (closed) Then
AddLWPolyline.closed = True
End If
AddLWPolyline.ConstantWidth = width
End Function

学习VBA开发发生了一些问题，新人求教

发表回复

精选推荐