没事干就写了一个灌水工具！源码如下：
form1:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "水王一号"
ClientHeight = 4320
ClientLeft = 45
ClientTop = 330
ClientWidth = 7140
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4320
ScaleWidth = 7140
StartUpPosition = 3 '窗口缺省
Begin VB.Frame Frame1
Caption = "显示模式"
Height = 555
Left = 15
TabIndex = 10
Top = 30
Width = 1680
Begin VB.OptionButton optHor
Caption = "横"
Height = 225
Left = 975
TabIndex = 12
Top = 240
Width = 570
End
Begin VB.OptionButton optVer
Caption = "竖"
Height = 225
Left = 150
TabIndex = 11
Top = 225
Value = -1 'True
Width = 570
End
End
Begin VB.TextBox txtFill
Height = 1230
Left = 15
TabIndex = 8
Top = 2115
Width = 1710
End
Begin MSComDlg.CommonDialog cdg
Left = 2100
Top = 4320
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.ComboBox cboFontSize
Height = 300
Left = 15
TabIndex = 7
Text = "Combo1"
Top = 900
Width = 1710
End
Begin VB.CommandButton cmdSelFont
Caption = "字体"
Height = 300
Left = 270
TabIndex = 5
Top = 3510
Width = 1215
End
Begin VB.CommandButton cmdCreate
Caption = "生成"
Height = 300
Left = 270
TabIndex = 4
Top = 3960
Width = 1215
End
Begin VB.TextBox txtSrc
Height = 330
Left = 15
TabIndex = 2
Top = 1470
Width = 1710
End
Begin VB.PictureBox pichide
AutoRedraw = -1 'True
BackColor = &H00FFFFFF&
BeginProperty Font
Name = "楷体_GB2312"
Size = 15.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4740
Left = 45
ScaleHeight = 312
ScaleMode = 3 'Pixel
ScaleWidth = 499
TabIndex = 1
Top = 4440
Width = 7545
End
Begin VB.TextBox txtDen
Height = 4230
Left = 1845
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 45
Width = 5235
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "填充文字"
Height = 180
Left = 30
TabIndex = 9
Top = 1860
Width = 720
End
Begin VB.Label Label3
Caption = "字体大小"
Height = 210
Left = -15
TabIndex = 6
Top = 645
Width = 885
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "显示文字"
Height = 180
Left = 15
TabIndex = 3
Top = 1245
Width = 720
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'********************************************************
'软件名称：水王一号
'主要作用：生成图形字符，用于论坛灌水时，
'主要原理：根据文字输入像素点的RGB值，用其它的文字来代替，一个像
'素点宽占两格，高占一格，所以填空的时候，一个中文字符占
'两格，英文字符占一格。
'作 者：york
'时 间：2005/01/04
'电子邮箱：yorkRao@126.com
'版权信息：欢迎复制和传播,但请保留以上信息
' 请大家多多指正
'**********************************************************
Option Explicit
Dim sFill As String ' 填空文字
Enum DrawStyle
StyleHorizontal
StyleVertical
End Enum
Dim lFontHeight As Long
Dim lFontWidth As Long
Private Sub cboFontSize_LostFocus()
pichide.FontSize = Val(cboFontSize.Text)
End Sub
'---------------------生成图形文字-------------------
Private Sub cmdCreate_Click()
Dim sSrc As String
Dim sDen As String
Dim i As Integer, j As Integer
sSrc = Trim$(txtSrc.Text)
If sSrc = "" Then
MsgBox "要输入出的文字为空，请重新输入！", vbInformation, "系统信息"
txtSrc.SetFocus
Exit Sub
End If
If Trim(txtFill.Text) = "" Then
MsgBox "填充字符为空，请重新输入！", vbInformation, "系统信息"
txtFill.SetFocus
Exit Sub
End If
sDen = ""
DrawStr sSrc, IIf(optHor.Value, StyleHorizontal, StyleVertical), pichide ' 把文字画上去
txtDen.Text = GetGraphicChar(txtFill.Text, lFontHeight, lFontWidth, RGB(255, 255, 255), pichide)
End Sub
'-------------选择字体-----------------
Private Sub cmdSelFont_Click()
On Error GoTo Errhandle
With cdg
.Flags = FontsConstants.cdlCFScreenFonts Or FontsConstants.cdlCFEffects
.FontName = pichide.FontName
.FontBold = pichide.FontBold
.FontItalic = pichide.FontItalic
.FontSize = pichide.FontSize
.FontStrikethru = pichide.FontStrikethru
.FontUnderline = pichide.FontUnderline
.ShowFont
pichide.FontName = .FontName
pichide.FontBold = .FontBold
pichide.FontItalic = .FontItalic
pichide.FontSize = .FontSize
pichide.FontStrikethru = .FontStrikethru
pichide.FontUnderline = .FontUnderline
End With
Exit Sub
Errhandle:
Exit Sub
End Sub
Private Sub Form_Initialize()
AppendSystemMem Me.hwnd, ConstAboutID, ConstAboutName
End Sub
Private Sub Form_Load()
HookWindow Me.hwnd
Dim i As Integer
For i = 10 To 30
cboFontSize.AddItem i
Next
cboFontSize.ListIndex = 5
End Sub
' ****************************将字符画到PictureBox里面**********************
'函 数 名：DrawStr
'作用说明：将字符按给定的方式输出到picturebox中去
'参数说明：pstr 要按输入出的文字,pstyle 输出的方式,pPicBox 要输出的目标Picturebox
'返 回 值：函数是否正确执行
'时 间：2005/01/03
'作 者：york
' E-Mail：yorkRao@126.com
'版权信息：欢迎复制和传播,但请保留以上信息
'************************************************************************
Private Function DrawStr(ByVal pstr As String, ByVal pStyle As DrawStyle, pPicBox As PictureBox) As Boolean
Dim i As Integer, j As Integer
Dim iLen As Integer ' 字符数
Dim sTmp As String
Dim iOldMode As Integer
On Error GoTo Errhandle
sTmp = Trim(pstr)
If sTmp = "" Then
Exit Function
End If
iLen = Len(sTmp)
With pPicBox
.CurrentX = 0
.CurrentY = 0
iOldMode = .ScaleMode '保存原来的MODE
.ScaleMode = 3 '将MODE设为PIEXL
.Cls
If pStyle = StyleHorizontal Then
lFontHeight = .TextHeight(sTmp)
lFontWidth = .TextWidth(sTmp)
pPicBox.Print sTmp
Else
lFontHeight = 0
lFontWidth = 0
For i = 1 To iLen
If lFontWidth < .TextWidth(Mid(sTmp, i, 1)) Then
lFontWidth = .TextWidth(Mid(sTmp, i, 1))
End If
lFontHeight = lFontHeight + .TextHeight(Mid(sTmp, i, 1))
pPicBox.Print Mid(sTmp, i, 1)
.CurrentX = 0
'.CurrentY = .CurrentY + .TextHeight(Mid(sTmp, i, 1))
Next
End If
End With
pPicBox.ScaleMode = iOldMode '恢复原来的MODE
DrawStr = True
Exit Function
Errhandle:
DrawStr = False
End Function
' ****************************获取图形字符********************************
'函 数 名：GetGraphicChar
'作用说明：根据给定picturebox里面的内容，获得图形字符
'参数说明：pFillChar 填空字符，pHeight,pWidth 字符的高和宽 ,pMaskColor 要屏蔽的颜色
' pPicBox 字符所在的picturebox
'返 回 值：图形字符
'时 间：2005/01/03
'作 者：york
' E-Mail：yorkRao@126.com
'版权信息：欢迎复制、传播和使用,但请保留以上信息
'************************************************************************
Public Function GetGraphicChar(ByVal pFillchar As String, ByVal pHeight As Long, ByVal pwidth As Long, _
ByVal pMaskColor As Long, pPicBox As PictureBox) As String
Dim iLen As Integer '填充文字的字符数
Dim iCurPos As Integer '填空文字当前的位置
Dim bOverplus As Boolean '是否有剩余
Dim i As Long, j As Long
Dim sTmp As String
Dim sDen As String
On Error GoTo Errhandle
sTmp = Replace(pFillchar, " ", "") '将空格去掉
If sTmp = "" Then
Exit Function
End If
With pPicBox
For i = 0 To pHeight - 1
For j = 0 To pwidth - 1
If GetPixel(.hdc, j, i) <> pMaskColor Then
sDen = sDen & CalChar(sTmp, iCurPos, bOverplus) ' 计算当前的字符
Else
sDen = sDen & " "
End If
Next
sDen = sDen & vbCrLf
Next
End With
GetGraphicChar = sDen
Exit Function
Errhandle:
GetGraphicChar = ""
Exit Function
End Function
' ****************************计算当前的字符********************************
'函 数 名：CalChar
'作用说明：根据给定填充字符和当前位置，获得图形字符
'参数说明：pFillChar 填空字符，curPos 字符串当前的位置 ,pOverplus 是否剩余
'返 回 值：当前的字符
'时 间：2005/01/03
'作 者：york
' E-Mail：yorkRao@126.com
'版权信息：欢迎复制、传播和使用,但请保留以上信息
'************************************************************************
Public Function CalChar(ByVal pFillchar As String, curPos As Integer, pOverplus As Boolean) As String
Dim i As Integer
On Error GoTo Errhandle
If Trim(pFillchar) = "" Then ' 如果为空
Exit Function
ElseIf Len(pFillchar) = 1 Then ' 如果填空字符为就一个，那么复制一个
pFillchar = pFillchar & pFillchar
Else
pFillchar = pFillchar & Left(pFillchar, 1)
End If
If curPos > Len(pFillchar) - 1 Or curPos = 0 Then
curPos = 1
End If
If pOverplus = True Then '有剩余
If TextWidth(Mid(pFillchar, curPos, 1)) > TextHeight("*") Then ' 如果是该符号占两格
CalChar = Mid(pFillchar, curPos, 1)
curPos = curPos + 1 ' 填充字符数加一
pOverplus = True ' 还有剩余
Else ' 该字符占一格
CalChar = Mid(pFillchar, curPos, 1)
curPos = curPos + 1
pOverplus = False ' 将剩余补上
End If
Else ' 不剩余
If TextWidth(Mid(pFillchar, curPos, 1)) > TextWidth("*") Then ' 如果占两格
CalChar = Mid(pFillchar, curPos, 1)
curPos = curPos + 1
pOverplus = False
Else ' 如果当前字符占一格
CalChar = Mid(pFillchar, curPos, 2) ' 取两个字符
curPos = curPos + 2
pOverplus = TextWidth(Mid(pFillchar, curPos - 1, 1)) > TextHeight("*") ' 如果第二个字符占两格就剩余
End If
End If
Exit Function
Errhandle:
CalChar = ""
End Function
Private Sub Form_Unload(Cancel As Integer)
UnHook Me.hwnd
End Sub
mod中的代码：
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Public Const MF_STRING = &H0&
Public Const MF_SEPARATOR = &H800&
Public Const GWL_WNDPROC = (-4)
Private loldWnd As Long
Public Const ConstAboutID = &H10 ' 关于菜单ID值
Public Const ConstAboutName = "关于水王一号"
Public Const WM_SYSCOMMAND = &H112
Public Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(loldWnd, hwnd, Msg, wParam, lParam) '执行窗体原有过程
If Msg = WM_SYSCOMMAND Then
If (wParam And &HFFF0) = ConstAboutID Then
frmAbout.Show vbModal
End If
End If
End Function
Public Function HookWindow(ByVal hwnd As Long) As Long
loldWnd = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc) '子类化窗体
End Function
Public Sub UnHook(ByVal hwnd As Long) ' 恢复窗体原有过程
SetWindowLong hwnd, GWL_WNDPROC, loldWnd
End Sub
Public Function AppendSystemMem(ByVal hwnd As Long, ByVal pMenuid As Long, ByVal pMenuStr As String) As Boolean
Dim hSystemMenu As Long
hSystemMenu = GetSystemMenu(hwnd, False)
AppendMenu hSystemMenu, MF_SEPARATOR, 0&, 0&
AppendMenu hSystemMenu, MF_STRING, pMenuid, pMenuStr
End Function
下载地址：http://www.blogerhome.com/uploadfile/20051614213321.rar
扫一扫
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
