form1.frm

该程序基于RS232串口通讯的激光检测钻头钻孔内径及外径等相关参数从而判断该产品是否为OK/NG

        .DialogTitle = "选择文件的路径"
        .Filter = "参数文件(*.LS)|*.LS|所有文件(*.*)|*.*"
        .Flags = cdlCFEffects Or cdlCFBoth
        .ShowOpen
    End With
    Dialog1.CancelError = True
       If Dir(Dialog1.FileName, vbNormal) = "" Then
                  Exit Sub
           End If
    If Not F1Book1.TextRC(4, 1) = "" Then
         Dim msg As String
             msg = MsgBox("您要保存当前的数据吗？", vbYesNoCancel + vbInformation, "提示")
               If msg = vbYes Then
                              msaveas_Click
               ElseIf msg = vbNo Then
                Else
                 Exit Sub
             End If
         End If
inigraph 25, 20 '初始化操作料盘
mingzi = getname  '  得到名字
oktall = 0: ngtall = 0: bianhao = 1
lok.Caption = 0: lng.Caption = 0: pic1OK.Visible = False: pic1ng.Visible = False
F1Book1.ClearRange 4, 1, 16384, 256, 3
f1row = 3
zhuidu1.Caption = "00.0000"
zhuidu2.Caption = "00.0000"
F1Book1.MaxRow = 4
ronghang = 1: ronglei = 1
''''=================================文件操作
Open Dialog1.FileName For Random As #1
  Screen.MousePointer = 11
Get #1, 1, sam      '名字
dname.Text = Trim(sam)
Get #1, 2, sam
clearstring = WaitRS(frmmain.com1, vbCrLf, 20)
If Val(sam) = 1 Then '成品否
  frmmain.com1.Output = "RS" & Space(1) & 1300 & vbCr
  clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",成品"
    leixing.Caption = "半成品："
Else
  frmmain.com1.Output = "ST" & Space(1) & 1300 & vbCr
        clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",半成品"
   leixing.Caption = " 成品："
End If

'为测量方法
Get #1, 3, sam
frmmain.com1.Output = "WR" & Space(1) & "DM7" & Space(1) & Val(sam) & vbCr
           clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",测量方法"
'显示方法
 Get #1, 4, sam
  mearint = Val(sam)
  frmmain.com1.Output = "WR" & Space(1) & "DM500" & Space(1) & mearint & vbCr
          clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",显示方法"
'点数量
 Get #1, 5, sam
ppoints = Val(sam)
cntpoints = ppoints
'点数量
 Get #1, 6, sam
diamoth = Val(sam)
frmmain.com1.Output = "WR" & Space(1) & "DM501" & Space(1) & diamoth & vbCr
           clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",直径的比较方法"
Get #1, 7, sam   '横向间距
frmmain.com1.Output = "WR" & Space(1) & "DM" & 2 & Space(1) & Val(sam) & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & "，横向间距"
Get #1, 8, sam   '坚向间距
frmmain.com1.Output = "WR" & Space(1) & "DM" & 10 & Space(1) & Val(sam) & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & "，坚向间距"
Get #1, 9, sam   '横向个数
xtoll.Text = Val(sam)
frmmain.com1.Output = "WR" & Space(1) & "DM" & 9 & Space(1) & Val(sam) & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & "，横向个数"
Get #1, 10, sam   '坚向个数
ytoll.Text = Val(sam)
frmmain.com1.Output = "WR" & Space(1) & "DM" & 8 & Space(1) & Val(sam) & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & "，坚向个数"
Get #1, 11, sam   '斜度显示否
If Val(sam) = 1 Then
            '==
             zdboolean = True
             Get #1, 12, sam   '斜度
               zd1 = Val(sam)
              frmmain.com1.Output = "WR" & Space(1) & "DM" & 300 & Space(1) & Val(sam) & vbCr
                        clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
              If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",斜度位置一"
             Get #1, 13, sam
               zd2 = Val(sam)
              frmmain.com1.Output = "WR" & Space(1) & "DM" & 302 & Space(1) & Val(sam) & vbCr
                        clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
              If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",斜度位置二"
             Get #1, 14, sam
               Bzdupper = Val(sam)
              frmmain.com1.Output = "WR" & Space(1) & "DM" & 312 & Space(1) & Val(sam) * 10000 & vbCr
                     clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
              If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",斜度上限"
             Get #1, 15, sam
             Bzdlower = Val(sam)
             frmmain.com1.Output = "WR" & Space(1) & "DM" & 310 & Space(1) & Val(sam) * 10000 & vbCr
                    clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
              If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",斜度下限"
Else
  zdboolean = False
End If
'清空位置
frmmain.com1.Output = "WR" & Space(1) & "DM" & 50 + ppoints & Space(1) & 0 & vbCr
 clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
 If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",清空PLC"
'点位置
fbkline = 15
instring = ""
  For j = 1 To ppoints
   fbkline = fbkline + 1
   Get #1, fbkline, sam
   instring = instring & Space(1) & Val(sam)
   Next j
  frmmain.com1.Output = "WRS" & Space(1) & "DM" & 50 & Space(1) & ppoints & instring & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",测量点位置"
'dieupper
instring = ""
  For j = 1 To ppoints
  fbkline = fbkline + 1
   Get #1, fbkline, sam
   diaupper(j) = Val(sam)
  instring = instring & Space(1) & Val(sam) * 10000
   Next j
   frmmain.com1.Output = "WRS" & Space(1) & "DM" & 60 & Space(1) & ppoints & instring & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",外径上限"
  ' dialower
  instring = ""
  For j = 1 To ppoints
   fbkline = fbkline + 1
   Get #1, fbkline, sam
   dialower(j) = Val(sam)
  instring = instring & Space(1) & Val(sam) * 10000
   Next j
      frmmain.com1.Output = "WRS" & Space(1) & "DM" & 70 & Space(1) & ppoints & instring & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",外径下限"
   'zhenyuan
   instring = ""
  For j = 1 To ppoints
   fbkline = fbkline + 1
   Get #1, fbkline, sam
   zyupper(j) = Val(sam)
   instring = instring & Space(1) & Val(sam) * 10000
   Next j
      frmmain.com1.Output = "WRS" & Space(1) & "DM" & 80 & Space(1) & ppoints & instring & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",真圆度上限"
   'tongxin
   instring = ""
  For j = 1 To ppoints
   fbkline = fbkline + 1
   Get #1, fbkline, sam
   txupper(j) = Val(sam)
   instring = instring & Space(1) & Val(sam) * 10000
   Next j
      frmmain.com1.Output = "WRS" & Space(1) & "DM" & 100 & Space(1) & ppoints & instring & vbCr
         clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
  If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",同心度上限"
'出表头
displaybiaotu mearint, ppoints, diamoth
Close
 Screen.MousePointer = 0
 SaveSetting "myapp", "dname", "value", dname.Text
  mstart_Click
    errstring = Mid(errstring, 2)
   If Not errstring = "" Then MsgBox "载入参数错误发生在：" & errstring & "!  请重新载入参数", vbCritical + vbCritical, "错误"
 Exit Sub
ErrHandler:
' 用户按了“取消”按钮
 Screen.MousePointer = 0
Close
Exit Sub
End Sub

Private Sub Command5_Click()

End Sub

Private Sub Command6_Click()

End Sub


Private Sub F1Book1_Click(ByVal nRow As Long, ByVal nCol As Long)
If nRow < 3 Or Not nCol = 0 Then Exit Sub
If (nRow - 1) < Val(frmmain.F1Book1.MaxRow - Val(frmmain.xtoll.Text) * Val(ytoll.Text)) Then Exit Sub
If F1Book1.TextRC(nRow, 1) = "" Then Exit Sub
      clickPdOKNg nRow, F1Book1.MaxCol
'          frmmain.F1Book1.SelStartCol = nCol
 '         frmmain.F1Book1.SelEndCol = nCol
End Sub

Private Sub Form_Load()
On Error Resume Next
f1row = 1
Sta1.Panels(1).Text = "欢迎使用深蓝自动化有限公司开发的设备--"
Text1.Text = GetSetting(AppName:="myapp", Section:="text1", Key:="value", Default:="NO001")
Text2.Text = GetSetting(AppName:="myapp", Section:="text2", Key:="value", Default:="SLAN")
 If App.PrevInstance Then
                 MsgBox "程序已经运行不能加载了！", vbOKOnly + vbInformation, "提示"
                       Unload Me: Exit Sub
             End If
    With com1
      .CommPort = GetSetting(AppName:="myapp", Section:="c1", Key:="value", Default:="1")
        If .PortOpen = False Then .PortOpen = True
        .Settings = "115200,e,8,1"
    End With
    com1.Output = strCR             '发出开始通讯命令"CR"
    strReceived = WaitRS(com1, vbCrLf, 50)
    If InStr(strReceived, strDTR) > 0 Then
           Sta1.Panels(2).Text = "通信成功！"
    Else
       MsgBox "通信不成功,请重新开始!", vbCritical, "错误"
       setnoenable  '无较眷念
       frmmain.mstart.Enabled = False
       Sta1.Panels(2).Text = "通信失败！"
   End If
    F1Book1.ShowColHeading = False
    F1Book1.ShowRowHeading = False
    F1Book1.ShowEditBar = False
    f1row = 3
    doing = False
    S3 = False: S4 = False
    '=========
    Open App.Path & "\sys.ini" For Random As #2
Get #2, 1, sam
datasavepath = Trim(sam)
Get #2, 2, sam
pdyuyanok = Trim(sam)
Get #2, 3, sam
pdyuyanng = Trim(sam)
Get #2, 4, sam
f1bookdatatype = Val(sam)
Get #2, 5, sam
autosavedata = Val(sam)
Get #2, 6, sam
closesavedata = Val(sam)
Get #2, 7, sam
zhuijiaboolean = Val(sam)
    Close
    F1Book1.TextRC(2, 1) = "№"
    F1Book1.TextRC(1, 2) = "判           根"
    F1Book1.TextRC(2, 2) = "定           据"
    F1Book1.TextRC(3, 2) = "时间"
    
    F1Book1.TextRC(1, 3) = "测量点"
    F1Book1.TextRC(2, 3) = "上限"
    F1Book1.TextRC(3, 3) = "下限"
bianhao = 1
leixing.Caption = ""
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If closesavedata = 1 Or closesavedata = True Then savetopath
Cancel = True
mexit_Click
End Sub

Private Sub Form_Resize()
'On Error Resume Next
CoolBar1.Width = frmmain.ScaleWidth
Frame2.Width = frmmain.ScaleWidth - 20

Frame5.Left = Frame4.Width + 180
Frame5.Width = frmmain.ScaleWidth - Frame4.Width - Frame6.Width - 400
Frame6.Left = Frame4.Width + Frame5.Width + 250


F1Book1.Width = frmmain.ScaleWidth
F1Book1.Height = frmmain.ScaleHeight - CoolBar1.Height - Frame2.Height - 300

Frame1.Move (Frame5.Width - Frame1.Width - graph.Width) / 3, Frame1.Top, Frame1.Width, Frame1.Height
graph.Move Frame5.Width - graph.Width - 250 - (Frame5.Width - Frame1.Width - graph.Width) / 3, Frame1.Top, Frame1.Width, Frame1.Height

'picture1.Move Frame5.Width / 2 - picture1.Width * 2, picture1.Top, picture1.Width, picture1.Height
'picture2.Move picture1.Left + picture1.Width + 250, picture2.Top, picture1.Width, picture1.Height

'Frame1.Move Frame5.Width - 2500, Frame1.Top, Frame1.Width, Frame1.Height
End Sub

Private Sub mcom_Click()
communication.Show 1
End Sub

Private Sub mcontrol_Click()
 If Timer1.Enabled = True Then
     jiankongboolean = True
   Else
     jiankongboolean = False
     End If
If Toolbar1.Buttons(1).Caption = "停止监视" Then
 mstart_Click
 End If
Load fsetcontrol
addtime (300)
fsetcontrol.Show 1
End Sub

Private Sub mexit_Click()
    If MsgBox("  您确认退出吗？", vbExclamation + vbOKCancel, "退出") = vbCancel Then
              Cancel = True
         Else
           ' mmsavedata_Click
            If com1.PortOpen = True Then com1.PortOpen = False