VERSION 5.00
Object = "{D27CDB6B-AE6D-11CF-96B8-444553540000}#1.0#0"; "Flash9f.ocx"
Begin VB.UserControl MyTransparentFlash 
   ClientHeight    =   3930
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3705
   ScaleHeight     =   3930
   ScaleWidth      =   3705
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   3120
      Top             =   3120
   End
   Begin ShockwaveFlashObjectsCtl.ShockwaveFlash ShockwaveFlash1 
      Height          =   3615
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3255
      _cx             =   5741
      _cy             =   6376
      FlashVars       =   ""
      Movie           =   ""
      Src             =   ""
      WMode           =   "Transparent"
      Play            =   -1  'True
      Loop            =   -1  'True
      Quality         =   "High"
      SAlign          =   ""
      Menu            =   -1  'True
      Base            =   ""
      AllowScriptAccess=   ""
      Scale           =   "ShowAll"
      DeviceFont      =   0   'False
      EmbedMovie      =   0   'False
      BGColor         =   ""
      SWRemote        =   ""
      MovieData       =   ""
      SeamlessTabbing =   -1  'True
      Profile         =   0   'False
      ProfileAddress  =   ""
      ProfilePort     =   0
      AllowNetworking =   "all"
      AllowFullScreen =   "false"
   End
   Begin VB.Image Image1 
      Height          =   3735
      Left            =   0
      Top             =   0
      Width           =   3495
   End
End
Attribute VB_Name = "MyTransparentFlash"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Private 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
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long


Option Explicit
'Default Property Values:
Const m_def_BackColor = 0
Const m_def_ForeColor = 0
Const m_def_Enabled = 0
Const m_def_BackStyle = 0
Const m_def_BorderStyle = 0
'Property Variables:
Dim m_BackColor As Long
Dim m_ForeColor As Long
Dim m_Enabled As Boolean
Dim m_Font As Font
Dim m_BackStyle As Integer
Dim m_BorderStyle As Integer
'Event Declarations:
Event Click()
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick()
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event KeyDown(KeyCode As Integer, Shift As Integer)
Attribute KeyDown.VB_Description = "Occurs when the user presses a key while an object has the focus."
Event KeyPress(KeyAscii As Integer)
Attribute KeyPress.VB_Description = "Occurs when the user presses and releases an ANSI key."
Event KeyUp(KeyCode As Integer, Shift As Integer)
Attribute KeyUp.VB_Description = "Occurs when the user releases a key while an object has the focus."
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."

Dim WithEvents sh As cSystemHook '钩子
Attribute sh.VB_VarHelpID = -1
Dim bEnableHook As Boolean '钩子捕获键盘的开关
Dim strKeyPressed As String  '曾经已经按下过的键
Dim rfid As String '得到的RFID
Dim bRegistered As Boolean '已经注册
Dim strRegFlash As String  '已注册的FLASH
Dim strUnregFlash As String '未注册的flash



Public Type ImageSize
    width As Long
    height As Long
End Type

Public Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type
    
