本人在用Oicq聊天時，經常收到一些好友發給我的用文本符號描繪的圖像，覺得好羨慕啊，于是一想何不自己編一個程序來解決一下這個問題呢。本人近期正好在學Vb，所以我就打算用Vb來搞定:).

首先，新建一個工程。在窗體Form1上放200個Shape控件（大量的復制粘貼，要有耐心),并讓其成為一個從Shape(0)到Shape(199)的數組 .大家也可以先在窗體Form1上放一個Shape控件，然后用Load語句來完成加載。把Shape控件的FillColor屬性設置為白色，FillStyle屬性設置為Solid(實填充), BorderColor屬性設置為黑色，BorderWidth屬性設置為1，Shape屬性設置為0(Rectangle),Height和Width屬性設置為195。

然后，用"工具"下的"菜單編輯器"加入四個菜單項，標題分New,Save,Char,Exit,名稱分別為NewMenu,SaveMenu,CharMenu和ExitMenu.

以上的準備工作完成以后，下面就來寫程序代碼了。首先介紹一下本程序設計的大體思想。本程序通過用鼠標來描繪圖形，當按著鼠標左鍵在Shape控件上移動時，處在鼠標位置的Shape控件的顏色變為藍色,當按右鍵時變為白色（Shape控件按20*10的方式排列）。用一個20*10的字符串數組來紀錄各個Shape控件的狀態，如著色則對應的數組元素為當前設置的字符串，否則為空格.當存盤時，把字符串數組寫入文件。

程序的變量說明為:

Dim imagearray(1 To 10, 1 To 20) As String

Dim curstr As String '當前的描繪字符串

1.在Form_Load()過程中加入初始化代碼,如下:

Private Sub Form_Load()

Dim i As Integer

Dim j As Integer

For i = 1 To 10

For j = 1 To 20

imagearray(i, j) = " " '把數組都清為空格

Next

Next

tops = (Form1.Height - 2000) 2 - 500

lefts = (Form1.Width - 4000) 2

For i = 0 To 199

Shape1(i).Top = tops + (i 20) * 200

Shape1(i).Left = lefts + (i Mod 20) * 200

Next '排列控件,使之按20*10排列

curstr = "*"

End Sub

2.在MouseDown過程中添加如下代碼:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim i As Integer

Dim j As Integer

If Button = 1 Then '如果是左鍵

For i = 1 To 10

For j = 1 To 20

If (X >= lefts + (j - 1) * 200) And (X <= lefts + j * 200) And (Y >= tops + (i - 1) * 200) And (Y <= tops + i * 200) Then

'以上判斷鼠標點在哪個控件上

imagearray(i, j) = curstr '置相應的數組元素為Curstr

Shape1((i - 1) * 20 + j - 1).FillColor = vbBlue

'控件顏色變為藍色

End If

Next

Next

ElseIf Button = 2 Then '如果是右鍵

For i = 1 To 10

For j = 1 To 20

If (X >= lefts + (j - 1) * 200) And (X <= lefts + j * 200) And (Y >= tops + (i - 1) * 200) And (Y <= tops + i * 200) Then

imagearray(i, j) = " " '置相應的數組元素為空格

Shape1((i - 1) * 20 + j - 1).FillColor = vbWhite

'控件顏色變為白色

End If

Next

Next

End If

End Sub

3.在MouseDown過程添加如下代碼:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim i As Integer


Dim j As Integer

If Button = 1 Then '按著鼠標左鍵

For i = 1 To 10

For j = 1 To 20

If (X >= lefts + (j - 1) * 200) And (X <= lefts + j * 200) And (Y >= tops + (i - 1) * 200) And (Y <= tops + i * 200) Then

imagearray(i, j) = curstr '置相應的數組元素為Curstr

Shape1((i - 1) * 20 + j - 1).FillColor = vbBlue

'控件顏色變為藍色

End If

Next

Next

ElseIf Button = 2 Then '按著鼠標右鍵

For i = 1 To 10

For j = 1 To 20

If (X >= lefts + (j - 1) * 200) And (X <= lefts + j * 200) And (Y >= tops + (i - 1) * 200) And (Y <= tops + i * 200) Then

imagearray(i, j) = " " '置相應的數組元素為空格

Shape1((i - 1) * 20 + j - 1).FillColor = vbWhite

'控件顏色變為白色

End If

Next

Next

End If

End Sub

4.New菜單的Click事件:

Private Sub NewMenu_Click(Index As Integer)

Dim i As Integer

Dim j As Integer

For i = 1 To 10

For j = 1 To 20

imagearray(i, j) = " " '數組全清為空格

Next

Next

For i = 0 To 199

Shape1(i).FillColor = vbWhite '控件的顏色全置為白色

Next

End Sub

5.Char菜單的Click事件:

Private Sub CharMenu_Click(Index As Integer)

Dim str As String

str = InputBox("請輸入描繪字符串:", "輸入描繪字符串:", curstr)

If str <> "" Then '如輸入的字符串不為空

curstr = str

End If

End Sub

6.Save菜單的Click事件:

Private Sub SaveMenu_Click(Index As Integer)

Dim i As Integer

Dim j As Integer

Dim fso As Object

Dim ts As TextStream

Dim filename As String

Set fso = CreateObject("Scripting.FileSystemObject")

filename = InputBox("請輸入文件名:", "輸入文件名:", "*.txt") '輸入文件名

Set ts = fso.CreateTextFile(filename, True)

For i = 1 To 10

For j = 1 To 20

ts.Write imagearray(i, j)

Next

ts.WriteLine '寫一新行

Next

End Sub

7.Exit菜單的Click事件:

Private Sub ExitMenu_Click(Index As Integer)

end '程序結束

End Sub

做完以上工作后就可以運行程序了,該程序只是一個簡化版本,由許多可以改進的地方.以上代碼大家也可到http://cattyxin.yeah.net/下載.