[VBA程序]：毕业设计时候做的简单工具

ln2127105

12

ln2127105

13

ln2127105

有人吗？有人来搞定吗？？

wzmfx

我来帮你搞定。
下面的是代码，但是我没搞懂你程序中的计算公式，不知你把y值缩小了几倍，最好把你的缩小倍数与我的缩小倍数n结合为一个，就OK了。还有，你光提供了一个弯矩最大值mm，应该还计算一个最小值，即负弯矩最大值。
另外，我在我的破电脑上运行时，如果不先把AUTOCAD2004打开，它就会报错，不知什么原因。
Public AcadApp As AcadApplication

Private Sub Command1_Click()

'打开AutoCAD
On Error Resume Next
Set AcadApp = GetObject(, "AutoCAD.Application.16")
If Err Then
   MsgBox Err.Description
   Err.Clear
   Set AcadApp = CreateObject("AutoCAD.Application.16")
   If Err Then
      MsgBox Err.Description
      Exit Sub
   End If
End If
AcadApp.Visible = True
AcadApp.WindowState = acMax
AcadApp.Documents.Add


Dim Va, u As Double
Dim Q1, Q2 As Double
Dim Ma, Mb, Mm As Double
Dim a As Double
Dim L As Double
Dim b As Integer
Dim c As Double
Dim n As Integer

Dim I As Integer
I = 2

Q1 = Val(Text3.Text)
Q2 = Val(Text4.Text)
a = Val(Text5.Text)
L = Val(Text6.Text)
Ma = Val(Text1.Text)
Mb = Val(Text2.Text)

Dim Lzx_Line As AcadLine
Dim Wjx_WPline As AcadLWPolyline
Dim WjPnt_Dou(0 To 2005) As Double
Dim Lqd(0 To 2) As Double
Dim Lzd(0 To 2) As Double

Dim TextObj As AcadText
Dim TextStr As String
Dim InsertPnt(0 To 2) As Double
Dim TextHight As Double

Lqd(0) = 0#: Lqd(1) = 0#: Lqd(2) = 0#
Lzd(0) = L: Lzd(1) = 0#: Lzd(2) = 0#

WjPnt_Dou(0) = 0
WjPnt_Dou(1) = 0
WjPnt_Dou(2004) = L
WjPnt_Dou(2005) = 0

If L <= 0 Or a > 0.5 Then
Picture1.Cls
Picture1.Line (0, 0)-(L, 0), QBColor(15)
MsgBox "数据输入错误!"
GoTo ends
End If
u = -1
Va = -(Ma - Mb) / (0.75 * L) + 0.5 * Q1 * L + (1 - a) * L * Q2 * 0.5
If Q1 = 0 And Q2 = 0 Then
b = 1
GoTo tu
End If

If Va - 0.5 * (2 * Q1 + Q2) * a * L <= 0 Then
b = 0
u = Va / (Q1 + 0.5 * Q2)
ElseIf Va - 0.5 * (2 * Q1 + Q2) * a * L > 0 And Va - 0.5 * (2 * Q1 + Q2) * a * L - (Q1 + Q2) * (L - a * L) <= 0 Then
u = (Va + 0.5 * a * L * Q2) / (Q1 + Q2)
b = 0
Else
u = (Va - 0.5 * Q2 * L + Q2 * a * L) / (Q1 + 0.5 * Q2)
b = 0
End If

tu:

If (Abs(Ma) > Abs(Mb) And b = 1) Or u < 0 Then
Mm = Ma
u = 0
ElseIf (Abs(Ma) < Abs(Mb) And b = 1) Or u > L Then
Mm = Mb
u = L
Else
Mm = -(Ma / 0.75 + Va * ux - 0.5 * (Q1 + Q2) * u ^ 2 + 0.5 * Q2 * a * L * (u - (1 / 3) * a * L))
End If

c = Abs(Mm) / 20
If c = 0 Then GoTo ends

'n是绘画y方向缩小倍数
n = Round(Abs(Mm) / L / 10) * 10
If n = 0 Then n = 1

Picture1.Scale (0, 50)-(L, -50)
Picture1.Cls
Picture1.Line (0, 0)-(L, 0), QBColor(15)

Set Lzx_Line = AcadApp.ActiveDocument.ModelSpace.AddLine(Lqd, Lzd)
Lzx_Line.Color = acGreen