Public Function CombineBytes(ByVal low As Byte, ByVal high As Byte) As Long
CombineBytes = low + high * 256
End Function
Public Function GetImageSize(sFileName As String) As ImageSize
On Error Resume Next
Dim iFN As Integer
Dim bTemp(3) As Byte
Dim lFlen As Long
Dim lPos As Long
Dim bHmsb As Byte
Dim bHlsb As Byte
Dim bWmsb As Byte
Dim bWlsb As Byte
Dim bBuf(7) As Byte
Dim bDone As Byte
Dim iCount As Integer
lFlen = FileLen(sFileName)
iFN = FreeFile
Open sFileName For Binary As iFN
Get #iFN, 1, bTemp()
'PNG 文件
If bTemp(0) = &H89 And bTemp(1) = &H50 And bTemp(2) = &H4E _
And bTemp(3) = &H47 Then
Get #iFN, 19, bWmsb
Get #iFN, 20, bWlsb
Get #iFN, 23, bHmsb
Get #iFN, 24, bHlsb
GetImageSize.width = CombineBytes(bWlsb, bWmsb)
GetImageSize.height = CombineBytes(bHlsb, bHmsb)
End If
'GIF 文件
If bTemp(0) = &H47 And bTemp(1) = &H49 And bTemp(2) = &H46 _
And bTemp(3) = &H38 Then
Get #iFN, 7, bWlsb
Get #iFN, 8, bWmsb
Get #iFN, 9, bHlsb
Get #iFN, 10, bHmsb
GetImageSize.width = CombineBytes(bWlsb, bWmsb)
GetImageSize.height = CombineBytes(bHlsb, bHmsb)
End If
'JPEG 文件
If bTemp(0) = &HFF And bTemp(1) = &HD8 And bTemp(2) = &HFF Then
Debug.Print "JPEG"
lPos = 3
Do
Do
Get #iFN, lPos, bBuf(1)
Get #iFN, lPos + 1, bBuf(2)
lPos = lPos + 1
Loop Until (bBuf(1) = &HFF And bBuf(2) <> &HFF) Or lPos > lFlen
For iCount = 0 To 7
Get #iFN, lPos + iCount, bBuf(iCount)
Next iCount
If bBuf(0) >= &HC0 And bBuf(0) <= &HC3 Then
bHmsb = bBuf(4)
bHlsb = bBuf(5)
bWmsb = bBuf(6)
bWlsb = bBuf(7)
bDone = 1
Else
lPos = lPos + (CombineBytes(bBuf(2), bBuf(1))) + 1
End If
Loop While lPos < lFlen And bDone = 0
GetImageSize.width = CombineBytes(bWlsb, bWmsb)
GetImageSize.height = CombineBytes(bHlsb, bHmsb)
End If
'BMP 文件
If bTemp(0) = &H42 And bTemp(1) = &H4D Then
Get #iFN, 19, bWlsb
Get #iFN, 20, bWmsb
Get #iFN, 23, bHlsb
Get #iFN, 24, bHmsb
GetImageSize.width = CombineBytes(bWlsb, bWmsb)
GetImageSize.height = CombineBytes(bHlsb, bHmsb)
End If
Close iFN
End Function


'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get BackColor() As Long
Attribute BackColor.VB_Description = "Returns/sets the background color used to display text and graphics in an object."
    BackColor = m_BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As Long)
    m_BackColor = New_BackColor
    PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get ForeColor() As Long
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As Long)
    m_ForeColor = New_ForeColor
    PropertyChanged "ForeColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=0,0,0,0
Public Property Get Enabled() As Boolean
Attribute Enabled.VB_Description = "Returns/sets a value that determines whether an object can respond to user-generated events."
    Enabled = m_Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    m_Enabled = New_Enabled
    PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=6,0,0,0
Public Property Get Font() As Font
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set m_Font = New_Font
    PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get BackStyle() As Integer
Attribute BackStyle.VB_Description = "Indicates whether a Label or the background of a Shape is transparent or opaque."
    BackStyle = m_BackStyle
End Property

Public Property Let BackStyle(ByVal New_BackStyle As Integer)
    m_BackStyle = New_BackStyle
    PropertyChanged "BackStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=7,0,0,0
Public Property Get BorderStyle() As Integer
Attribute BorderStyle.VB_Description = "Returns/sets the border style for an object."
    BorderStyle = m_BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
    m_BorderStyle = New_BorderStyle
    PropertyChanged "BorderStyle"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=5
Public Sub Refresh()
Attribute Refresh.VB_Description = "Forces a complete repaint of a object."
     
End Sub

 



