📄 module1.bas
字号:
Attribute VB_Name = "Module1"
'半透明效果
'Public Declare Function AlphaBlending Lib "msimg32.dll" Alias "AlphaBlend" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BF As Long) As Long
'==============================
'Dim w As Long, h As Long
'Dim TempLong As Long
'w = Picture1.ScaleWidth
'h = Picture1.ScaleHeight
'Call AlphaBlend(Me.hdc, Picture1.Left, Picture1.Top, w, h, Picture1.hdc, 0, 0, w, h, 100)
'Refresh
'===============================
'锁定鼠标键盘
Public Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'改变光标
Public Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Public Declare Function LoadCursorBynum& Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long)
Public Declare Function SetSystemCursor Lib "user32" (ByVal hcur As Long, ByVal id As Long) As Long
Public Const OCR_NORMAL = 32512
Public Const IDC_ARROW = 32512&
'不规则窗口
Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'将本窗口放在主窗口中
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
'窗口最上
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal Cy As Long, ByVal wFlags As Long) As Long
'透明窗口
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public hBitmap As Long
';Jet OLEDB:Database Password=密码
'移动控件
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_SYSCOMMAND = &H112
Public Const SC_MOVE = &HF012
Public Const DataLink = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Public Const DataLink1 = "\database.dat;Persist Security Info=False;Jet OLEDB:Database Password=clj98*"
Public Const DataLink2 = "\lwcl\lwcl.dat;Persist Security Info=False;Jet OLEDB:Database Password=clj98*"
Public Const DataLink3 = ".dat;Persist Security Info=False"
Public Const DataLink4 = "\log.dat;Persist Security Info=False;Jet OLEDB:Database Password=clj98*"
Public ZhuZi, cs_R, cs_T, Jdcs_No, Ins_Use, Print_Begin, Print_End, Print_Set, Print_Yes, Print_All, Print_use
Public Const Pa = 3.9083 * (10 ^ -3), Pb = -5.775 * (10 ^ -7), Pc = -4.183 * (10 ^ -12), Ca = 4.28 * (10 ^ -3), Cb = -9.31 * (10 ^ -8), Cc = 1.23 * (10 ^ -9), Pid = 3.14159265358979 / 180
Public PassWord As String, PWtext As String, LoginUser As String, UserAuth As String, SetTemp_id As Integer, Backup_v(15), PrintStr As String
Public Addgyqx_value(9, 32), Addgyqx_att As String, TempQx_id As Integer, ManageStr As String, Contr_value(50, 17), Contr_gyqx(50, 30) As Integer, PrintSel(18)
Public Addgyqx_Find As Boolean, Controlx_Find As Boolean, ClosePr_End As Boolean, ManageList_value(50, 11), LoginCh As Boolean, DataRecS(1) As String
Public LogDate As String, LogDate1 As String, Loglist As String, Loglist1 As String, SysValue(1), TcValue(27, 16), ModFixValue(120, 11), TbValue(49, 23)
Public Sub RtoT()
If cs_R = "Pt100" Or cs_R = "Pt10" Then
If cs_T > 0 Then
ZhuZi = Val(Mid(cs_R, 3, 3)) * (1 + Pa * cs_T + Pb * cs_T * cs_T)
Else
ZhuZi = Val(Mid(cs_R, 3, 3)) * ((1 + Pa * cs_T + Pb * cs_T * cs_T) + Pc * (cs_T - 100) * cs_T * cs_T * cs_T)
End If
Else
ZhuZi = Val(Mid(cs_R, 3, 3)) * (1 + Ca * cs_T + Cb * cs_T * (cs_T - 100) + Cc * cs_T * cs_T * (cs_T - 100))
End If
If Val(Mid(cs_R, 3, 3)) = 100 Then
ZhuZi = Format(ZhuZi, "0.000")
Else
ZhuZi = Format(ZhuZi, "0.000")
End If
End Sub
Function HextoD(HextoD_16 As String) As Integer
HextoD = 0
For i = Len(HextoD_16) To 1 Step -1
If Val(Mid(HextoD_16, i, 1)) > 0 And Val(Mid(HextoD_16, i, 1)) <= 9 Then
HextoD = HextoD + Val(Mid(HextoD_16, i, 1)) * 16 ^ (Len(HextoD_16) - i)
Else
Select Case Mid(HextoD_16, i, 1)
Case "A"
HextoD = HextoD + 10 * 16 ^ (Len(HextoD_16) - i)
Case "B"
HextoD = HextoD + 11 * 16 ^ (Len(HextoD_16) - i)
Case "C"
HextoD = HextoD + 12 * 16 ^ (Len(HextoD_16) - i)
Case "D"
HextoD = HextoD + 13 * 16 ^ (Len(HextoD_16) - i)
Case "E"
HextoD = HextoD + 14 * 16 ^ (Len(HextoD_16) - i)
Case "F"
HextoD = HextoD + 15 * 16 ^ (Len(HextoD_16) - i)
End Select
End If
Next
End Function
Public Sub RtoC()
If cs_R = "Pt100" Or cs_R = "Pt10" Then
cs_T = (-Pa + Sqr(Pa ^ 2 - 4 * Pb * (1 - ZhuZi / Val(Mid(cs_R, 3))))) / (2 * Pb)
Else
'铜电阻计算公式
End If
cs_T = Format(cs_T, "0.00")
End Sub
Public Sub PassWordSet()
Dim tem As String
PassWord = ""
tem = ""
For i = 1 To Len(PWtext)
tem = tem & Asc(Mid(PWtext, i, 1))
Next
tem = Mid(tem, Len(tem), 1) & Mid(tem, 1, Len(tem) - 1)
For i = 1 To Len(tem) Step 3
PassWord = PassWord & Chr(Val(Mid(tem, i, 3)) Mod 256)
Next
End Sub
Public Sub Delay(Delay_Value)
temp = Timer
Do While Timer - temp < Delay_Value
DoEvents
If Timer - temp < 0 Then
temp = temp - 86400
End If
Loop
End Sub
Public Sub Delay2(Delay_Value)
temp = Timer
Do While Timer - temp < Delay_Value
DoEvents
If Timer - temp < 0 Then
temp = temp - 86400
End If
Loop
End Sub
Public Sub Delay3(Delay_Value)
temp = Timer
Do While Timer - temp < Delay_Value
DoEvents
If Timer - temp < 0 Then
temp = temp - 86400
End If
Loop
End Sub
Public Sub Delay4(Delay_Value)
temp = Timer
Do While Timer - temp < Delay_Value
DoEvents
If Timer - temp < 0 Then
temp = temp - 86400
End If
Loop
End Sub
Public Sub Delay5(Delay_Value)
temp = Timer
Do While Timer - temp < Delay_Value
DoEvents
If Timer - temp < 0 Then
temp = temp - 86400
End If
Loop
End Sub
Function TC_CtoV(TC_CtoV_c, TC_CtoV_Type As String)
Dim TCK300(1)
For i = 0 To 27
If TcValue(i, 0) = TC_CtoV_Type And TcValue(i, 16) = False And TcValue(i, 12) <= TC_CtoV_c And TcValue(i, 13) >= TC_CtoV_c Then
temp = i
Exit For
End If
Next
If Len(temp) > 0 Then
TC_CtoV = 0
For i = 0 To 10
TC_CtoV = TC_CtoV + TcValue(temp, i + 1) * TC_CtoV_c ^ (i)
Next
If TC_CtoV_Type = "K" And TC_CtoV_c < 300 Then
temp = Int(TC_CtoV_c / 10) * 10
For j = temp To temp + 1
Select Case j
Case 0
TC_CtoV = 0
Case 1
TC_CtoV = 0.039
Case 10
TC_CtoV = 0.397
Case 11
TC_CtoV = 0.437
Case 20
TC_CtoV = 0.798
Case 21
TC_CtoV = 0.838
Case 30
TC_CtoV = 1.203
Case 31
TC_CtoV = 1.244
Case 40
TC_CtoV = 1.612
Case 41
TC_CtoV = 1.653
Case 50
TC_CtoV = 2.023
Case 51
TC_CtoV = 2.064
Case 60
TC_CtoV = 2.436
Case 61
TC_CtoV = 2.478
Case 70
TC_CtoV = 2.851
Case 71
TC_CtoV = 2.893
Case 80
TC_CtoV = 3.267
Case 81
TC_CtoV = 3.308
Case 90
TC_CtoV = 3.682
Case 91
TC_CtoV = 3.723
Case 100
TC_CtoV = 4.096
Case 101
TC_CtoV = 4.138
Case 110
TC_CtoV = 4.509
Case 111
TC_CtoV = 4.55
Case 120
TC_CtoV = 4.92
Case 121
TC_CtoV = 4.961
Case 130
TC_CtoV = 5.328
Case 131
TC_CtoV = 5.369
Case 140
TC_CtoV = 5.735
Case 141
TC_CtoV = 5.775
Case 150
TC_CtoV = 6.138
Case 151
TC_CtoV = 6.179
Case 160
TC_CtoV = 6.54
Case 161
TC_CtoV = 6.58
Case 170
TC_CtoV = 6.941
Case 171
TC_CtoV = 6.981
Case 180
TC_CtoV = 7.34
Case 181
TC_CtoV = 7.38
Case 190
TC_CtoV = 7.739
Case 191
TC_CtoV = 7.779
Case 200
TC_CtoV = 8.138
Case 201
TC_CtoV = 8.178
Case 210
TC_CtoV = 8.539
Case 211
TC_CtoV = 8.579
Case 220
TC_CtoV = 8.94
Case 221
TC_CtoV = 8.98
Case 230
TC_CtoV = 9.343
Case 231
TC_CtoV = 9.383
Case 240
TC_CtoV = 9.747
Case 241
TC_CtoV = 9.788
Case 250
TC_CtoV = 10.153
Case 251
TC_CtoV = 10.194
Case 260
TC_CtoV = 10.561
Case 261
TC_CtoV = 10.602
Case 270
TC_CtoV = 10.971
Case 271
TC_CtoV = 11.012
Case 280
TC_CtoV = 11.382
Case 281
TC_CtoV = 11.423
Case 290
TC_CtoV = 11.795
Case 291
TC_CtoV = 11.836
Case 300
TC_CtoV = 12.209
Case 301
TC_CtoV = 12.25
End Select
If j = temp Then
TCK300(0) = TC_CtoV
Else
TCK300(1) = TC_CtoV
End If
Next j
TC_CtoV = (TC_CtoV_c - temp) * (TCK300(1) - TCK300(0)) + TCK300(0)
End If
TC_CtoV = Val(Format(TC_CtoV, "0.00000"))
Else
TC_CtoV = -1
End If
End Function
Function TC_VtoC(TC_VtoC_v, TC_VtoC_Type As String)
For i = 0 To 27
If TcValue(i, 0) = TC_VtoC_Type And TcValue(i, 16) = True And TcValue(i, 14) <= TC_VtoC_v And TcValue(i, 15) >= TC_VtoC_v Then
temp = i
Exit For
End If
Next
If Len(temp) > 0 Then
TC_VtoC = 0
For i = 0 To 10
TC_VtoC = TC_VtoC + TcValue(temp, i + 1) * TC_VtoC_v ^ (i)
Next
TC_VtoC = Val(Format(TC_VtoC, "0.0"))
Else
TC_VtoC = -1
End If
End Function
Public Sub ErrLogW(Werr, Werror, i, j, Errsub)
On Error Resume Next
Open App.Path & "\" & "Error.log" For Append As #1
Print #1, Date & " " & Time
Print #1, Werr & Werror
Print #1, "编号 " & i
Print #1, "点 " & j
Print #1, Errsub
Print #1, ""
Close #1
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -