frmmain.frm

一个非常好的生物表源程序

            Width           =   6270
         End
      End
   End
   Begin ComctlLib.TabStrip TabStrip1 
      Height          =   5190
      Left            =   45
      TabIndex        =   0
      Top             =   135
      Width           =   6540
      _ExtentX        =   11536
      _ExtentY        =   9155
      _Version        =   327680
      BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7} 
         NumTabs         =   3
         BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "Settings"
            Key             =   "Settings"
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "Graph"
            Key             =   "Graph"
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
         BeginProperty Tab3 {0713F341-850A-101B-AFC0-4210102A8DA7} 
            Caption         =   "About BioWiz"
            Key             =   "About BioWiz"
            Object.Tag             =   ""
            ImageVarType    =   2
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Arial Black"
         Size            =   11.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      MouseIcon       =   "frmMain.frx":589D4
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Type SavedData
date1 As Date
date2 As Date
color(6) As Long
End Type
Private CurrentData As SavedData
Private Const P_Interval = 23
Private Const I_Interval = 33
Private Const E_Interval = 28
Private date1 As Date
Private date2 As Date
Private Const Pi = 3.14159265358979
Private CurrentTab As Integer
Private Days As Long
Private Sub chkEmotional_Click()
DrawGraph
End Sub
Private Sub chkIntellectual_Click()
DrawGraph
End Sub
Private Sub chkPhysical_Click()
DrawGraph
End Sub
Private Sub chkRulers_Click()
DrawGraph
End Sub
Private Sub cmdDayBack_Click()
date2 = DateAdd("d", -1, date2)
DrawGraph
End Sub
Private Sub cmdDayForth_Click()
date2 = DateAdd("d", 1, date2)
DrawGraph
End Sub
Private Sub cmdMonthBack_Click()
date2 = DateAdd("m", -1, date2)
DrawGraph
End Sub
Private Sub cmdMonthForth_Click()
date2 = DateAdd("m", 1, date2)
DrawGraph
End Sub
Private Sub cmdWebsite_Click()
lReturn = ShellExecute(hWnd, "open", "http://www.geocities.com/SiliconValley/Network/5045", vbNull, vbNull, SW_SHOWNORMAL)
End Sub
Private Sub cmdYearBack_Click()
date2 = DateAdd("yyyy", -1, date2)
DrawGraph
End Sub
Private Sub cmdYearForth_Click()
date2 = DateAdd("yyyy", 1, date2)
DrawGraph
End Sub
Private Sub cmdReset_Click()
date2 = txtDate(1) & "/" & txtDate(2) & "/" & txtDate(3)
DrawGraph
End Sub
Private Sub cmdSystemDate_Click()
txtDate(1) = Month(Date)
txtDate(2) = Day(Date)
txtDate(3) = Year(Date)
End Sub
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyEscape
Unload Me
End Select
End Sub
Private Sub Form_Load()
date3 = "10-24-1979"
date4 = "10-24-1979"
CurrentTab = 1
Dim LastData As SavedData
Open App.Path & "\BioWiz.dat" For Random As #1
Get #1, 1, LastData
Close
If LastData.date1 = 0 Then
CurrentData.color(1) = vbBlack
CurrentData.color(2) = vbWhite
CurrentData.color(3) = vbWhite
CurrentData.color(4) = vbYellow
CurrentData.color(5) = vbGreen
CurrentData.color(6) = vbRed
CurrentData.date1 = "10-24-1979"
CurrentData.date2 = Date
Else
For i = 1 To 6
CurrentData.color(i) = LastData.color(i)
Next
CurrentData.date1 = LastData.date1
CurrentData.date2 = LastData.date2
End If
date1 = CurrentData.date1
date2 = CurrentData.date2
txtDate(1) = Trim(Month(date2))
txtDate(2) = Trim(Day(date2))
txtDate(3) = Trim(Year(date2))
txtBirthdate(1) = Trim(Month(date1))
txtBirthdate(2) = Trim(Day(date1))
txtBirthdate(3) = Trim(Year(date1))
For i = 1 To 6
optColor(i).Tag = CurrentData.color(i)
Next
Show
For i = 1 To 3
Frame(i).Move Frame(1).Left, Frame(1).Top
Next
Open App.Path & "\BioWiz.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close
lblColor(1) = Trim(Str(optColor(1).Tag Mod 256))
lblColor(2) = Trim(Str((optColor(1).Tag \ 256) Mod 256))
lblColor(3) = Trim(Str(optColor(1).Tag \ 65536))
For i = 1 To 3
hsbColor(i).Value = Format(lblColor(i))
Next
optColor(1) = True
For Each c In Controls
If TypeOf c Is Frame Then c.Visible = False
Next
TabStrip1.Tabs.Item(3).Selected = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
For i = 1 To 6
CurrentData.color(i) = optColor(i).Tag
Next
CurrentData.date1 = date1
CurrentData.date2 = date2
Open App.Path & "\BioWiz.dat" For Random As #1
Put #1, 1, CurrentData
Close
End Sub
Private Sub hsbColor_Change(Index As Integer)
lblColor(Index) = Trim(Str(hsbColor(Index).Value))
col = Format(lblColor(3).Caption) * 65536 + Format(lblColor(2).Caption) * 256 + Format(lblColor(1).Caption)
picColor.BackColor = col
For i = 1 To 6
If optColor(i).Value = True Then optColor(i).Tag = col
Next
End Sub
Private Sub hsbColor_Scroll(Index As Integer)
hsbColor_Change (Index)
End Sub

