VB 星座查询代码

Private Sub Command1_Click()

Dim str1 As String, d1 As Date, i As Integer, xz

xz = Array("白羊座", 3, 21, 4, 20, "金牛座", 4, 21, 5, 20, "双子座", 5, 21, 6, 21, _

"巨蟹座", 6, 22, 7, 22, "狮子座", 7, 23, 8, 22, "处女座", 8, 23, 9, 22, _

"天秤座", 9, 23, 10, 22, "天蝎座", 10, 23, 11, 21, "射手座", 11, 22, 12, 21, _

"摩羯座", 12, 22, 12, 31, "摩羯座", 1, 1, 1, 19, "水瓶或世座", 1, 20, 2, 18, _

"双鱼座", 2, 19, 3, 20)

str1 = txtMonth &"-" &txtDay

If IsDate(str1) Then

'd1 = CDate(str1)

For i = 0 To UBound(xz) Step 5

If Val(txtMonth) >= xz(i + 1) And Val(txtDay) >= xz(i + 2) _

And Val(txtMonth) <= xz(i + 3) And Val(txtDay) <= xz(i + 4) Then

MsgBox "你查询的" &str1 &"的星座" &xz(i), vbOKOnly, "星座查询衫袭肢"

Exit For

End If

Next i

Else

MsgBox "你输入的数据" &str1 &"不是日禅丛期！", vbOKOnly, "星座查询"

End If

End Sub

'新建窗体form1

'添加控件 DTPicker1，Command1

Private Sub Command1_Click()

Dim aa As Integer

Dim bb As Integer

Dim cc As Integer

Dim dd_xingzuo As Integer

Dim dd_shengxiao As Integer

Dim leirong As String

bb = DTPicker1.Month

aa = DTPicker1.Day

cc = DTPicker1.Year

dd_xingzuo = (bb * 100 + aa)

dd_shengxiao = cc Mod 12

If dd_xingzuo >112 And dd_xingzuo <221 Then

leirong = "星座：水瓶座"

End If

If dd_xingzuo >= 221 And dd_xingzuo <= 321 Then

leirong = "星座：双鱼座"

End If

If dd_xingzuo >= 322 And dd_xingzuo <= 420 Then

leirong = "星座：白羊座"

End If

If dd_xingzuo >= 421 And dd_xingzuo <= 521 Then

leirong = "星瞎派激座：金牛座"

End If

If dd_xingzuo >= 522 And dd_xingzuo <= 621 Then

leirong = "星座：双子座"

End If

If dd_xingzuo >= 622 And dd_xingzuo <= 721 Then

leirong = "星座：巨蟹座"

End If

If dd_xingzuo >= 722 And dd_xingzuo <= 821 Then

leirong = "星座：狮子坐"

End If

If dd_xingzuo >= 822 And dd_xingzuo <= 921 Then

leirong = "星座：处女座"

End If

If dd_xingzuo >= 922 And dd_xingzuo <= 1021 Then

leirong = "星座：天秤座"

End If

If dd_xingzuo >= 1022 And dd_xingzuo <= 1121 Then

leirong = "星座磨袜：天蝎座"

End If

If dd_xingzuo >= 1122 And dd_xingzuo <= 1221 Then

leirong = "星座：射手座"

End If

If dd_xingzuo >= 1222 Or dd_xingzuo <= 111 Then

leirong = "星座：摩羯座"

End If

Select Case dd_shengxiao

Case 0

leirong = leirong &vbCrLf &"身肖：猴"

Case 1

leirong = leirong &vbCrLf &"身肖：鸡"

Case 2

leirong = leirong &vbCrLf &"身肖：狗羡锋"

Case 3

leirong = leirong &vbCrLf &"身肖：猪"

Case 4

leirong = leirong &vbCrLf &"身肖：鼠"

Case 5

leirong = leirong &vbCrLf &"身肖：牛"

Case 6

leirong = leirong &vbCrLf &"身肖：虎"

Case 7

leirong = leirong &vbCrLf &"身肖：兔"

Case 8

leirong = leirong &vbCrLf &"身肖：龙"

Case 9

leirong = leirong &vbCrLf &"身肖：蛇"

Case 10

leirong = leirong &vbCrLf &"身肖：马"

Case 11

leirong = leirong &vbCrLf &"身肖：羊"

End Select

MsgBox leirong, vbInformation, "计算结果"

End Sub

两个标签，两个Text

Public Function Constellation(mDate As Date) As String

'星座

Constellation = Mid("摩羯水瓶双鱼白羊金牛双子巨蟹狮子处女天秤天蝎射手摩羯", (Month(mDate) + IIf((Day(mDate) - (19 + Int(Mid("102123444533", Month(mDate), 1)))) >= 0, 0, -1)) * 2 + 1, 2) &"座"

End Function

Public Function GetCNum(d As Date) As Integer

Select Case Constellation(d)

Case "白羊座"

n = 0

Case "金牛座"

n = 1

Case "双子座"

n = 2

Case "巨蟹座"

n = 3

Case "狮子座"

