module1.bas

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

Attribute VB_Name = "Module1"
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'声明调用的GetTickCount函数和Sleep函数
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public f1row, f1col As Integer 'F1book1的行数。
Public mingzi As String         '以月日小时分钟为名保存文件
Public S3, S4, ss3, ss4 As Boolean '总的判定
Public ngtall, oktall As Integer '总的NG
Public Tenstsam(1 To 5) As Boolean '测量的方法！
Public cntpoints As Integer '///设置测量点的数量
Public diaupper(1 To 8), dialower(1 To 8), zyupper(1 To 8), txupper(1 To 8) As Single
Public ronghang, ronglei As Integer  '行列
Public okngboolean As Integer      '总的OKNG
Public Const mdbj As Integer = 53 / 69 * 100 '马达的转换
Public zdboolean As Boolean '//是否显示锥度
Public Bzdupper, Bzdlower As Single '锥度的上下限
Public zd1, zd2 As Integer
Public zdgongshi As String
Public datastring1, datastring2, datastring3, datastring4, datastring5 As String '//数据反村
Public pdyuyanok, pdyuyanng, datasavepath As String   '为程序参数
Public autosavedata, closesavedata, zhuijiaboolean As Boolean
Public f1bookdatatype As Integer
Public dialig1, dialig2 As Integer '为液晶字的列数
Public bianhao As Integer '为总的编号
Public mainmaxcol As Integer '为总的列数
Public jiankongboolean As Boolean '为是否自动开启

'Public emputydata, emputydata1 As Integer '为空的数据
'处理从COM口中得到的数据，并进行处理返回一个比较规范的字符
Function WaitRS(Com As MSComm, rs As String, DT As Integer) As String
    Dim buf$, TT As Long
     buf = ""
    TT = GetTickCount
    Do
         DoEvents
        buf = buf & Com.Input
    Loop Until InStr(1, buf, rs) > 0 Or GetTickCount - TT > DT
    If InStr(1, buf, rs) > 0 Then
         WaitRS = Trim(buf)
    Else
        WaitRS = ""
     End If

End Function
Function addtime(DT As Long)
  Dim TT As Long
  TT = GetTickCount()
  Do
    DoEvents
    If GetTickCount - TT < 0 Then TT = GetTickCount
  Loop Until GetTickCount - TT >= DT
End Function


Function backtored(ByVal row As Integer, ByVal col As Integer, ByVal fsize As Integer)
                            frmmain.F1Book1.SelStartCol = col
                            frmmain.F1Book1.SelEndCol = col
                            frmmain.F1Book1.SelEndRow = row
                            frmmain.F1Book1.SelStartRow = row
                            frmmain.F1Book1.SetFont "宋体", fsize, False, False, False, False, vbRed, False, False
End Function
Function backtogreen(ByVal row As Integer, ByVal col As Integer, ByVal fsize As Integer)
                            frmmain.F1Book1.SelStartCol = col
                            frmmain.F1Book1.SelEndCol = col
                            frmmain.F1Book1.SelEndRow = row
                            frmmain.F1Book1.SelStartRow = row
                            frmmain.F1Book1.SetFont "宋体", fsize, True, False, False, False, vbGreen, False, False

End Function
Function backfont(ByVal row As Integer, ByVal col As Integer, ByVal fsize As Integer)
                            frmmain.F1Book1.SelStartCol = col
                            frmmain.F1Book1.SelEndCol = col
                            frmmain.F1Book1.SelEndRow = row
                            frmmain.F1Book1.SelStartRow = row
                            frmmain.F1Book1.SetFont "宋体", fsize, True, False, False, False, &H0&, False, False
End Function
Function backfont1(ByVal row As Integer, ByVal col As Integer, ByVal fsize As Integer)
                            frmmain.F1Book1.SelStartCol = col
                            frmmain.F1Book1.SelEndCol = col
                            frmmain.F1Book1.SelEndRow = row
                            frmmain.F1Book1.SelStartRow = row
                            frmmain.F1Book1.SetFont "宋体", fsize, False, False, False, False, &H0&, False, False
