home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Sleep_posi2083189132007.psc / frmMain.frm < prev    next >
Text File  |  2007-09-13  |  7KB  |  213 lines

  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00400000&
  5.    BorderStyle     =   1  'Fixed Single
  6.    Caption         =   "Tell me how you sleep ..."
  7.    ClientHeight    =   5220
  8.    ClientLeft      =   45
  9.    ClientTop       =   360
  10.    ClientWidth     =   9180
  11.    Icon            =   "frmMain.frx":0000
  12.    LinkTopic       =   "Form1"
  13.    MaxButton       =   0   'False
  14.    MinButton       =   0   'False
  15.    ScaleHeight     =   348
  16.    ScaleMode       =   3  'Pixel
  17.    ScaleWidth      =   612
  18.    StartUpPosition =   3  'Windows Default
  19.    Begin VB.Label lblAbout 
  20.       Alignment       =   2  'Center
  21.       Caption         =   "Want to know more? Click here."
  22.       Height          =   255
  23.       Left            =   0
  24.       TabIndex        =   2
  25.       Top             =   4920
  26.       Width           =   9255
  27.    End
  28.    Begin VB.Label lblType 
  29.       BackStyle       =   0  'Transparent
  30.       BeginProperty Font 
  31.          Name            =   "MS Serif"
  32.          Size            =   24
  33.          Charset         =   0
  34.          Weight          =   700
  35.          Underline       =   0   'False
  36.          Italic          =   0   'False
  37.          Strikethrough   =   0   'False
  38.       EndProperty
  39.       ForeColor       =   &H000000FF&
  40.       Height          =   975
  41.       Left            =   480
  42.       TabIndex        =   1
  43.       Top             =   3480
  44.       Width           =   2175
  45.    End
  46.    Begin VB.Label lblMessage 
  47.       Alignment       =   2  'Center
  48.       BackColor       =   &H00FFFFFF&
  49.       BackStyle       =   0  'Transparent
  50.       Caption         =   "Move the mouse over your sleeping position."
  51.       BeginProperty Font 
  52.          Name            =   "Arial"
  53.          Size            =   18
  54.          Charset         =   0
  55.          Weight          =   400
  56.          Underline       =   0   'False
  57.          Italic          =   0   'False
  58.          Strikethrough   =   0   'False
  59.       EndProperty
  60.       ForeColor       =   &H00E0E0E0&
  61.       Height          =   1335
  62.       Left            =   3600
  63.       TabIndex        =   0
  64.       Top             =   3360
  65.       Width           =   5295
  66.    End
  67. End
  68. Attribute VB_Name = "frmMain"
  69. Attribute VB_GlobalNameSpace = False
  70. Attribute VB_Creatable = False
  71. Attribute VB_PredeclaredId = True
  72. Attribute VB_Exposed = False
  73. Option Explicit
  74. '............................ DC
  75. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  76. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  77. Private OriginalDC As Long
  78. Private HighlightedDC As Long
  79.  
  80. '............................ BITMAP
  81. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  82.  
  83. '............................ OBJECT
  84. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  85. Private oldOriginalObj As Long
  86. Private oldHighlightedObj As Long
  87.  
  88. '............................ RECT
  89. Private Type RECT
  90.   iLeft As Long
  91.   iTop As Long
  92.   iRight As Long
  93.   iBottom As Long
  94. End Type
  95. Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
  96.  
  97. Private arRect(5) As RECT
  98. Private oldSelected As Integer
  99. Private arWidth(5) As Long
  100.  
  101. Private stdPict101 As StdPicture
  102. Private stdPict102 As StdPicture
  103.  
  104. Private Sub Form_Load()
  105.    Dim lWidth As Long
  106.    Dim lHeight As Long
  107.  
  108. ' get "original" picture from resource file and show it in the form
  109.    OriginalDC = CreateCompatibleDC(Me.hdc)
  110.    Set stdPict101 = LoadResPicture(101, vbResBitmap)
  111.    oldOriginalObj = SelectObject(OriginalDC, stdPict101.Handle)
  112.    lWidth = Round(ScaleX(stdPict101.Width, vbHimetric, vbPixels))
  113.    lHeight = Round(ScaleY(stdPict101.Height, vbHimetric, vbPixels))
  114.    BitBlt Me.hdc, 0, 0, lWidth, lHeight, OriginalDC, 0, 0, vbSrcCopy
  115.    Me.Refresh
  116.    
  117. ' get "highlighted" picture
  118.    HighlightedDC = CreateCompatibleDC(Me.hdc)
  119.    Set stdPict102 = LoadResPicture(102, vbResBitmap)
  120.    oldHighlightedObj = SelectObject(HighlightedDC, stdPict102.Handle)
  121.    
  122. ' set up rectangles defining individual pictures
  123.    With arRect(0): .iLeft = 0:   .iTop = 0: .iBottom = 217: .iRight = 114: End With
  124.    With arRect(1): .iLeft = 115: .iTop = 0: .iBottom = 217: .iRight = 220: End With
  125.    With arRect(2): .iLeft = 221: .iTop = 0: .iBottom = 217: .iRight = 307: End With
  126.    With arRect(3): .iLeft = 308: .iTop = 0: .iBottom = 217: .iRight = 410: End With
  127.    With arRect(4): .iLeft = 411: .iTop = 0: .iBottom = 217: .iRight = 517: End With
  128.    With arRect(5): .iLeft = 518: .iTop = 0: .iBottom = 217: .iRight = 612: End With
  129.  
  130. ' set up width of individual pictures
  131.    arWidth(0) = 114
  132.    arWidth(1) = 116
  133.    arWidth(2) = 87
  134.    arWidth(3) = 103
  135.    arWidth(4) = 107
  136.    arWidth(5) = 105
  137.    
  138.   oldSelected = -1
  139. End Sub
  140.  
  141. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  142.    Dim iSelected As Integer
  143.    Dim i As Integer
  144.    
  145. ' is the mouse over a rectangle?
  146.    iSelected = -1
  147.    For i = 0 To 5
  148.       If PtInRect(arRect(i), CLng(X), CLng(Y)) <> 0 Then
  149.          iSelected = i
  150.          Exit For
  151.       End If
  152.    Next i
  153.    
  154. ' over same as previous rectangle?
  155.    If iSelected = oldSelected Then
  156.       Exit Sub
  157.    End If
  158.    
  159. ' remove highligth
  160.    If oldSelected <> -1 Then
  161.       BitBlt Me.hdc, arRect(oldSelected).iLeft, 0, arWidth(oldSelected), 217, OriginalDC, arRect(oldSelected).iLeft, 0, vbSrcCopy
  162.       Me.Refresh
  163.       oldSelected = -1
  164.       lblType = ""
  165.       lblMessage.ForeColor = &HE0E0E0
  166.       lblMessage = "Move the mouse over your sleeping position."
  167.       End If
  168.       
  169.  ' new highligth
  170.     If iSelected <> -1 Then
  171.       BitBlt Me.hdc, arRect(iSelected).iLeft, 0, arWidth(iSelected), 217, HighlightedDC, arRect(iSelected).iLeft, 0, vbSrcCopy
  172.       Me.Refresh
  173.       
  174.       lblMessage.ForeColor = vbYellow
  175.       Select Case iSelected
  176.          Case 0
  177.             lblType = "The Yearner"
  178.             lblMessage = "A suspicious person with a very rational approach to life."
  179.          Case 1
  180.             lblType = "The Starfish"
  181.             lblMessage = "A good listener who likes to help whenever needed."
  182.          Case 2
  183.             lblType = "The Log"
  184.             lblMessage = "Easy going and social, but can be seen as too gulible."
  185.          Case 3
  186.             lblType = "The Soldier"
  187.             lblMessage = "Quiet and reserved who loathes noisy social scenes."
  188.          Case 4
  189.             lblType = "The Freefaller"
  190.             lblMessage = "Appears brash but cannot cope with personal criticism."
  191.          Case 5
  192.             lblType = "The Foetus"
  193.             lblMessage = "Seems tough but is really a sensitive, shy person."
  194.       End Select
  195.       oldSelected = iSelected
  196.     End If
  197. End Sub
  198.  
  199. Private Sub Form_Unload(Cancel As Integer)
  200.    SelectObject OriginalDC, oldOriginalObj
  201.    DeleteDC OriginalDC
  202.    Set stdPict101 = Nothing
  203.    SelectObject HighlightedDC, oldHighlightedObj
  204.    DeleteDC HighlightedDC
  205.    Set stdPict102 = Nothing
  206.    Set frmMain = Nothing
  207.    
  208. End Sub
  209.  
  210. Private Sub lblAbout_Click()
  211.    frmAbout.Show vbModal
  212. End Sub
  213.