Picture1.CurrentX = 0
Picture1.CurrentY = 0

'我把它设成宋体，如果你的windows字体
文件与我的不一样，请自己修改路径。
AcadApp.ActiveDocument.ActiveTextStyle.fontFile = "c:\windows\fonts\simsun.ttf"
TextHight = 0.15

Dim Ya, Ym, Yb As Double

For x = 0 To L Step L / 1000
   
    WjPnt_Dou(I) = x
    If x < a * L Then
   
       y = -((0.5 * Q1 * L * x - 0.5 * Q1 * x ^ 2) + (Ma - x * (Ma - Mb) / L) / 0.75 - Q2 * (x ^ 3) / (6 * a * L) + (0.5 * (L - a * L) * Q2 * x)) / c
       Picture1.Line -(x, y)
      
       WjPnt_Dou(I + 1) = y / n
       I = I + 2
       If x = 0 Then Ya = y / n
      
    ElseIf x <= L - a * L And x > a * L Then

      y = -((0.5 * Q1 * L * x - 0.5 * Q1 * x ^ 2) + (Ma - x * (Ma - Mb) / L) / 0.75 + 0.5 * Q2 * (L - a * L) * x - 0.5 * Q2 * a * L * (x - 2 * a * L / 3) - Q2 * (x - a * L) ^ 2 / 2) / c
      Picture1.Line -(x, y)

      WjPnt_Dou(I + 1) = y / n
      I = I + 2

   ElseIf x <= L And x > L - a * L Then

      y = -((0.5 * Q1 * L * x - 0.5 * Q1 * x ^ 2) + (Ma - x * (Ma - Mb) / L) / 0.75 - Q2 * ((L - x) ^ 3) / (6 * a * L) + (0.5 * (L - a * L) * Q2 * (L - x))) / c
      Picture1.Line -(x, y)

      WjPnt_Dou(I + 1) = y / n
      I = I + 2
      If x < L Then Yb = y / n
         
   End If
   
   If x = L Then Picture1.Line (L, y)-(L, 0)
   
   If (x - u) < L / 2000 Then Ym = y / n

Next x
  
TextStr = "横向比例：1：1000"
InsertPnt(0) = -2.5: InsertPnt(1) = 0.3: InsertPnt(2) = 0
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)

TextStr = "纵向比例：1：" & Str(n * 1000)
InsertPnt(1) = 0
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)

TextStr = "单位：KN , m"
InsertPnt(0) = -2.05: InsertPnt(1) = -0.3
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)

Set Wjx_WPline = AcadApp.ActiveDocument.ModelSpace.AddLightWeightPolyline(WjPnt_Dou)
Wjx_WPline.Color = acRed

TextStr = "Ma=" & Str(Ma)
InsertPnt(0) = 0: InsertPnt(1) = Ya: InsertPnt(2) = 0
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)
TextObj.Alignment = acAlignmentBottomRight

TextStr = "Mb=" & Str(Mb)
InsertPnt(0) = L: InsertPnt(1) = Yb
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)

Lqd(0) = u: Lqd(1) = 0
Lzd(0) = u: Lzd(1) = Ym
Set Lzx_Line = AcadApp.ActiveDocument.ModelSpace.AddLine(Lqd, Lzd)
Lzx_Line.Color = acCyan

TextStr = "x=" & Str(Round(u * 10000) / 10000) & " ,Mmax=" & Str(Int(Mm * 100) / 100)
InsertPnt(0) = u: InsertPnt(1) = Ym
Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(TextStr, InsertPnt, TextHight)

ZoomExtents

Label8.Caption = Ma
Label10.Caption = Mb
Label12.Caption = Int(Mm * 100) / 100
Label13.Caption = Int(u * 100) / 100

ends:
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Command3_Click()
Form2.Show

End Sub

杨平

我想知道好不好做啊?

liuyu49

估计下载完了别人早就把问题解决了，呵呵!
在线时间太短，下载时间间隔太长了！

ln2127105

非常感谢19楼啊

thissun

xzx

pfrao

赞..好好学习ing

huayunhai

不错！真的很不错

ln2127105

19楼的高人如何联系？

lvjoly

好多啊
我下载的眼睛发晕啊