End Function
'求反正切
Function pyramidal(ByVal diameter1 As Single, ByVal diameter2 As Single, ByVal distance As Single)
'pyramidal = Atn(Abs(diameter2 - diameter1) / 2 / distance) * 180 / 3.1415927
pyramidal = Abs(diameter2 - diameter1)
End Function
Function savetopath() As String
Dim sam As String
On Error Resume Next
        If zhuijiaboolean = False Then mingzi = getname
             If mingzi = "" Then Exit Function
      Select Case f1bookdatatype
      Case 2
      frmmain.F1Book1.Write datasavepath & "\" & mingzi & ".htm", 10
      Case 1
       frmmain.F1Book1.Write datasavepath & "\" & mingzi & ".txt", 6
        Case Else
       frmmain.F1Book1.Write datasavepath & "\" & mingzi & ".xls", 11
       End Select
     sam = Dir(datasavepath & "\" & mingzi, vbDirectory)
     If sam = "" Then MkDir datasavepath & "\" & mingzi
    SavePicture frmmain.graph.Image, datasavepath & "\" & mingzi & "\" & frmmain.dname.Text & "(" & bianhao & ")" & ".bmp"
End Function
Function getname() As String
 Dim h1 As Integer, h2 As Integer
     Dim m1 As Integer, m2 As Integer
     Dim t1, t2 As Variant
    t1 = Format(Time, "h:mm:ss")
     h1 = Val(Hour(t1)): m1 = Val(Minute(t1))
    t2 = Format(Date, "Long Date")
      h2 = Val(Month(t2)): m2 = Val(Day(t2))
    getname = h2 & "-" & m2 & "-" & h1 & "-" & m1 & "--" & frmmain.dname.Text & "(" & bianhao & ")"
End Function
Function setnoenable()
'frmmain.mstart.Enabled = False
frmmain.mview.Enabled = False
frmmain.mout.Enabled = False
frmmain.saveto.Enabled = False
frmmain.Toolbar1.Buttons(2).Enabled = False
frmmain.Toolbar1.Buttons(3).Enabled = False
frmmain.Toolbar1.Buttons(4).Enabled = False
frmmain.Toolbar1.Buttons(5).Enabled = False
frmmain.Toolbar1.Buttons(6).Enabled = False
frmmain.Toolbar1.Buttons(7).Enabled = False
frmmain.Toolbar1.Buttons(8).Enabled = False
'frmmain.CoolBar1.Enabled = False
'frmmain.DataCombo1.Enabled = False
'frmmain.F1Book1.Enabled = False
End Function
Function inigraph(ByVal countx As Integer, ByVal county As Integer)
Dim i, j As Integer
Dim CX, CY, Radius, Limit   ' Declare variable.
With frmmain.graph
   .Cls
   .ScaleMode = 3   ' 以像素为单位。
   .FillStyle = 0
   .FillColor = RGB(255, 255, 255)
   CX = .ScaleWidth / (countx + 1) ' X 位置。
   CY = .ScaleHeight / (county + 1) ' Y 位置。
'Picture1.Circle (CX, CY), 59, RGB(255, 0, 0)  '红
'Picture1.Circle (CX, CY), 59, RGB(0, 0, 255) '蓝
If CX > CY Then
For j = 1 To 25
 For i = 1 To 20
    frmmain.graph.Circle (j * CX - CY / 2, i * CY - CY / 2), CY / 2, RGB(255, 255, 255)
    Next i
    Next j
Else
For j = 1 To 25
 For i = 1 To 20
     frmmain.graph.Circle (j * CX - CX / 2, i * CY - CX / 2), CX / 2, RGB(255, 255, 255)
    Next i
    Next j
End If
End With
    
End Function
Function initok(ByVal numberokhang As Integer, ByVal numberoklei As Integer)
Dim row, col As Integer
row = numberokhang
col = numberoklei
If col = 0 Then
    row = row - 1
    col = 20
    End If
Dim i, j As Integer
Dim CX, CY, Radius, Limit   ' Declare variable.
With frmmain.graph
   .ScaleMode = 3   ' 以像素为单位。
   .FillStyle = 0
   .FillColor = RGB(0, 255, 0)
   CX = .ScaleWidth / (25 + 1) ' X 位置。
   CY = .ScaleHeight / (20 + 1) ' Y 位置。
'frmmain.graph.Circle (CX, CY), 59, RGB(255, 0, 0)  '红
'frmmain.graph.Circle (CX, CY), 59, RGB(0, 0, 255) '蓝
If CX > CY Then
     frmmain.graph.Circle (row * CX - CY / 2, col * CY - CY / 2), CY / 2, RGB(0, 255, 0)
Else
     frmmain.graph.Circle (row * CX - CX / 2, col * CY - CX / 2), CX / 2, RGB(0, 255, 0)
End If
End With
End Function
Function initng(ByVal numbernghang As Integer, ByVal numbernglei As Integer)
Dim row, col As Integer
row = numbernghang
col = numbernglei
If col = 0 Then
    row = row - 1
    col = 20
    End If
Dim i, j As Integer
Dim CX, CY, Radius, Limit   ' Declare variable.
With frmmain.graph
   .ScaleMode = 3   ' 以像素为单位。
   .FillStyle = 0
   .FillColor = RGB(255, 0, 0)
   CX = .ScaleWidth / (25 + 1) ' X 位置。
   CY = .ScaleHeight / (20 + 1) ' Y 位置。
'frmmain.graph.Circle (CX, CY), 59, RGB(255, 0, 0)  '红
'frmmain.graph.Circle (CX, CY), 59, RGB(0, 0, 255) '蓝
If CX > CY Then
     frmmain.graph.Circle (row * CX - CY / 2, col * CY - CY / 2), CY / 2, RGB(255, 0, 0)
Else
     frmmain.graph.Circle (row * CX - CX / 2, col * CY - CX / 2), CX / 2, RGB(255, 0, 0)
End If
End With
End Function

Function tenstmoth(ByVal avexd As Integer, ByVal avezj As Integer, ByVal tx As Integer, ByVal zy As Integer, ByVal minzj As Integer, ByVal maxzj As Integer) As Integer
tenstmoth = avexd * 32 + avezj * 16 + tx * 8 + zy * 4 + minzj * 2 + maxzj
End Function
Function clearpoints(cnt As Integer)
Dim clearstring, errstring As String
clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
frmmain.com1.Output = "WR" & Space(1) & "DM" & 50 + cnt & Space(1) & 0 & vbCr
clearstring = WaitRS(frmmain.com1, vbCrLf, 40)
 If Not clearstring = "OK" & vbCr & vbLf Then errstring = errstring & ",成品半成品"
End Function
Function clearpointsALL()
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 50 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 60 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 70 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 80 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 90 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 100 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
addtime (100)
frmmain.com1.Output = "WRS" & Space(1) & "DM" & 110 & Space(1) & 8 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & Space(1) & 0 & vbCr
End Function
Function displaybiaotu(ByVal ininteger As Integer, ByVal ppoints As Integer, ByVal diamoth As Integer)
Dim i As Integer, j As Integer
If ininteger >= 32 Then
   zdboolean = True
   ininteger = ininteger - 32
 End If

If ininteger >= 16 Then
   Tenstsam(1) = True
   ininteger = ininteger - 16
   Else
   Tenstsam(1) = False
 End If

If ininteger >= 8 Then
    Tenstsam(2) = True
   ininteger = ininteger - 8
   Else
   Tenstsam(2) = False
 End If
 
 If ininteger >= 4 Then
    Tenstsam(3) = True
   ininteger = ininteger - 4
    Else
   Tenstsam(3) = False
 End If
 
 If ininteger >= 2 Then
    Tenstsam(4) = True
   ininteger = ininteger - 2
      Else
   Tenstsam(4) = False
 End If
 
 If ininteger >= 1 Then
    Tenstsam(5) = True
   ininteger = ininteger - 1
      Else
   Tenstsam(5) = False
 End If

If zdboolean = True Then
i = 4
frmmain.F1Book1.TextRC(1, 4) = "斜度"
frmmain.F1Book1.NumberRC(2, 4) = Bzdupper
frmmain.F1Book1.NumberRC(3, 4) = Bzdlower
Else
i = 3
End If

If Tenstsam(2) = True Then '同心
   For j = 1 To ppoints
   i = i + 1
   frmmain.F1Book1.TextRC(1, i) = "C" & j
   frmmain.F1Book1.NumberRC(2, i) = txupper(j)
   frmmain.F1Book1.NumberRC(3, i) = 0
  Next j
End If
If Tenstsam(3) = True Then '真圆
   For j = 1 To ppoints
        i = i + 1
        frmmain.F1Book1.TextRC(1, i) = "R" & j
        frmmain.F1Book1.NumberRC(2, i) = zyupper(j)
        frmmain.F1Book1.NumberRC(3, i) = 0
     Next j
End If

If Tenstsam(1) = True Then '平均
   For j = 1 To ppoints
      i = i + 1
      frmmain.F1Book1.TextRC(1, i) = "AVR" & j
      If diamoth = 0 Then
         frmmain.F1Book1.NumberRC(2, i) = diaupper(j)
         frmmain.F1Book1.NumberRC(3, i) = dialower(j)
         If zdboolean = True And j = zd1 + 1 Then
           zdgongshi = int_char(Val(i)) & 5 & "-"
             dialig1 = Val(i)
         End If
         If zdboolean = True And j = zd2 + 1 Then
           zdgongshi = "ABS(" & zdgongshi & int_char(Val(i)) & 5 & ")"
           frmmain.F1Book1.FormulaRC(5, 4) = zdgongshi
           dialig2 = Val(i)
           End If
         Else
         frmmain.F1Book1.NumberRC(2, i) = 99
         frmmain.F1Book1.NumberRC(3, i) = 0
       End If
  Next j