使用VB來解一元二次方程式(判斷指令IF)

使用VB來寫一個解一元二次方程式的程式, 流程圖如上，程式碼如下

使用到的物件有 text1,text2,text3,command1,command2,form1,label1~lbael5

X1 就是 label6   X2 就是 label7

其程式碼如下:

Private Sub Command1_Click()

'=====================
'  解 一元二次方程式
'=====================
' aX^2+bx+c=0

' 輸入 a,b,c

a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text3.Text)

' 判別式

d = b ^ 2 - 4 * a * c

If d >= 0 Then

  ' 有實根
  X1 = (-b + d ^ 0.5) / (2 * a)
  X2 = (-b - d ^ 0.5) / (2 * a)
Else
  ' 有虛根
  X1 = (-b + (-d) ^ 0.5) / (2 * a) & " i"
  X2 = (-b - (-d) ^ 0.5) / (2 * a) & " i"
End If

End Sub

Private Sub Command2_Click()

' 程式結束
 End
End Sub

使用 VB 寫一個金撲克程式

這是我寫來教學用的金撲克程式，這程式使用了如何判斷金撲克的得分

這程式需要用到一個樸克牌物件 (CARD.OCX)。
原始程式碼如下 :

Option Explicit
Dim poker(51) As Integer   '樸克牌
Dim flag As Integer        '目前在第幾張牌
Dim a(6) As Integer        '玩的牌有幾張
Dim h(6) As Integer        '是否按保留鍵
Dim b(5) As Integer        '判斷用陣列
Dim card_number As Integer '總牌數
Dim hand As Integer        '手數
Dim i, j, k, temp, kk As Integer

Private Sub Card_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
If h(Index) = 0 Then
   ho(Index).Caption = "保留"
   h(Index) = 1
Else
   ho(Index).Caption = ""
   h(Index) = 0
End If
End Sub
Private Sub Command1_Click()
'====================
'  show card value
'====================
Dim temp1, temp2, temp3, temp4 As Integer
Print "show"
For j = 0 To 4
   temp1 = a(j) \ 13 + 1
   temp2 = a(j) Mod 13 + 1
   temp3 = b(j) \ 13 + 1
   temp4 = b(j) Mod 13 + 1
   Print temp1; "-"; temp2
   Print temp3; "-"; temp4
Next j
End Sub
Sub wash()
'=============
'  洗牌作業
'=============
For i = 0 To 51
    poker(i) = 0
Next i
For i = 0 To 51
reselect:
  j = Int(Rnd(1) * 52)
  If poker(j) = 0 Then
     poker(j) = i
  Else
     GoTo reselect
  End If
Next i
End Sub
Sub clear_text()
'==========================
'   清除文字反向背景顏色
'==========================
   L9.BackColor = RGB(212, 208, 200)
   Lc9.BackColor = RGB(212, 208, 200)
   L8.BackColor = RGB(212, 208, 200)
   Lc8.BackColor = RGB(212, 208, 200)
   L7.BackColor = RGB(212, 208, 200)
   Lc7.BackColor = RGB(212, 208, 200)
   L6.BackColor = RGB(212, 208, 200)
   Lc6.BackColor = RGB(212, 208, 200)
   L5.BackColor = RGB(212, 208, 200)
   Lc5.BackColor = RGB(212, 208, 200)
   L4.BackColor = RGB(212, 208, 200)
   Lc4.BackColor = RGB(212, 208, 200)
   L3.BackColor = RGB(212, 208, 200)
   Lc3.BackColor = RGB(212, 208, 200)
   L2.BackColor = RGB(212, 208, 200)
   Lc2.BackColor = RGB(212, 208, 200)
   L1.BackColor = RGB(212, 208, 200)
   Lc1.BackColor = RGB(212, 208, 200)
End Sub
Sub see_card()
Dim v1, v2, pair, pair_flag, ss, same, score As Integer
pair = 0
'判斷結果
For i = 0 To 3
 For j = i + 1 To 4
   v1 = a(i) Mod 13 + 1
   v2 = a(j) Mod 13 + 1
   If v1 = v2 Then
      pair = pair + 1
      pair_flag = v1
   End If
 Next j
Next i
'=====================
'  一對 (11,12,13,A)
'=====================
If pair = 1 And (pair_flag = 1 Or pair_flag = 11 Or pair_flag = 12 Or pair_flag = 13) Then
   score = 1
End If
'==========
'   二對
'==========
If pair = 2 Then
   score = 2
End If
'==========
'   三對
'==========
If pair = 3 Then
   score = 3
End If
'==========
'   葫蘆
'==========
If pair = 4 Then
   score = 10
End If
'==========
'   四梅
'==========
If pair = 6 Then
   score = 40
