module1.bas

本软件为脚本导航

Attribute VB_Name = "Module1"
Option Explicit
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Type D3Point
  x As Double
  y As Double
  z As Double
End Type
Dim InitePoint As D3Point    '申明初始化点
Dim MovePathLength As Double, NextPoint As D3Point
Dim Dy() As Long, PC As Long
Public PauseTrue As Boolean, MidRangid As Long
Public ReadScriptFile As String, StrLine As String
Public Const PI As Double = 3.1415926535
Dim IniteDirector(1 To 2) As Double
Public MinJS As Double, MinJ As Double, MinQ As Double '最小的航行距离
Public ProgramFile As String
Public ComHs As Double '公用航速
Public MinLen As Double, FPointRang As Long, FindTrue As Boolean '起点行


Function GetMoveLengthAndScaleNum(FirstPoint As D3Point, SecondPoint As D3Point, LastDirector() As Double, ByRef MoveLength, ByRef outHs As Double, ByRef outDirector() As Double, ByRef outPoint As D3Point) As Boolean
'由两个现成的点 获取距离和方向角度
Dim L As Double                 '路径
Dim Scaledu(1 To 2) As Double   '角度
Dim HDirector(1 To 2) As Double '航向
Dim Hrange As Double            '航程
Dim Hs As Double                '航速
Dim Dsp As String

L = Math.Sqr((FirstPoint.x - SecondPoint.x) ^ 2 + (FirstPoint.y - SecondPoint.y) ^ 2 + (FirstPoint.z - SecondPoint.z) ^ 2)
'角度分三种 X Y 面，X Z 面 二个面的角度。如果其中任何一角度大于10度说明都需要转弯。

Scaledu(1) = IIf(((FirstPoint.x - SecondPoint.x) = 0), 0, Math.Atn((FirstPoint.y - SecondPoint.y) / (FirstPoint.x - SecondPoint.x)) / PI * 180)

Scaledu(2) = IIf(((FirstPoint.x - SecondPoint.x) = 0), 0, Math.Atn((FirstPoint.z - SecondPoint.z) / (FirstPoint.x - SecondPoint.x)) / PI * 180)

''将上一次的方向 与此次移动的方向做对比 计算出方向(角度差)
If Abs(Scaledu(1) - LastDirector(1)) > MinQ Or Abs(Scaledu(2) - LastDirector(2)) > MinQ Then
'说明转向角度大于10度 需要转弯
 HDirector(1) = Scaledu(1): HDirector(2) = Scaledu(2)
 
  Hrange = IIf(L > MinJS, L, 0)
 
 If Hrange <> 0 Then
 Call MOVTO(SecondPoint.x, SecondPoint.y, SecondPoint.z) '说明该移动车
 
 Hs = (Hrange / MinJ) * 100
 
 If Hs >= 100 Then Hs = 100
 
 Else
 
 Hs = 0
 
 End If
 
outHs = Hs                                                               '返回航速
outDirector(1) = HDirector(1): outDirector(2) = HDirector(2)             '返回最后的方向
outPoint = IniteD3Point(SecondPoint.x, SecondPoint.y, SecondPoint.z)     '返回第二点
MoveLength = Hrange                                                      '返回航程 .计算

Form1.HSM.Text = Hs
Form1.HXZLtxt.Text = IIf(outDirector(1) >= 0, 1, -1) * (Abs(outDirector(1)) Mod PI) '换成+/-0-180度
Form1.HXCGtxt.Text = LastDirector(1) '当前方向
Form1.Flable.Caption = InitePan(Form1.PPshape, Form1.cmdLine)

Dsp = "移动到" & ":" & SecondPoint.x & " : " & SecondPoint.y & " : " & SecondPoint.z & "Length=" & MoveLength & "ComHs=" & outHs & "  NextDirector=" & outDirector(1) & ":" & outDirector(2)
Form1.List1.AddItem Dsp
Else
'不转弯 保留原来的方向
MsgBox "不转弯 保留原来的方向"
 HDirector(1) = LastDirector(1): HDirector(2) = LastDirector(2)
 '航向没有变化，因此做为合并计算列
 outHs = 0                                                          '返回航速
 outDirector(1) = HDirector(1): outDirector(2) = HDirector(2)       '返回最后的方向
 outPoint = IniteD3Point(FirstPoint.x, FirstPoint.y, FirstPoint.z)  '返回第一点
 MoveLength = 0                                                     '返回航程 .不计算
