📄 frmmodel.frm
字号:
Width = 1455
End
Begin VB.OptionButton OptStandpipe
Caption = "立管压力"
BeginProperty Font
Name = "仿宋_GB2312"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 4
Top = 480
Value = -1 'True
Width = 1215
End
Begin VB.OptionButton OptTorque
Caption = "转盘扭矩"
BeginProperty Font
Name = "仿宋_GB2312"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 3
Top = 1080
Width = 1215
End
Begin VB.CommandButton CmdEnd
Caption = "结束&E"
Enabled = 0 'False
BeginProperty Font
Name = "仿宋_GB2312"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 3240
TabIndex = 2
Top = 8520
Width = 1335
End
End
Begin MSAdodcLib.Adodc Adodc1
Height = 375
Left = 1320
Top = 9240
Visible = 0 'False
Width = 1200
_ExtentX = 2117
_ExtentY = 661
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
End
Attribute VB_Name = "FrmAQS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim MaxPlotNo As Long
Dim prevalue1&, prevalue2&, prevalue3&, prevalue4&, prevalue5&, prevalue6&
Dim port(5)
Dim sendno(2)
Dim sendcmb(1)
Dim smsc(2)
Dim rSMSC As String, rNo As String, rTime As String, rSMS As String
Dim send As String
Dim n1%, n2%, n3%, n4%, n5%, n6%
Dim limit1$, limit2$, limit3$, limit4$, limit5$, limit6$
Private Function sendSMS(comm As MSComm, s1 As String, s2 As String, s3 As String) As Boolean '发送子函数
's1为中心号码，s2为发送手机号码，s3为短消息内容
Dim i As Integer
Dim smsc As String, sendno As String, sms As String
Dim sms1 As String, sms2 As String
Dim buf As String
i = 15 + 2 * Len(s3)
smsc = Mid(s1, 2)
sendno = Mid(s2, 2)
sms = Trim(s3)
sms1 = "AT+CMGS=" & i & vbCr '发送短消息的AT指令
sms2 = sendPDU(smsc, sendno, sms)
comm.InBufferCount = 0
comm.Output = sms1
timedelay (100) '延时100毫秒
comm.Output = sms2
buf = waitRS(comm, "+CMGS:", 30000)
If buf = "" Then
sendSMS = False
Else
lblmsg.Caption = "发送成功"
sendSMS = True
End If
End Function
Private Function ATCMD(s1 As String, s2 As String) As Boolean
Dim dummyar As Integer
Dim receivebuffer As String, tmpbool As Boolean
MSComm2.InBufferCount = 0
MSComm2.Output = s1 + vbCr
timedelay (100)
If MSComm2.InBufferCount > 0 Then
receivebuffer = receivebuffer + MSComm2.Input
If InStr(receivebuffer, "OK") Then
tmpbool = True
End If
If InStr(receivebuffer, "ERROR") Then
tmpbool = False
End If
End If
ATCMD = tmpbool
End Function
Private Function readSMS(n As String) As String '读短消息子函数
Dim s1 As String, s2 As String, s3 As String, s4 As String
Dim r1 As String, r2 As String, r4 As String
s1 = Mid(n, 5, 14)
r1 = gsmSerializeNumber(s1)
rSMSC = "+" & r1
s2 = Mid(n, 25, 14)
r2 = gsmSerializeNumber(s2)
rNo = "+" & r2
s3 = Mid(n, 43, 14)
rTime = gsmSerializeNumber(s3)
s4 = Mid(n, 57)
r4 = Mid(s4, 3)
rSMS = Unicode2Asc(r4)
End Function
Private Function sendPDU(s1 As String, s2 As String, s3 As String) As String '发送PDU
Dim ss1 As String, ss2 As String, ss3 As String
Dim ss4 As String, ss5 As String, ss6 As String
ss1 = gsmInvertNumber(s1)
ss2 = gsmInvertNumber(s2)
ss3 = Asc2Unicode(s3)
ss4 = "0891"
ss5 = "11000D91"
ss6 = "000800"
sendPDU = ss4 & ss1 & ss5 & ss2 & ss6 & ss3 & Chr$(26)
End Function
Private Function gsmSerializeNumber(n As String) As String '两两颠倒转换成正常顺序
Dim nlen, i As Integer
Dim s1 As String, s2 As String, s3 As String, s4 As String
Dim s5 As String
nlen = Len(n)
s4 = ""
For i = 1 To nlen Step 2
s1 = Mid(n, i, 1)
s2 = Mid(n, i + 1, 1)
s3 = s2 + s1
s4 = s4 + s3
Next i
s5 = Left(s4, nlen - 1)
gsmSerializeNumber = s5
End Function
Private Function gsmInvertNumber(n As String) As String '把正常顺序转换成两两颠倒顺序
Dim number As String, s1 As String, s2 As String, s3 As String, s4 As String
Dim nlen As Integer, i As Integer
number = n & "F"
nlen = Len(number)
s4 = ""
For i = 1 To nlen Step 2
s1 = Mid(number, i, 1)
s2 = Mid(number, i + 1, 1)
s3 = s2 + s1
s4 = s4 + s3
Next i
gsmInvertNumber = s4
End Function
Private Function Asc2Unicode(n As String) As String '把汉字转换成unicode码
Dim s1 As String, s2 As String, s4 As String, s3 As Long, i As Integer
s1 = Hex(LenB(n)) '字符串n的字节数
If Len(s1) = 1 Then
s1 = "0" + s1
End If
s2 = s1
s1 = ""
For i = 1 To Len(n)
s1 = Mid(n, i, 1)
s3 = AscW(s1)
If s3 < 0 Then
s4 = Hex(s3 + 65536)
ElseIf s3 >= 0 And s3 <= 255 Then '如果不足4位要加00
s4 = "00" + Hex(s3)
Else
s4 = Hex(s3)
End If
s2 = s2 + s4
Next i
Asc2Unicode = s2
End Function
Private Function Unicode2Asc(n As String) As String '把Unicode转换成汉字
Dim nlen As Integer, i As Integer
Dim ucode As String, j As String, asc As String
nlen = Len(n)
For i = 1 To nlen Step 4
ucode = Mid(n, i, 4)
j = "&h" & ucode
asc = asc + ChrW(Val(j))
Next i
Unicode2Asc = asc
End Function
Private Function plot(data As String, Pic As PictureBox, n As Integer, prevalue&) As Boolean
Dim i&, X!, Y!
Dim valuestr&
valuestr = Val(data)
If n = 0 Then
Pic.Cls
Pic.Scale (0, 10)-(MaxPlotNo, -10)
Pic.Line (0, 0)-(MaxPlotNo, 0), vbRed
Pic.Line (0, 10)-(0, -10), vbBlue
Pic.DrawWidth = 1
Pic.DrawStyle = vbDot
'绘x轴上的方格线，均分10等份
For i = 0 To 9
X = i * MaxPlotNo / 10
Pic.Line (X, -10)-(X, 10)
Next i
'绘y轴上的方格线，均分15等份
For i = -10 To 10
Y = i * 10 / 10
Pic.Line (0, Y)-(MaxPlotNo, Y)
Next i
Pic.DrawWidth = 2 '绘制宽度改为2
Pic.DrawStyle = vbSolid '以实线绘图
Pic.PSet (0, valuestr) '设置起点
Else
'以下是判断现在读数是否大于前一次的读数，如果是，则以红线绘线；如果否，则以蓝线绘线
If valuestr > prevalue - 0.01 Then
Pic.Line (n - 1, prevalue)-(n, valuestr), RGB(255, 0, 0)
'由上一次的位置画至此点
Else
Pic.Line (n - 1, prevalue)-(n, valuestr), RGB(0, 0, 255)
End If
End If
prevalue = valuestr
n = n + 1
If n > MaxPlotNo Then n = 0 '超过范围则数值归零
plot = True
End Function
Private Function dialNo(d As String) As Boolean
'拨通电话报警
MSComm2.Output = "ATD" & d & ";" & vbCr
timedelay (20000)
MSComm2.Output = "ATH" & vbCr '响两声后挂断，可以通过延时的时间长短来控制响声的长短
dialNo = True
End Function
Private Sub CmdEnd_Click()
Timer1.Enabled = False
CmbSMSC.Enabled = True
If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
If MSComm2.PortOpen = True Then
MSComm2.PortOpen = False
End If
Frame4.Enabled = True
CmdStart.Enabled = False
CmdInit.Enabled = True
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdInit_Click()
Dim cs As String, cn As String, cf As String
Dim smscNO As String
On Error GoTo err
MSComm2.CommPort = Val(CmbPort.Text)
MSComm2.PortOpen = True '打开端口
If Not ATCMD("AT", "连接测试") Then
GoTo connectFail
End If
MsgBox "连接成功！"
cn = "AT+CNMI=2,1,0,0,1"
If CmbSMSC.Text = "" Then
GoTo smscfail
Else
smscNO = Trim(CmbSMSC.Text)
cs = "AT+CSCA=" & Chr$(34) & smscNO & Chr$(34)
CmbSMSC.Enabled = False
End If
cf = "AT+CMGF=0"
If Not ATCMD(cn, "选择新的短消息提示") Then
GoTo InitFail
End If
If Not ATCMD(cs, "短消息服务中心号码设置") Then
GoTo InitFail
End If
If Not ATCMD(cf, "选择短消息支持文字格式") Then
GoTo InitFail
End If
MsgBox "初始化正常！"
CmdInit.Enabled = False
CmdOpenCOM.Enabled = True
Frame1.Enabled = True
Frame4.Enabled = False
Exit Sub
err:
MsgBox "对不起，您选择的端口已经被打开，请选择别的端口", vbOKOnly, "通知"
Exit Sub
connectFail: MsgBox "连接失败！"
MSComm2.PortOpen = False
CmdInit.Enabled = False
Exit Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -