?? 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 + -