'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14
Public Function InitFlash(ByVal UnregFlash As Variant, ByVal RegFlash As Variant) 'ByVal BkImgFileName As Variant, , ByVal x0 As Integer, ByVal y0 As Integer, ByVal cx_flash As Long, ByVal cy_flash As Long) As Variant
'将this控件隐藏后，使背景显现出来，timer1定时1秒后捕获屏幕的特定区域作为背景
    ShowFlash 0
    
    strRegFlash = RegFlash
    strUnregFlash = UnregFlash

    Timer1.Enabled = True
End Function

'timer1定时1秒后捕获屏幕的特定区域作为背景
Private Sub Timer1_Timer()

    Dim width As Integer
    Dim height As Integer
    Dim rc1 As RECT
    Dim BkImgFileName As String
    BkImgFileName = "c:\\back.bmp"
    
   
    Timer1.Enabled = False '停止定时器
    
    GetWindowRect hwnd, rc1   '获取当前控件的窗口坐标，相对于屏幕左上角
    width = rc1.right - rc1.left
    height = rc1.bottom - rc1.top

    CopyScreenToBMP BkImgFileName, rc1.left, rc1.top, width, height  '通过拷屏动态捕获背景
    
    ShowFlash 1  '重新显示flash

    ShockwaveFlash1.Movie = strUnregFlash '设置动画为未注册状态
    ShockwaveFlash1.width = width * 15
    ShockwaveFlash1.height = height * 15 '从象素单位转换为vb单位
    
    Image1.Picture = LoadPicture(BkImgFileName)
         
        'GetWindowRect hwnd, rc1
       ' width = rc1.right - rc1.left
        'height = rc1.bottom - rc1.top

        'SetWindowPos hwnd, 0, 0, 0, width, height, 2  ' &H42
    
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14
Public Function ShowFlash(ByVal show_hide As Long) As Variant
    If show_hide = 0 Then
        ShowWindow hwnd, 0
    Else
        ShowWindow hwnd, 1
    End If
    
End Function

 

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=14
Public Function Play(ByVal play_stop As Long) As Variant
    If play_stop = 0 Then
        ShockwaveFlash1.Stop
        ShockwaveFlash1.TStopPlay "/Clip1"
    Else
        ShockwaveFlash1.Play
    End If
    
    Dim pro As String * 256
    pro = ShockwaveFlash1.TGetProperty("/", 1)
    MsgBox pro
End Function



'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_BackColor = m_def_BackColor
    m_ForeColor = m_def_ForeColor
    m_Enabled = m_def_Enabled
    Set m_Font = Ambient.Font
    m_BackStyle = m_def_BackStyle
    m_BorderStyle = m_def_BorderStyle
    
   
    strKeyPressed = ""
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    m_BackColor = PropBag.ReadProperty("BackColor", m_def_BackColor)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    m_Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
    Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_BackStyle = PropBag.ReadProperty("BackStyle", m_def_BackStyle)
    m_BorderStyle = PropBag.ReadProperty("BorderStyle", m_def_BorderStyle)
End Sub

'打开或者关闭钩子
Public Sub EnableHook(ByVal en As Boolean)
    bEnableHook = en
    If (en) Then
        strKeyPressed = ""
        bRegistered = False
        rfid = ""
        
        If (sh Is Nothing) Then
            Set sh = New cSystemHook  '初始化钩子
            sh.SetHook
        End If
        
    Else
        sh.RemoveHook '删除钩子
        Set sh = Nothing
    End If
    
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", m_BackColor, m_def_BackColor)
    Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("Enabled", m_Enabled, m_def_Enabled)
    Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
    Call PropBag.WriteProperty("BackStyle", m_BackStyle, m_def_BackStyle)
    Call PropBag.WriteProperty("BorderStyle", m_BorderStyle, m_def_BorderStyle)
End Sub


Private Sub sh_KeyDown(KeyCode As Integer, Shift As Integer)

Dim MAX_LEN As Integer
Dim asc_val As Integer
Dim k As Integer