End If
'==============
'   判斷 順
'==============
'取得牌值
For i = 0 To 4
  b(i) = a(i)
  b(i) = b(i) Mod 13 + 1  '取餘數
Next i
'排序
For i = 0 To 3
  For j = i + 1 To 4
    If b(i) > b(j) Then
       temp = b(i)
       b(i) = b(j)
       b(j) = temp
    End If
  Next j
Next i

'判斷是否差 1
ss = 0
temp = b(0)
For i = 1 To 4
   If temp + 1 <> b(i) Then
       ss = 0 '不是順
       Exit For
   Else
       temp = b(i)
       ss = 1
   End If
Next i

' 特例 (大順)
For i = 0 To 4
  b(i) = a(i)
  b(i) = b(i) Mod 13 + 1  '取餘數
Next i
'排序
For i = 0 To 3
  For j = i + 1 To 4
    If b(i) > b(j) Then
       temp = b(i)
       b(i) = b(j)
       b(j) = temp
    End If
  Next j
Next i
If b(0) = 1 And b(1) = 10 And b(2) = 11 And b(3) = 12 And b(4) = 13 Then
   ss = 2
End If
If ss = 1 Or ss = 2 Then
   score = 5
End If
'============
'  是否同花
'============
For i = 0 To 4
  b(i) = a(i)
  b(i) = b(i) \ 13 + 1 '取整數
Next i
same = 0
For i = 0 To 3
  If b(i) <> b(i + 1) Then
     same = 0
     Exit For
  Else
     same = 1
  End If
Next i
If same = 1 Then
   score = 7
End If

'==========
'  同花順
'==========
If same = 1 And ss = 1 Then
   score = 100
End If
'============
'  同花大順
'============
If same = 1 And ss = 2 Then
   score = 500
End If
'==================
'   顯示所得倍數
'==================
Select Case score
Case 1
   L9.BackColor = RGB(255, 255, 0)
   Lc9.BackColor = RGB(255, 255, 0)
Case 2
   L8.BackColor = RGB(255, 255, 0)
   Lc8.BackColor = RGB(255, 255, 0)
Case 3
   L7.BackColor = RGB(255, 255, 0)
   Lc7.BackColor = RGB(255, 255, 0)
Case 5
   L6.BackColor = RGB(255, 255, 0)
   Lc6.BackColor = RGB(255, 255, 0)
Case 7
   L5.BackColor = RGB(255, 255, 0)
   Lc5.BackColor = RGB(255, 255, 0)
Case 10
   L4.BackColor = RGB(255, 255, 0)
   Lc4.BackColor = RGB(255, 255, 0)
Case 40
   L3.BackColor = RGB(255, 255, 0)
   Lc3.BackColor = RGB(255, 255, 0)
Case 100
   L2.BackColor = RGB(255, 255, 0)
   Lc2.BackColor = RGB(255, 255, 0)
Case 500
   L1.BackColor = RGB(255, 255, 0)
   Lc1.BackColor = RGB(255, 255, 0)
Case Else
End Select
End Sub
Private Sub Command2_Click()
Call see_card
End Sub
Private Sub Command3_Click()
'=============
'  看牌作業
'=============
hand = hand + 1
Call clear_text
If hand = 1 Then
   Call show_card '第一輪
   Command3.Caption = "換牌"
   Command6.Enabled = False
Else
   Call show_card '第二輪
   Call see_card
   hand = 0
   Command3.Caption = "出牌"
   Command6.Enabled = True
   Command3.Enabled = False
End If
End Sub
Sub show_card()
Dim temp As Integer
temp = 0
'  蓋牌
  For i = 0 To 4
    If h(i) = 0 Then
       temp = temp + 1
       Card(i).Value = 0
    End If
  Next i
'  顯示牌
 For i = 0 To 4
   If h(i) = 0 Then
      flag = flag + 1
      a(i) = poker(flag)
      Card(i).Suit = a(i) \ 13 + 1
      Card(i).Value = a(i) Mod 13 + 1
      Call Delay
   End If
 Next i
End Sub
Private Sub Command4_Click()
'==============
'   程式結束
'==============
End
End Sub
Private Sub Command5_Click()
'================
'  換牌背面花色
'================
Static switch As Integer
switch = switch + 1
If switch > 65 Then switch = 53
If switch < 53 Then switch = 53
For i = 0 To card_number - 1
    Card(i).CardBackStyle = switch
Next i
End Sub
Private Sub Command6_Click()
Command3.Enabled = True
Call Form_Load
Call Command3_Click
End Sub
Private Sub Command7_Click()
'============
'   測試牌
'============
poker(1) = 0
poker(2) = 9
poker(3) = 10
poker(4) = 24
poker(5) = 12
flag = 0
End Sub
Private Sub Form_Load()
'===================
'   程式起始設定
'===================
  Randomize Timer  '設定亂數種子
