module1.bas

来自「社区医疗系统实现了数字电压计参数的无线传送和温度参数的传送」· BAS 代码 · 共 137 行

Attribute VB_Name = "Module1"
Option Explicit
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public ResponseData As String
'登录与否标志
Public bPassWordok As Boolean
Public Const g_MYPASSWORD = "ch"
Public g_NorPassWord As String
Public g_SpecPassWord As String   '特殊密码
Public g_UserPassWord As String   '用户输入密码
Public FileName As String
Dim newstart As Long '索引行数
Dim newstart2 As Long '索引行数
Sub Main()
  '防止多个程序运行
  If App.PrevInstance = True Then
     End
  End If
  '获得特殊密码
  g_SpecPassWord = GetSpecPassWord
  frmSplash.Show
  TimeDelay 1000
  frmMain.Show
End Sub
Private Function GetSpecPassWord() As String
  GetSpecPassWord = GetSetting("ch", "PassWord", "SpecPassWord", "111111")
End Function
Sub TimeDelay(TT As Long)
  Dim t As Long
  t = GetTickCount()
  Do
    DoEvents
    If GetTickCount - t < 0 Then t = GetTickCount
  Loop Until GetTickCount - t >= TT
End Sub
'二进制字符串转化为十六进制字符串
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function BinToHex(BinStr As String) As String
  Dim i As Long
    BinStr = String$((4 - Len(BinStr) Mod 4) Mod 4, "0") & BinStr
  For i = 0 To Len(BinStr) \ 4 - 1
    Select Case Mid$(BinStr, i * 4 + 1, 4)
        Case "0000": BinToHex = BinToHex & "0"
        Case "0001": BinToHex = BinToHex & "1"
        Case "0010": BinToHex = BinToHex & "2"
        Case "0011": BinToHex = BinToHex & "3"
        Case "0100": BinToHex = BinToHex & "4"
        Case "0101": BinToHex = BinToHex & "5"
        Case "0110": BinToHex = BinToHex & "6"
        Case "0111": BinToHex = BinToHex & "7"
        Case "1000": BinToHex = BinToHex & "8"
        Case "1001": BinToHex = BinToHex & "9"
        Case "1010": BinToHex = BinToHex & "A"
        Case "1011": BinToHex = BinToHex & "B"
        Case "1100": BinToHex = BinToHex & "C"
        Case "1101": BinToHex = BinToHex & "D"
        Case "1110": BinToHex = BinToHex & "E"
        Case "1111": BinToHex = BinToHex & "F"
    End Select
  Next i
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'二进制字符串转化为十进制数值
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function BintoDec(ByVal varString As String) As Long
  Dim Slen  As Long
  Dim i As Long
  Dim returnNum     As Long
    Slen = Len(varString)
    For i = 0 To Slen - 1
       returnNum = returnNum + Val(Mid(varString, i + 1, 1)) * (2 ^ (Slen - i - 1))
    Next
       BintoDec = returnNum
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'16 进制的字符串转换位10进制整数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub HextoDec(x As String)
Dim s As Integer, a As Integer, i As Integer

For i = 1 To Len(x)
tmp = Mid(x, i, 1)
If Asc(x) >= 65 And Asc(x) <= 70 Then    'ASC是返回ASCII码的十进制值
a = Asc(x) - 55
If Asc(x) >= 97 And Asc(x) <= 102 Then
a = Asc(x) - 87
Else
a = x
End If
End If

If Len(x) - i = 0 Then
s = s + a
Else
s = s + a * 16 * (Len(x) - i)
End If
Next i

'Text2 = Text2 & s
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'显示字体颜色
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub TEXTCOLOR1_end() '第一结束方式
  frmMain.txtMsg.SelStart = newstart
  frmMain.txtMsg.SelLength = Len(frmMain.txtMsg.Text) - newstart
  frmMain.txtMsg.SelColor = &H8000000D
End Sub
Public Sub TEXTCOLOR2_end() '第二结束方式
  frmMain.txtMsg.SelStart = newstart
  frmMain.txtMsg.SelLength = Len(frmMain.txtMsg.Text) - newstart
  frmMain.txtMsg.SelColor = &HFF&        'vbWhite
End Sub
Public Sub TEXTCOLOR3_end() '第三结束方式
  frmMain.txtMsg.SelStart = newstart
  frmMain.txtMsg.SelLength = Len(frmMain.txtMsg.Text) - newstart
  frmMain.txtMsg.SelColor = &H80000015
End Sub
Public Sub TEXTCOLOR_start()
 ' newstart = Len(frmMain.txtMsg.Text)
  frmMain.txtMsg.SelStart = newstart '定义起点,避免覆盖文本
End Sub
Public Sub TEXTCOLOR11_end() '第一结束方式
  frmMain.xwmessage.SelStart = newstart2
  frmMain.xwmessage.SelLength = Len(frmMain.xwmessage.Text) - newstart2
  frmMain.xwmessage.SelColor = &H8000000D
End Sub
Public Sub TEXTCOLOR12_end() '第二结束方式
  On Error Resume Next
    frmMain.xwmessage.SelStart = newstart2
    frmMain.xwmessage.SelLength = Len(frmMain.xwmessage.Text) - newstart2
    frmMain.xwmessage.SelColor = &HFF&        'vbWhite
End Sub