Private Sub optColor_Click(Index As Integer)
lblColor(1) = Trim(Str(optColor(Index).Tag Mod 256))
lblColor(2) = Trim(Str((optColor(Index).Tag \ 256) Mod 256))
lblColor(3) = Trim(Str(optColor(Index).Tag \ 65536))
For i = 1 To 3
hsbColor(i).Value = Format(lblColor(i))
Next
End Sub
Private Sub TabStrip1_Click()
Frame(CurrentTab).Visible = False
Frame(TabStrip1.SelectedItem.Index).Visible = True
CurrentTab = TabStrip1.SelectedItem.Index
If CurrentTab = 2 Then
DrawGraph
chkEmotional.BackColor = optColor(4).Tag
chkPhysical.BackColor = optColor(5).Tag
chkIntellectual.BackColor = optColor(6).Tag
chkRulers.BackColor = optColor(2).Tag
For i = 4 To 6
lblCycles(i).BackColor = optColor(i).Tag
Next
End If
End Sub
Private Sub txtBirthdate_Change(Index As Integer)
On Error Resume Next
newtext = txtBirthdate(Index)
Static PrevText(3) As Integer
invalid = False
For i = 1 To Len(newtext)
If Asc(Mid(newtext, i, 1)) < 48 Or Asc(Mid(newtext, i, 1)) > 57 Then invalid = True
Next
Select Case Index
Case 1
maxx = 12
normallen = 2
Case 2
maxx = 31
normallen = 2
Case 3
normallen = 4
maxx = 3000
End Select
If Len(Trim(newtext)) > normallen Or Val(newtext) < 1 Or Val(newtext) > maxx Then invalid = True
If invalid = True Then
txtBirthdate(Index) = PrevText(Index)
vscBirthdate(Index).Value = Val(PrevText(Index))
Exit Sub
Else
vscBirthdate(Index).Value = Val(newtext)
PrevText(Index) = Val(newtext)
End If
RefreshDays
End Sub
Private Sub txtBirthdate_GotFocus(Index As Integer)
hsbColor(1).SetFocus
End Sub
Private Sub txtDate_GotFocus(Index As Integer)
hsbColor(1).SetFocus
End Sub
Private Sub vscBirthdate_Change(Index As Integer)
txtBirthdate(Index) = vscBirthdate(Index).Value
End Sub
Private Sub vscBirthdate_Scroll(Index As Integer)
vscBirthdate_Change (Index)
End Sub
Private Sub txtdate_Change(Index As Integer)
On Error Resume Next
newtext = txtDate(Index)
Static PrevText(3) As Integer
invalid = False
For i = 1 To Len(newtext)
If Asc(Mid(newtext, i, 1)) < 48 Or Asc(Mid(newtext, i, 1)) > 57 Then invalid = True
Next
Select Case Index
Case 1
maxx = 12
normallen = 2
Case 2
maxx = 31
normallen = 2
Case 3
normallen = 4
maxx = 3000
End Select
If Len(Trim(newtext)) > normallen Or Val(newtext) < 1 Or Val(newtext) > maxx Then invalid = True
If invalid = True Then
txtDate(Index) = PrevText(Index)
RefreshDays
vscDate(Index).Value = Val(PrevText(Index))
Exit Sub
Else
vscDate(Index).Value = Val(newtext)
PrevText(Index) = Val(newtext)
End If
RefreshDays
End Sub
Private Sub vscdate_Change(Index As Integer)
txtDate(Index) = vscDate(Index).Value
End Sub
Private Sub vscdate_Scroll(Index As Integer)
vscdate_Change (Index)
End Sub
Public Sub RefreshDays()
date1 = txtBirthdate(1) & "/" & txtBirthdate(2) & "/" & txtBirthdate(3)
date2 = txtDate(1) & "/" & txtDate(2) & "/" & txtDate(3)
Days = DateDiff("d", date1, date2)
lblDays.Caption = "You have lived " & Str(Days) & " days"
End Sub
Public Sub DrawGraph()
Const Int_Max = 8
Const Phy_Max = 5
Const Emo_Max = 13
Const Average_Max = 15
picGraph.ScaleWidth = 35
picGraph.ScaleHeight = 30
picGraph.BackColor = optColor(1).Tag
picGraph.DrawWidth = 2
Dim Phys As Integer, Emot As Integer, Inte As Integer
curdays = DateDiff("d", date1, date2)
If chkEmotional.Value = 1 Then
picGraph.CurrentX = 1
picGraph.CurrentY = 15 - Sin((((curdays - 17) Mod E_Interval) * 2 * Pi) / E_Interval) * Emo_Max
x = 1
For eachday = curdays - 16 To curdays + 16
x = x + 1
v = Sin(((eachday Mod E_Interval) * 2 * Pi) / E_Interval) * Emo_Max
picGraph.Line -(x, 15 - v), optColor(4).Tag
Next
End If
If chkPhysical.Value = 1 Then
picGraph.CurrentX = 1
picGraph.CurrentY = 15 - Sin((((curdays - 17) Mod P_Interval) * 2 * Pi) / P_Interval) * Phy_Max
x = 1
For eachday = curdays - 16 To curdays + 16
x = x + 1
v = Sin(((eachday Mod P_Interval) * 2 * Pi) / P_Interval) * Phy_Max
picGraph.Line -(x, 15 - v), optColor(5).Tag
Next
End If
If chkIntellectual.Value = 1 Then
picGraph.CurrentX = 1
picGraph.CurrentY = 15 - Sin((((curdays - 17) Mod I_Interval) * 2 * Pi) / I_Interval) * Int_Max
x = 1
For eachday = curdays - 16 To curdays + 16
x = x + 1
v = Sin(((eachday Mod I_Interval) * 2 * Pi) / I_Interval) * Int_Max
picGraph.Line -(x, 15 - v), optColor(6).Tag
Next
End If
picGraph.DrawWidth = 1
picGraph.Line (1, 2)-(1, 28), optColor(2).Tag
picGraph.Line (1, 15)-(34, 15), optColor(2).Tag
picGraph.DrawStyle = 2
picGraph.DrawWidth = 1
If chkRulers.Value = 1 Then
picGraph.Line (2 + 16, 0)-(2 + 16, 15), optColor(2).Tag
picGraph.Line (2 + 16, 17)-(2 + 16, picGraph.ScaleHeight), optColor(2).Tag
Else
picGraph.Line (2 + 16, 0)-(2 + 16, picGraph.ScaleHeight), optColor(2).Tag
End If
If chkRulers.Value = 1 Then
picGraph.DrawWidth = 1
picGraph.FontSize = 6
For i = 2 To 34
a = Trim(Str(Day(DateAdd("d", i - 2, DateAdd("d", -16, date2)))))
picGraph.Line (i, 15)-(i, 14), optColor(3).Tag
picGraph.CurrentX = i - (picGraph.TextWidth(a)) / 2
picGraph.CurrentY = 15
picGraph.ForeColor = optColor(3).Tag
picGraph.Print a
Next
picGraph.FontSize = 10
End If
picGraph.ForeColor = vbWhite
cd = date2
cd = Format(cd, "dddd, mmm d yyyy")
picGraph.CurrentX = picGraph.ScaleWidth - picGraph.TextWidth(cd) - 1
picGraph.CurrentY = picGraph.ScaleHeight - picGraph.TextHeight(cd)
picGraph.Print cd
picGraph.DrawStyle = 0
e_per = Format(Sin(((DateDiff("d", date1, date2) Mod E_Interval) * 2 * Pi) / E_Interval) * 100, "00") & "%"
If e_per = "00%" Then e_per = " Crucial Day"
lblCycles(4) = " Emotional : " & e_per
p_per = Format(Sin(((DateDiff("d", date1, date2) Mod P_Interval) * 2 * Pi) / P_Interval) * 100, "00") & "%"
If p_per = "00%" Then p_per = " Crucial Day"
lblCycles(5) = " Physical : " & p_per
i_per = Format(Sin(((DateDiff("d", date1, date2) Mod I_Interval) * 2 * Pi) / I_Interval) * 100, "00") & "%"
If i_per = "00%" Then i_per = " Crucial Day"
lblCycles(6) = " Intellectual : " & i_per
a = Sin(((DateDiff("d", date1, date2) Mod P_Interval) * 2 * Pi) / P_Interval) * 100
b = Sin(((DateDiff("d", date1, date2) Mod E_Interval) * 2 * Pi) / E_Interval) * 100
c = Sin(((DateDiff("d", date1, date2) Mod I_Interval) * 2 * Pi) / I_Interval) * 100
a_per = Int((a + b + c) / 3)
lblCycles(7) = " Average : " & Str(a_per) & "%"
lblCurDate = Format(date2, "mm-dd-yyyy")
End Sub