'
' 設定樸克牌的初值(測試用)
'
  Call wash
  flag = 0
  hand = 0
  card_number = 5
  Command3.Enabled = True
'
'  清除按鈕標題
'
For i = 0 To card_number - 1
  ho(i).Caption = ""
  h(i) = 0
Next i
'
'  顯示牌背
'
For i = 0 To card_number - 1
  Card(i).Value = 0
Next i
End Sub
Public Sub Delay()
'==================
'   延時程式
'==================
Dim x As Long
For x = 1 To 10000000
  x = x + 1
Next x
End Sub

使用 VB 寫一個畫多邊形的程式

最近寫了一個畫多邊形的程式，以做為教學之用，一個圓的半徑大小為 1
使用極座標畫出的圖如下 :

 
使用物件 command1, command2, text1, form1, pict

原始程式碼如下:

Private Sub Command1_Click()
Dim x(50) As Single, y(50) As Single '宣告最多畫 50 個角
angle = Val(Text1.Text) '要畫的角數
If angle > 50 Or angle < 3 Then
  MsgBox ("要畫的角數最少 3 , 最多 50 !!")
Else
  Pict.Cls '清除表單
  Pict.Scale (-1.1, 1.1)-(1.1, -1.1)   '設定範圍
  pi = 3.14159
  st = (2 * pi) / angle  '差值=2pi /angle
  c = 0   '令 c 的初值為 0
  '儲存各點的座標
  For i = 0 To 2 * pi Step st
     c = c + 1
     x(c) = Cos(i)
     y(c) = Sin(i)
  Next i
  '畫各點相連的線
  For i = 1 To angle - 1
     Pict.Line (x(i), y(i))-(x(i + 1), y(i + 1))
  Next i
  '最後一點連回第一點
  Pict.Line -(x(1), y(1))
 
End If
End Sub
Private Sub Command2_Click()
Dim x(50) As Single, y(50) As Single '宣告最多畫 50 個角
angle = Val(Text1.Text) '要畫的角數
If angle > 50 Or angle < 3 Then
  MsgBox ("要畫的角數最少 3 , 最多 50 !!")
Else
  Pict.Cls '清除表單
  Pict.Scale (-1.1, 1.1)-(1.1, -1.1)   '設定範圍
  pi = 3.14159
  st = (2 * pi) / angle  '差值=2pi /angle
  c = 0   '令 c 的初值為 0
  '儲存各點的座標
  For i = 0 To 2 * pi Step st
     c = c + 1
     x(c) = Cos(i)
     y(c) = Sin(i)
  Next i
  '畫每一點相連其他點的線
  For i = 1 To angle - 1
    For j = i + 1 To angle
       Pict.Line (x(i), y(i))-(x(j), y(j))
    Next j
  Next i
End If

End Sub

使用VB設計的井字遊戲

這個程式是我 93 年要訓練選手所出的題目。現在把它放上來，給有興趣的人觀看吧。

物件有 a(0) ~ a(8) command1 , command2 , form1 , option1 , option2

原始程式碼如下:

Dim i As Integer         ' i 變數
Dim xo(8) As String      ' 存放資料格
Dim locate As Integer    ' 電腦最佳解
Dim counter As Integer   ' 目前可下的空格數目
Dim b(8) As Integer      ' 記錄目前的空格狀態
Dim win(8) As Integer    ' 記錄八種勝利的狀態
Private Sub a_Click(Index As Integer)
game_ov = 0
'=========
'  人下
'=========
  If b(Index) = 0 Then
     a(Index).Caption = "O"
     b(Index) = 1
  Else
     MsgBox "此地已下過,不可再下!!"
  End If
  Call see_stat(flag)
  ' 玩家勝利了
  If flag = 1 Then
     MsgBox "你好厲害哦!!大玩家!!"
     game_ov = 1
  End If
 
  ' 無空格可下了
  Call count_counter(counter)
  Debug.Print counter
 
  If counter = 0 Then
     game_ov = 1
     GoTo pg_ov
  End If
'=============
'   電腦下子
'=============
  Call think(locate) '電腦求最佳解.
  b(locate) = -1
  a(locate).Caption = "X"
  Call see_stat(flag)
  ' 玩家勝利了
  If flag = -1 Then
     MsgBox "哈哈!我贏了!!", 0, ""
     game_ov = 1
  End If
 
  ' 無空格可下了
  Call count_counter(counter)
  Debug.Print counter
  If counter = 0 Then
     game_ov = 1
     GoTo pg_ov
  End If
