ICQ/即时通讯

开发平台：
Visual Basic

FrmMain.frm：源码内容
							VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "字+字=字！"
   ClientHeight    =   5490
   ClientLeft      =   1665
   ClientTop       =   1500
   ClientWidth     =   7140
   Icon            =   "FrmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   22.875
   ScaleMode       =   4  'Character
   ScaleWidth      =   59.5
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton CmgMsg 
      Caption         =   "使用说明"
      Height          =   375
      Left            =   60
      TabIndex        =   26
      Top             =   4920
      Width           =   1575
   End
   Begin VB.TextBox TxtMain 
      Height          =   4695
      Left            =   1740
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   6
      Top             =   600
      Width           =   5175
   End
   Begin VB.PictureBox Picture2 
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   3540
      ScaleHeight     =   255
      ScaleWidth      =   3255
      TabIndex        =   19
      Top             =   120
      Width           =   3255
      Begin VB.OptionButton Op1 
         Alignment       =   1  'Right Justify
         Caption         =   "不处理"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   22
         Top             =   0
         Width           =   855
      End
      Begin VB.OptionButton Op1 
         Alignment       =   1  'Right Justify
         Caption         =   "单字重复"
         Height          =   255
         Index           =   1
         Left            =   960
         TabIndex        =   21
         Top             =   0
         Value           =   -1  'True
         Width           =   1095
      End
      Begin VB.OptionButton Op1 
         Alignment       =   1  'Right Justify
         Caption         =   "加空格"
         Height          =   255
         Index           =   2
         Left            =   2280
         TabIndex        =   20
         Top             =   0
         Width           =   975
      End
   End
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   255
      Left            =   3540
      ScaleHeight     =   255
      ScaleWidth      =   3255
      TabIndex        =   15
      Top             =   360
      Width           =   3255
      Begin VB.OptionButton Op2 
         Alignment       =   1  'Right Justify
         Caption         =   "加空格"
         Height          =   255
         Index           =   2
         Left            =   2280
         TabIndex        =   18
         Top             =   0
         Width           =   975
      End
      Begin VB.OptionButton Op2 
         Alignment       =   1  'Right Justify
         Caption         =   "单字重复"
         Height          =   255
         Index           =   1
         Left            =   960
         TabIndex        =   17
         Top             =   0
         Value           =   -1  'True
         Width           =   1095
      End
      Begin VB.OptionButton Op2 
         Alignment       =   1  'Right Justify
         Caption         =   "不处理"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   16
         Top             =   0
         Width           =   855
      End
   End
   Begin VB.CommandButton CmdSave 
      Caption         =   "保存到文件"
      Height          =   375
      Left            =   60
      TabIndex        =   12
      Top             =   4500
      Width           =   1575
   End
   Begin VB.CommandButton CmdCopy 
      Caption         =   "复制到剪贴板"
      Height          =   375
      Left            =   60
      TabIndex        =   5
      Top             =   4080
      Width           =   1575
   End
   Begin VB.PictureBox PicCon 
      BorderStyle     =   0  'None
      Height          =   1455
      Left            =   60
      ScaleHeight     =   1455
      ScaleWidth      =   1575
      TabIndex        =   11
      Top             =   1440
      Width           =   1575
      Begin VB.TextBox TxtOut 
         Height          =   1455
         Left            =   0
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   2
         Top             =   0
         Width           =   1575
      End
   End
   Begin VB.TextBox TxtBack 
      Height          =   375
      Left            =   60
      TabIndex        =   1
      Top             =   780
      Width           =   1575
   End
   Begin VB.PictureBox PicMain 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H00000000&
      Height          =   1575
      Left            =   2340
      ScaleHeight     =   105
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   121
      TabIndex        =   8
      Top             =   960
      Visible         =   0   'False
      Width           =   1815
   End
   Begin MSComDlg.CommonDialog CDGMain 
      Left            =   2220
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton CmdFont 
      Caption         =   "设置字体"
      Height          =   375
      Left            =   60
      TabIndex        =   3
      Top             =   2940
      Width           =   1575
   End
   Begin VB.CommandButton CmdMain 
      Caption         =   "开始生成"
      Height          =   375
      Left            =   60
      TabIndex        =   4
      Top             =   3660
      Width           =   1575
   End
   Begin VB.TextBox TxtIn 
      Height          =   375
      Left            =   60
      TabIndex        =   0
      Top             =   180
      Width           =   1575
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "生成文字:"
      Height          =   180
      Index           =   2
      Left            =   60
      TabIndex        =   25
      Top             =   1200
      Width           =   810
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "背景文字:"
      Height          =   180
      Index           =   1
      Left            =   60
      TabIndex        =   24
      Top             =   600
      Width           =   810
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "组合文字:"
      Height          =   180
      Index           =   0
      Left            =   60
      TabIndex        =   23
      Top             =   0
      Width           =   810
   End
   Begin VB.Label Lblbac 
      AutoSize        =   -1  'True
      Caption         =   "背  景 英文>>中文："
      Height          =   180
      Left            =   1740
      TabIndex        =   14
      Top             =   360
      Width           =   1710
   End
   Begin VB.Label LblEng 
      AutoSize        =   -1  'True
      Caption         =   "组合字 英文>>中文："
      Height          =   180
      Left            =   1740
      TabIndex        =   13
      Top             =   120
      Width           =   1710
   End
   Begin VB.Label TxtY 
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   900
      TabIndex        =   10
      Top             =   3360
      Width           =   735
   End
   Begin VB.Label TxtX 
      BorderStyle     =   1  'Fixed Single
      Height          =   255
      Left            =   60
      TabIndex        =   9
      Top             =   3360
      Width           =   735
   End
   Begin VB.Label LblMain 
      AutoSize        =   -1  'True
      BackColor       =   &H00FFC0FF&
      Caption         =   "L"
      Height          =   180
      Left            =   1980
      TabIndex        =   7
      Top             =   2280
      Visible         =   0   'False
      Width           =   90
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim AllOutStr As String
Private Sub CmdCopy_Click()
    Clipboard.Clear
    Clipboard.SetText TxtMain.Text