End If

GetMoveLengthAndScaleNum = True
End Function
Function GetMinLen(CurrtPoint As D3Point, NextP As D3Point, ByVal CurrtRangid)
 Dim L As Double
 L = Math.Sqr((CurrtPoint.x - NextP.x) ^ 2 + (CurrtPoint.y - NextP.y) ^ 2 + (CurrtPoint.z - NextP.z) ^ 2)
 If MinLen <> 0 Then
 FPointRang = IIf(MinLen > L, CurrtRangid, FPointRang)  '获得行号
 MinLen = IIf(MinLen > L, L, MinLen)                    '获得距离
 Else
 FPointRang = CurrtRangid '初始化第一点
 MinLen = L               '初始化第一点
 End If
End Function


Function ScriptReader(ByVal ScriptPath As String, ReadFlag As Long) As Boolean
'脚本阅读器
Dim FileNum As Long
Dim CmdStr As String
Dim Passage() As String
Dim PamTxt As String
Dim CmdClose As Boolean, FirstRead As Boolean
Dim NextP As D3Point
Dim Rangid As Long
Dim MoveLength As Double, ScaleNum As Double
FirstRead = False
CmdClose = True
ReadScriptFile = ScriptPath
FileNum = FreeFile
'MsgBox ReadFlag
Open ReadScriptFile For Input As #FileNum
Do While Not EOF(FileNum)
    Rangid = Rangid + 1
    Line Input #FileNum, StrLine
    If Len(StrLine) = 0 Then GoTo loo
    If FirstRead = False Then
       If Rangid = ReadFlag Then
       FirstRead = True
       Else
       GoTo loo
       End If
    End If
    CmdStr = IIf(InStr(1, StrLine, "(") <> 0, Mid(StrLine, 1, InStr(1, StrLine, "(") - 1), "")
    PamTxt = Mid(StrLine, InStr(1, StrLine, "(") + 1, InStr(1, StrLine, ")") - InStr(1, StrLine, "(") - 1)
    
    Select Case UCase(CmdStr)
       Case "MSG"
         MsgBox PamTxt
         Form1.List1.AddItem PamTxt
       Case "MOVETO"
          Passage = Split(PamTxt, ",")
          If UBound(Passage) = 2 Then
          NextP = IniteD3Point(CDbl(Trim(Passage(0))), CDbl(Trim(Passage(1))), CDbl(Trim(Passage(2))))
          If FindTrue And FPointRang <= Rangid Then '执行代码
            Call GetMoveLengthAndScaleNum(InitePoint, NextP, IniteDirector, MoveLength, ComHs, IniteDirector, InitePoint)
          Else              '检查近点功能
            Call GetMinLen(InitePoint, NextP, Rangid) '求取最短距离
          End If
          Else
          Form1.List1.AddItem UBound(Passage)
          CmdClose = False
          End If
       Case "JMP"
         '无条件跳转指令
         Close #FileNum
         If Not JmpCmd(ReadScriptFile, PamTxt) Then MsgBox "JMP命令没有找到"
         Exit Do
         
       Case "RETURN"
       '返回对应最近的CALL
       Close #FileNum
       PC = PC - 1
         If Not ScriptReader(ReadScriptFile, Dy(PC + 1) + 1) Or PC < 0 Then MsgBox "RETURN命令没有找到"
       Exit Do
       
       
       Case "EXIT"
          Exit Do

       Case "DELAY"
       
       Close #FileNum
       Form1.List1.AddItem "DELAY" & CLng(PamTxt)
       If DelayTime(CLng(PamTxt)) Then Call ScriptReader(ReadScriptFile, Rangid + 1)
         Exit Do
       Case "PAUSE"
       '将暂停功能取消
       'Close #FileNum
       'Form1.List1.AddItem "暂停执行了！空格继续执行……"
       'PauseTrue = True
       'MidRangid = Rangid
       'Exit Do
       Case "LABEL"
       '标签就不要动作了！
       Case "CALL"
       If PC = 255 Then ReDim Preserve Dy(UBound(Dy) + 255) As Long
       PC = PC + 1      '指针地址
       Dy(PC) = Rangid  '将此行压入堆欹
       Close #FileNum
       If Not JmpCmd(ReadScriptFile, PamTxt) Then MsgBox "CALL命令没有找到"
       Exit Do
       Case Else
       CmdClose = True
   End Select
  ' If MsgBox("是否继续" & StrLine, vbOKCancel, "询问") = vbCancel Then Exit Do
   
