module1.bas

基于MSCOMM的炉温控制系统上位机程序

Attribute VB_Name = "Module1"

Public db As Database
Public Rs As Recordset
Public td As TableDef
Public Y As Integer
Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Public Declare Function DeleteObject Lib "Gdi32" (ByVal hObject As Long) As Long
Public Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Public ClearDatabase As Boolean

Public Type PointAPI
        X As Long
        Y As Long
End Type

Public Declare Function GetPixel Lib "Gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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 CreateRectRgn Lib "Gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "Gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long


Declare Function sndPlaySound Lib "WINMM.DLL" Alias "sndPlaySoundA" _
        (lpszSoundName As Any, ByVal uFlags As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)

Global Const SND_ASYNC = &H1     ' 异步播放
Global Const SND_NODEFAULT = &H2 ' 不使用缺省声音
Global Const SND_MEMORY = &H4    ' lpszSoundName 指向一个内存文件

Public Type SndTable
    Text As String '语音文本内容
    BeginTime As Single
    EndTime As Single
    BeginOffset As Long
    DataSize As Long
End Type
Public SndElement(0 To 140) As SndTable '声音信息表
Public SndTotalBytes As Long '声音数据字节数
Public SndTotalTime As Single '声音播放总时间
Public SndDataBlockB As Integer '声音数据块调整数
Public SndHeaderSize As Long '声音信息头的长度
Public SndDataRate As Long '声音播放传输率
Public Wavfmt As Integer

Public SndRes() As Byte
Global SndBuffer() As Byte
'升级注意：
'资源文件中的WAV资源项是一个连续录音的WAV语音文件。
'用WINDOWS自带录音机录音，声音文件都很大，应该压缩，
'我采用的Mpeg layer-3压缩，语音文件由34M减为487K，可以压得更小，但音效很差了
'据说有专门的软件可以将音元自动提取，应该实现不难，这样对文件压缩可能有好处
'可以对每个音元的起始和结束数据进行修饰，可以取得比较自然话音效果，但由于不成熟，导致有时出错，暂时不能用
'如果时间允许，应该添加语音读数功能。


Public Sub EndPlaySound()
    sndPlaySound ByVal vbNullString, 0&
End Sub

Public Sub SndInitial()
    Dim TmpLong As Long, i%, TmpStrArray() As String
    Dim TmpStr As String
    
    SndRes = LoadResData(101, "Wav") '取出声音文件
    Call CopyMemory(TmpLong, SndRes(16), 4) '取得过渡字节数
    Call CopyMemory(Wavfmt, SndRes(20), 2) '取得格式字节
    Call CopyMemory(SndTotalBytes, SndRes(16 + 4 + TmpLong + 16), 4) '取得声音数据字节数
    SndHeaderSize = TmpLong + 40 '取得声音文件头字节数
    Call CopyMemory(SndDataBlockB, SndRes(32), 2) '取得数据块调整数
    Call CopyMemory(SndDataRate, SndRes(28), 4) '播放传输率
    TmpStr = LoadResData(104, 6) '取得声音文件总播放时间修正补偿数
    SndTotalTime = SndTotalBytes / SndDataRate + val(TmpStr) '声音文件在不同格式转换过程中，播放时间可能会发生稍微变化，需要修正补偿
    TmpStr = LoadResData(101, 6) '取出声音对应文本串
    TmpStrArray = Split(TmpStr, ",")
    For i = LBound(SndElement) To UBound(SndElement)
        SndElement(i).Text = TmpStrArray(i - LBound(SndElement))
    Next i
    TmpStr = LoadResData(102, 6) '取出声音元素起始时间
    TmpStrArray = Split(TmpStr, ",")
    For i = LBound(SndElement) To UBound(SndElement)
        SndElement(i).BeginTime = val(TmpStrArray(i - LBound(SndElement))) '+ 0.04
        SndElement(i).BeginOffset = Int(SndElement(i).BeginTime / SndTotalTime * SndTotalBytes) \ SndDataBlockB
    Next i
    TmpStr = LoadResData(103, 6) '取出声音元素结束时间
    TmpStrArray = Split(TmpStr, ",")
    For i = LBound(SndElement) To UBound(SndElement)
        SndElement(i).EndTime = val(TmpStrArray(i - LBound(SndElement))) - 0.1 '减0.1，是因为每个音元结束时间太靠后，显得很不连续，前提0.1秒
        SndElement(i).DataSize = Int(SndElement(i).EndTime / SndTotalTime * SndTotalBytes) \ SndDataBlockB - SndElement(i).BeginOffset
    Next i
    '*******
    'Debug.Print
    'For i = LBound(SndElement) To UBound(SndElement)
    '    Debug.Print i, SndElement(i).Text, SndElement(i).BeginTime, SndElement(i).EndTime, SndElement(i).BeginOffset, SndElement(i).DataSize
    'Next i
    'Debug.Print
    '*********
    Erase TmpStrArray
End Sub
Public Function AutoFormShape(bg As Form, transColor)
    Dim X, Y As Integer
    CurRgn = CreateRectRgn(0, 0, bg.ScaleWidth, bg.ScaleHeight)  ' Create base region which is the current whole window

    While Y <= 5 ' Go through each column of pixels on form
        While X <= bg.ScaleWidth  ' Go through each line of pixels on form
            If GetPixel(bg.hdc, X, Y) = transColor Then  ' If the pixels color is the transparency color (bright purple is a good one to use)
                TempRgn = CreateRectRgn(X, Y, X + 1, Y + 1)  ' Create a temporary pixel region for this pixel
                success = CombineRgn(CurRgn, CurRgn, TempRgn, RGN_DIFF)  ' Combine temp pixel region with base region using RGN_DIFF to extract the pixel and make it transparent
                DeleteObject (TempRgn)  ' Delete the temporary pixel region and clear up very important resources
            End If
            X = X + 1
        Wend
            Y = Y + 1
            X = 0
    Wend
    success = SetWindowRgn(bg.hWnd, CurRgn, True)  ' Finally set the windows region to the final product
    DeleteObject (CurRgn)  ' Delete the now un-needed base region and free resources
    ' This code is by Chris Yates (1999)
End Function
Public Function Horizontal(Newform As Form, Colour1 As ColorConstants, Colour2 As ColorConstants)
    Dim VR, VG, VB As Single
    Dim Color1, Color2 As Long
    Dim R, G, b, R2, G2, B2 As Integer
    Dim temp As Long

    Color1 = Colour1
    Color2 = Colour2

    temp = (Color1 And 255)
    R = temp And 255
    temp = Int(Color1 / 256)
    G = temp And 255
    temp = Int(Color1 / 65536)
    b = temp And 255
    temp = (Color2 And 255)
    R2 = temp And 255
    temp = Int(Color2 / 256)
    G2 = temp And 255
    temp = Int(Color2 / 65536)
    B2 = temp And 255

    VR = Abs(R - R2) / Newform.ScaleWidth
    VG = Abs(G - G2) / Newform.ScaleWidth
    VB = Abs(b - B2) / Newform.ScaleWidth

    If R2 < R Then VR = -VR
    If G2 < G Then VG = -VG
    If B2 < b Then VB = -VB

    For X = 0 To Newform.ScaleWidth
        R2 = R + VR * X
        G2 = G + VG * X
        B2 = b + VB * X
        Newform.Line (X, 0)-(X, Newform.ScaleHeight), RGB(R2, G2, B2)
    Next X
End Function