pg_ov:
  If game_ov = 1 Then
     Call again
  End If
End Sub
Private Sub Command1_Click()
End
End Sub
Private Sub Command2_Click()
For i = 0 To 8
   a(i).Visible = True
   a(i).Caption = ""
   b(i) = 0
Next i
If Option1.Value = True Then
   Call chess_one
End If
End Sub
Private Sub Form_Load()
Randomize Timer '亂數種子
For j = 0 To 8
    b(j) = 0
    a(j).Caption = ""
    a(j).Visible = False
Next j
End Sub
Sub again()
    xx = MsgBox("是否還要玩?", vbYesNo, "")
    If xx = 6 Then
       For i = 0 To 8
          b(i) = 0
          a(i).Caption = ""
          a(i).Visible = False
       Next i
    Else
       End
    End If
End Sub
Sub see_stat(flag)
'============================================
' 記錄目前可下的空格數目是否有勝利的狀態
' flag= 0 --> 無勝負
' flag= 1 --> O 勝利
' flag=-1 --> X 勝利
'============================================
  Call count_win
  '計算是否有人勝利
  flag = 0
  For i = 1 To 8
    If win(i) = 3 Or win(i) = -3 Then
       If win(i) = 3 Then
          flag = 1
       Else
          flag = -1
       End If
    End If
  Next i
End Sub
Sub count_counter(x)
  '計算尚有格數
  x = 0
  For i = 0 To 8
      If b(i) = 0 Then x = x + 1
  Next
End Sub
Sub count_win()
  win(1) = b(0) + b(1) + b(2)
  win(2) = b(3) + b(4) + b(5)
  win(3) = b(6) + b(7) + b(8)
  win(4) = b(0) + b(3) + b(6)
  win(5) = b(1) + b(4) + b(7)
  win(6) = b(2) + b(5) + b(8)
  win(7) = b(0) + b(4) + b(8)
  win(8) = b(2) + b(4) + b(6)
End Sub
Sub chess_one()
'================
'  電腦下第一子
'================
    t = Int(Rnd(1) * 5) * 2
    b(t) = -1
    a(t).Caption = "X"
End Sub
Sub think(what)
    '設定位置
    xo(1) = "012"
    xo(2) = "345"
    xo(3) = "678"
    xo(4) = "036"
    xo(5) = "147"
    xo(6) = "258"
    xo(7) = "048"
    xo(8) = "246"
   
    '特例處理
    Call count_counter(counter)
   
    If counter = 6 Then
       If b(4) = -1 And b(0) = 1 And b(8) = 1 Then
          what = 3
          GoTo pg_ov
       End If
       If b(4) = -1 And b(2) = 1 And b(6) = 1 Then
          what = 3
          GoTo pg_ov
       End If
       If b(4) = -1 And b(1) = 1 And b(3) = 1 Then
          what = 0
          GoTo pg_ov
       End If
       If b(4) = -1 And b(1) = 1 And b(5) = 1 Then
          what = 2
          GoTo pg_ov
       End If
       If b(4) = -1 And b(3) = 1 And b(7) = 1 Then
          what = 6
          GoTo pg_ov
       End If
       If b(4) = -1 And b(5) = 1 And b(7) = 1 Then
          what = 8
          GoTo pg_ov
       End If
    End If
   
    '電腦快連成一直線了，所以先連
    For i = 1 To 8
        If win(i) = -2 Then
           sel = xo(i)
           num1 = Val(Mid(sel, 1, 1))
           num2 = Val(Mid(sel, 2, 1))
           num3 = Val(Mid(sel, 3, 1))
           If b(num1) = 0 Then what = num1
           If b(num2) = 0 Then what = num2
           If b(num3) = 0 Then what = num3
           GoTo pg_ov
        End If
    Next i
   
    '對方快連成一直線了，所以快阻止
    For i = 1 To 8
        If win(i) = 2 Then
           sel = xo(i)
           num1 = Val(Mid(sel, 1, 1))
           num2 = Val(Mid(sel, 2, 1))
           num3 = Val(Mid(sel, 3, 1))
           If b(num1) = 0 Then what = num1
           If b(num2) = 0 Then what = num2
           If b(num3) = 0 Then what = num3
           GoTo pg_ov
        End If
    Next i
   
    '求最小值，決定下那裏
    Min = 99
    For i = 0 To 8
        If b(i) = 0 Then
           b(i) = -1
           '計算分數
           score = 0
          
           '計算 win(1)~win(8) 分數
           Call count_win
          
           For wi = 1 To 8
             score = score + win(wi)
           Next wi
          
           If score < Min Then
              what = i
              Min = score
           End If
           b(i) = 0
        End If
    Next i
pg_ov:
End Sub