MAX_LEN = 10


    If (bEnableHook) Then
        If (KeyCode = 13) Then  '回车
            If (Len(strKeyPressed) = MAX_LEN) Then
                bRegistered = True '已注册
                For k = 1 To MAX_LEN
                    asc_val = Asc(Mid(strKeyPressed, k, 1))
                    If (asc_val < 48 Or asc_val > 57) Then '非数字字符不是合法的刷卡字符
                        bRegistered = False
                    End If
                Next k

                If (bRegistered) Then
                    rfid = strKeyPressed  '将获得的RFID进行保存
                    strKeyPressed = ""
                    ShockwaveFlash1.Movie = strRegFlash
                End If
            End If
        Else
            If ((KeyCode >= 65 And KeyCode <= 90) Or (KeyCode >= 48 And KeyCode <= 57)) Then
                strKeyPressed = strKeyPressed + Chr(KeyCode)
                If (Len(strKeyPressed) > MAX_LEN) Then
                    strKeyPressed = right(strKeyPressed, MAX_LEN)
                End If
            Else
                strKeyPressed = ""          '出现非法字符后，将以前的键盘输入缓冲区清空
            End If
        End If
    End If

End Sub


Public Sub RemoteWriteExpResult(ByVal ProjectName As Variant, ByVal result As Variant)
'通过ADO调用sqlserver的存储过程写入数据
    'If (bRegistered) Then
    '    MsgBox rfid
    'End If
    Dim constr As String
    constr = "Provider=SQLOLEDB.1;Password=123;Persist Security Info=True;User ID=openit;Initial Catalog=Data_Name;Data Source=  server_name"

'    Dim strS As String '定义一变量
'    Dim adoconn As New ADODB.Connection 'Connection 对象代表了打开与数据源的连接。
'    Dim adocomm As New ADODB.Command 'Command 对象定义了将对数据源执行的指定命令。
'    Dim ReturnValue As Integer '调用存储过程的返回值
'    adoconn.ConnectionString = constr '
'    adoconn.Open
'    Set adocomm.ActiveConnection = adoconn '指示指定的 Command对象当前所属的 Connection对象。
'    adocomm.CommandText = "doc_ProcName" '设置Command对象源。
'    adocomm.CommandType = adCmdStoredProc '通知提供者CommandText属性有什么，它可能包括Command对象的源类型。设置这个属性优化了该命令的执行。
'    adocomm.Parameters(1) = "1"
'    adocomm.Parameters(2) = "OutputParameters" 'OutputParameters可以为任意的字符串或数字
'    adocomm.Execute
'    ReturnValue = adocomm.Parameters(0) '存储过程的返回值，返回0则成功执行。
'    strS = adocomm.Parameters(2) '把存储过程的输出参数的值赋给变量strS


    '2) 追加参数法调用存储过程
    Dim adoconn As New ADODB.Connection 'Connection 对象代表了打开与数据源的连接。
    Dim adocomm As New ADODB.Command 'Command 对象定义了将对数据源执行的指定命令。
    Dim ReturnValue As Integer '调用存储过程的返回值

    Dim mRst As ADODB.Recordset 'Recordset 对象表示的是来自基本表或命令执行结果的记录全集。
    Dim prm As ADODB.Parameter 'Parameter 对象代表参数或与基于参数化查询或存储过程的Command 对象相关联的参数。
    adoconn.ConnectionString = constr
    adoconn.Open
    Set adocomm.ActiveConnection = adoconn
    adocomm.CommandText = "doc_ProcName"  '存储过程名
    adocomm.CommandType = adCmdStoredProc
    
    '参数
    Set prm = adocomm.CreateParameter("parameter1", adVariant, adParamInput, , ProjectName)
    adocomm.Parameters.Append prm
     Set prm = adocomm.CreateParameter("parameter2", adVariant, adParamInput, , result)
    adocomm.Parameters.Append prm
   
    '返回值
    Set prm = adocomm.CreateParameter("parameter3", adInteger, adParamOutput)
    adocomm.Parameters.Append prm
    Set mRst = adocomm.Execute
    ReturnValue = adocomm.Parameters(0)


End Sub


 