n = 4

Case "处女座"

n = 5

Case "天秤座"

n = 6

Case "天蝎座"

n = 7

Case "射手座"

n = 8

Case "摩羯座"

n = 9

Case "水瓶座"

n = 10

Case "双鱼座"

n = 11

End Select

GetCNum = n

End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)

Dim d As Date

If KeyAscii = 13 Then

d = Text1.Text

strConstellation = Constellation(d)

Select Case Constellation(d)

Case "白羊座"

s = "平时活力十足的你，今天却变得混身没劲！不想让感情只是三分钟热度，就仔细想想该如何经营。偶尔也要培养气质，去买本好书吧！今天没迟销啥冲劲，不妨低调沉潜、伺机而动！"

Case "金牛座"

s = "会接触不少人，记得放开胸怀，别太闷了！睁大眼睛瞧，新对象或许就出现啰！一个轻松的聚会场合令你破费。工作:今天会和不少人开会，互动频繁。"

Case "双子座"

s = "无往不利、全力打拼！想让你安定下来，今天是个好时机！平时花钱很随兴的你，突然想作财务规划。今天会做一项重要决策，相信自己准没错！"

Case "巨蟹座"

s = "别老待在家里，今天是出外走走的好时机。和亲爱的他到户外踏青去！有场聚会将会让你破费。提升自己的竞争力，应接触些平时不懂的业务。"

Case "狮子座"

s = "收起尖锐的利爪，今天凡事好商量。强势的狮子成了温柔的小猫，只想依偎着心爱的他。会为家人购买一些小礼物！有人找你帮忙处理公务，你不好意思拒绝。"

Case "处女座"

s = "拓展生活圈，建立新关系的好时机。单身的人将感到特别地孤单，很期盼爱情降临。和朋友共同讨论合资的计划?工作: 要妥善处理合作案的细节? "

Case "天秤座"

s = "对事情能够屏除偏见，具有客观、冷静判断力的一天。对自己理念的坚持，让你在态度上也强势了起来。之前投资的都有获得回报的迹象。今天你让人感觉成熟稳重，可托付重任的样子！"

Case "天蝎座"

s = "顺路经过感兴趣的店，不妨进去看看。不要排斥相亲或是朋友介绍，也许会遇到不错的人选唷！适合出门逛街买些秋冬用品。初次相见的人肢态特别值得注目，你从身上可学到不少东西。"

Case "射手座"

s = "年长的朋友可望对你提出有益的建言。今天是个适合向亲密朋友吐露心事的日子。为了讨好情人，不惜打种脸充胖子。要注意对长辈或年纪较长者，要比平常更客气一点的言词相待。"

Case "摩羯座"

s = "不论自己心情如何都要隐藏起来，多保持笑容才拉近与他人的关系。即使是亲密的人历旦源，还是要尊重对方的自尊心。真心诚意帮助别人，也是为自己开运。为了处理别人的事，自己的事都没做到一天就结束了。"

Case "水瓶座"

s = "是个不能一心二用的日子，顾得了东就顾不了西，力量宜集中在一件事物上。看人不能只看外表，小心有跌破眼镜的时候。一感到苗头不对，就要有修正计划的应变措施。心急的要求成果，反而越搞越乱，其实慢慢做的话，倒是还能蛮顺利就解决了。"

Case "双鱼座"

s = "陶醉于玩乐的气氛中，让你很high。热情参加朋友邀约的轻松聚会，会有意想不到的恋情发展。吃喝玩乐的开销颇大，小心控制。下班下课后的约会、休闲，可将压力一口气解消掉了。"

End Select

Label1.Caption = strConstellation &vbCrLf &s

End If

End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)

Dim d1 As Date, d2 As Date

If KeyAscii = 13 Then

arr = Array(Array(90, 64, 86, 22, 94, 65, 83, 44, 93, 25, 84, 46), _

Array(62, 91, 83, 41, 16, 94, 48, 85, 66, 93, 22, 76), _

Array(83, 42, 91, 67, 79, 20, 94, 63, 80, 39, 96, 24), _

Array(26, 83, 63, 94, 36, 82, 24, 96, 45, 84, 59, 94), _

Array(92, 22, 87, 43, 89, 63, 84, 30, 93, 63, 81, 44), _

Array(66, 93, 19, 86, 57, 96, 44, 82, 25, 94, 39, 83), _

Array(82, 47, 90, 17, 77, 46, 91, 64, 77, 21, 94, 64), _

Array(45, 87, 62, 92, 19, 76, 62, 94, 44, 58, 23, 97), _

Array(91, 65, 82, 47, 93, 23, 76, 35, 94, 64, 77, 23), _

Array(20, 96, 44, 78, 55, 97, 27, 82, 66, 96, 46, 78), _

Array(82, 21, 92, 59, 79, 44, 90, 22, 78, 43, 95, 66))

d1 = Text1.Text

d2 = Text2.Text

n1 = GetCNum(d1)

n2 = GetCNum(d2)

Label2.Caption = arr(n1)(n2)

End If

End Sub

---