End Sub
Private Sub CmdFont_Click()
On Error Resume Next
CDGMain.Flags = 255
CDGMain.ShowFont
With TxtOut
    .FontName = CDGMain.FontName
    .FontSize = CDGMain.FontSize
    .FontItalic = CDGMain.FontItalic
    .FontBold = CDGMain.FontBold
    LblMain.FontName = CDGMain.FontName
End With
With LblMain
    .FontName = CDGMain.FontName
    .FontSize = CDGMain.FontSize
    .FontItalic = CDGMain.FontItalic
    .FontBold = CDGMain.FontBold
End With
With PicMain
    .FontName = CDGMain.FontName
    .FontSize = CDGMain.FontSize
    .FontItalic = CDGMain.FontItalic
    .FontBold = CDGMain.FontBold
End With
    
End Sub
Private Sub CmdMain_Click()
Dim IsEng As Boolean, WhSel As Integer, WhSelBack As Integer
Dim Px As Long, Py As Long, N As Long, AllOutStrNum As Long
Dim StrIn() As String, StrInLen As Long, CurStr As String, CurStrInLen As Long
Dim StrBack() As String, StrBackLen As Long, CurStrBack As String, CurStrBackLen As Long
Dim StrOut As String
Dim S As String
Dim AllStr As String
    If TxtIn.Text = "" Then MsgBox "请输入组合字": Exit Sub
    If TxtOut.Text = "" Then MsgBox "请输入输出文字": Exit Sub
    If TxtBack.Text = "" Then TxtBack.Text = " "
    For N = 0 To 2
        If Op1(N).Value = True Then WhSel = N
        If Op2(N).Value = True Then WhSelBack = N
    Next N
    
    S = TxtIn.Text
    StrInLen = Len(S)
    IsEng = True
    ReDim StrIn(0)
    For N = 1 To StrInLen
        CurStr = Mid(S, N, 1)
        ReDim Preserve StrIn(0 To UBound(StrIn) + 1)
        StrIn(UBound(StrIn)) = CurStr
        If Asc(CurStr) < 0 Then
            IsEng = False
        Else
            If WhSel = 1 Then
                StrIn(UBound(StrIn)) = CurStr & CurStr
            ElseIf WhSel = 2 Then
                StrIn(UBound(StrIn)) = CurStr & " "
            End If
        End If
    Next N
    If IsEng = True And WhSel > 0 And LblEng.Tag = "" Then MsgBox "组合字符无中文，建议将英文>>中文选择“不处理!”": LblEng.Tag = "0"
    
    S = TxtBack.Text
    StrBackLen = Len(S)
    ReDim StrBack(0)
    For N = 1 To StrBackLen
        CurStrBack = Mid(S, N, 1)
        ReDim Preserve StrBack(0 To UBound(StrBack) + 1)
        StrBack(UBound(StrBack)) = CurStrBack
        If Asc(CurStrBack) > 0 And Asc(CurStrBack) < 256 Then
            If WhSelBack = 1 Then
                StrBack(UBound(StrBack)) = CurStrBack & CurStrBack
            ElseIf WhSelBack = 2 Then
                StrBack(UBound(StrBack)) = CurStrBack & " "
            End If
        End If
    Next N
    
    AllOutStr = TxtOut.Text
    StrInLen = UBound(StrIn)
    StrBackLen = UBound(StrBack)
    CurStrInLen = 0
    CurStrBackLen = 0
    For AllOutStrNum = 1 To Len(AllOutStr)
        S = ""
        Call GetPicXY(Mid(AllOutStr, AllOutStrNum, 1))
        For N = 0 To PicMain.ScaleHeight - 1
            For Px = 0 To PicMain.ScaleWidth - 1
                If PicMain.Point(Px, N) = 0 Then GoTo GETPY
            Next Px
        Next N