loo:
Loop
   Close #FileNum
ScriptReader = True
End Function
Function PreReader(FileNamestr As String)
'预前处理过程
ReDim Preserve Dy(1 To 255) As Long
PC = 0
MinLen = 0
FPointRang = 0
PauseTrue = False
IniteDirector(1) = 0: IniteDirector(2) = 0

InitePoint = IniteD3Point(Val(Form1.Pointx.Text), Val(Form1.Pointy.Text), Val(Form1.Pointz.Text))

FindTrue = False
If ScriptReader(FileNamestr, 1) Then
FindTrue = True

MsgBox "最近行号：" & FPointRang & vbCrLf & "最短距离：" & MinLen

If FPointRang <> 0 Then Call ScriptReader(FileNamestr, 1)

Else
FindTrue = False
MsgBox "没有比较完 "
End If
End Function
Function DelayTime(TimeLong As Long) As Boolean  '单位为秒
Dim i As Long  '计算毫秒
Dim iM As Long '计算秒数

DelayTime = False

For i = 1 To 1000  '循环1000次算一秒种

If iM = TimeLong Then
DelayTime = True
Exit For
End If

If i = 1000 Then
iM = iM + 1
i = 1
End If
Next i

End Function


Function JmpCmd(ScriptPath As String, LableName As String) As Boolean
Dim iRangid As Long, iPamTxt As String
Dim ReadScriptFile As String, StrLine As String
Dim FileNum As Long
Dim CmdClose As Boolean
Dim CmdStr As String
         CmdClose = False
         ReadScriptFile = ScriptPath
         FileNum = FreeFile
         iRangid = 0
         Open ReadScriptFile For Input As #FileNum
         Do While Not EOF(FileNum)
         iRangid = iRangid + 1
         Line Input #FileNum, StrLine
         CmdStr = IIf(InStr(1, StrLine, "(") <> 0, Mid(StrLine, 1, InStr(1, StrLine, "(") - 1), "")
         iPamTxt = Mid(StrLine, InStr(1, StrLine, "(") + 1, InStr(1, StrLine, ")") - InStr(1, StrLine, "(") - 1)
       
          If UCase(CmdStr) = "LABEL" And LableName = iPamTxt Then
          Close #FileNum
          Call ScriptReader(ScriptPath, iRangid)
          CmdClose = True
          Exit Do
          End If
          Loop
          If Not CmdClose Then Close #FileNum
          JmpCmd = CmdClose
End Function
Function IniteD3Point(x As Double, y As Double, z As Double) As D3Point
'装坐标函数
With IniteD3Point
.x = x
.y = y
.z = z
End With
End Function
  'Inverse   Sine
  Public Function ASin(ByVal Number As Double) As Double
          ASin = Atn(Number / Sqr(-Number * Number + 1))
  End Function
  'Inverse   Cosine
  Public Function ACos(ByVal Number As Double) As Double
          ACos = Atn(-Number / Sqr(-Number * Number + 1)) + 2 * Atn(1)
  End Function
  'Secant
  Public Function Sec(ByVal Number As Double) As Double
          Sec = 1 / Cos(Number)
  End Function
    
  'Cosecant
  Public Function Csc(ByVal Number As Double) As Double
          Csc = 1 / Sin(Number)
  End Function
    
  'Cotangent
  Public Function Ctn(ByVal Number As Double) As Double
          Ctn = 1 / Tan(Number)
  End Function


Sub Main()
ProgramFile = App.Path & "\Config.ini"
Load Form1
Form1.Show
End Sub


Sub MOVTO(x As Double, y As Double, z As Double)
'移动车的函数
MsgBox "目前车行使点：" & x & " : " & y & " : " & z
End Sub