GETPY:
        For Py = IIf(N < 6, 0, N - 3) To PicMain.ScaleHeight - 1
            For Px = 0 To PicMain.ScaleWidth - 1
                CurStrInLen = CurStrInLen Mod StrInLen + 1
                CurStrBackLen = CurStrBackLen Mod StrBackLen + 1
                If PicMain.Point(Px, Py) = 0 Then S = S & StrIn(CurStrInLen) Else S = S & StrBack(CurStrBackLen)
            Next Px
            AllStr = AllStr & S & Chr(13) & Chr(10)
            S = ""
        Next Py
    Next AllOutStrNum
    
    TxtMain.Text = AllStr
    AllStr = ""
    Erase StrIn
    Erase StrBack
End Sub
Private Sub CmdSave_Click()
On Error Resume Next
    Dim FName As String
    Dim A As Integer
    CDGMain.Flags = 0
    CDGMain.Filter = "*.txt|*.txt"
    CDGMain.ShowSave
    FName = CDGMain.FileName
    If FName = "" Then Exit Sub
    If Dir(FName, vbSystem + vbHidden) <> "" Then A = MsgBox("该文件已经存在，是否要覆盖？", vbOKCancel, "确定")
    If A = vbCancel Then Exit Sub
    Open FName For Output As #1
        Print #1, TxtMain.Text
    Close #1
If Err Then MsgBox "写入不成功，文件可能写保护", vbCritical, "错误"
End Sub
Private Sub CmgMsg_Click()
Dim SStr As String
    SStr = "该程序完全用于娱乐！" & Chr(13) & Chr(10) & Chr(13) & Chr(10)
    SStr = SStr & "组合文字即所构成目标文字的主要文字" & Chr(13) & Chr(10)
    SStr = SStr & "背景文字作为填充，通常不选（即用空格），也可以用文字" & Chr(13) & Chr(10)
    SStr = SStr & "组合与背景最好是对比分明的，否则看不清" & Chr(13) & Chr(10)
    SStr = SStr & "可以是多个文字，将用来循环填充！" & Chr(13) & Chr(10)
    MsgBox SStr, vbInformation, "怎么做大字?"
    SStr = ""
End Sub
Private Sub Form_Load()
TxtOut.Height = TxtOut.Width
End Sub
Private Sub TxtMain_DblClick()
TxtMain.SelStart = 0
TxtMain.SelLength = Len(TxtMain.Text)
End Sub
Private Sub TxtOut_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then Call CmdMain_Click
End Sub
Private Sub TxtOut_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    TxtOut.SelStart = 0
    TxtOut.SelLength = Len(TxtOut.Text)
End Sub
Private Sub GetPicXY(ByVal WhStr As String)
    PicMain.Cls
    LblMain.Caption = WhStr
    PicMain.Width = LblMain.Width
    PicMain.Height = LblMain.Height
    If PicMain.FontItalic = True Then PicMain.Width = PicMain.Width * 1.2
    PicMain.Print WhStr
    
    TxtX = PicMain.Width
    TxtY = PicMain.Height
End Sub

						