I have written a irrigation tool without doing things! The source code is as follows:
Form1:
Version 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB} # 1.2 # 0"; "COMDLG32.OCX" begin vb.form frmmain border = 1 'fixed single caption = "Water King No.1" ClientHeight = 4320 ClientLeft = 45 ClientTop = 330 ClientWidth = 7140 Icon = "Form1.frx": 0000 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 4320 ScaleWidth = 7140 StartUpPosition = 3' default window Begin VB.Frame Frame1 Caption = "display mode "Height = 555 Left = 15 TabIndex = 10 Top = 30 Width = 1680 Begin VB.OptionButton optHor Caption =" horizontal "Height = 225 Left = 975 TabIndex = 12 Top = 240 Width = 570 End Begin VB.OptionButton optVer Caption =" Running "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 = "Font" Height = 300 Left = 270 TabIndex = 5 Top = 3510 Width = 1215 End Begin VB.CommandButton cmdCreate Caption = "generate" 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 Autoraw = -1 'True Backcolor = & H00FFFFFFFFFFFFFFFFF & BEGINPROPERTY FONT Name = "italics _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 = 'True Caption = "padding characters 5235 End Begin VB.Label Label4 AutoSize = -1 "Height = 180 Left = 30 TabINDEX = 9 TOP = 1860 width = 720 end begin vb.label label3 caption =" Font size "height = 210 left = -15 TabINDEX = 6 TOP = 645 width = 885 End Begin vb.label label2 AutoSize = -1 'true caption = "Show text" Height = 180 left = 15 TabINDEX = 3 TOP = 1245 width = 720 Endendattribute VB_Name = "frmmain" attribute vb_globalname Space = false = falsettribute vb_predeclaredid = true = false VB_EXPOSED = false '************************************************ ****************** "Software Name: Water King No.1 'main role: Generate graphic characters, when used for the forum water,' main principle: input pixel point according to text RGB value, instead of other words, one like 'pigwidth is two grids, high and one, so when filling out, a Chinese character accounts for' two, English characters occupying one.
'Compressed: York' Time: 2005/01/04 'Email: Yorkrao@126.com' Copyright Information: Welcome to copy and spread, please keep the above information 'Please correct more "******* *********************************************************** * Option ExplicitDim sFill As String 'fill in the blank text Enum DrawStyle StyleHorizontal StyleVerticalEnd EnumDim lFontHeight As LongDim lFontWidth As LongPrivate Sub cboFontSize_LostFocus () pichide.FontSize = Val (cboFontSize.Text) End Sub' ------------- -------- Generate graphic text ------------------- private subdcreate_click () Dim Ssrc As String Dim Sden As String Dim i as integer, J AS Integer ssrc = trim $ (txtsrc.text) if ssrc = "" "" "" ",", vbinformation, "system information" TXTSRC.SETFOCUS EXIT SUB END IF TRIM (TxtFill.) TEXT) = "" "" "" ", vbinformation," system information "txtfill.setfocus exit sub * =" DrawStr SSRC, IIF (Opthor.Value, Styleizontal, Style.Value, STYLEHORIZONTAL, STYLEVERTICAL), Pichide 'pulls text to txtden.text = getGraphicchar (TX Tfill.Text, Lfontheight, LFontWidth, RGB (255, 255, 255), Pichide) End Sub '------------- Select Font ------------- ---- 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 SubErrhandle: Exit SubEnd SubPrivate Sub Form_initialize () appendsystemmem me.hwnd, constaboutid, constaboutnameend Sub
PRIVATE SUB FORM_LOAD () hookwindow me.hwnd Dim i as integer for i = 10 to 30 cbofontsize.additem i Next cbofontsize.listindex = 5END SUB '********************* ********* Painted characters to PictureBox ********************************* 'function name: DrawStr' action Description: Press the character to Decided to PictureBox to PictureBox 'parameter description: PSTR To press the input text, PStyle output, PPICBOX to output the target PictureBox' return value: function correctly 'time: 2005/01/03' Person: York 'E-mail: Yorkrao@126.com' copyright information: Welcome to copy and spread, please keep the above information "********************* *********************************************************** 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 'characters 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 'Save the original mode .scalemode = 3 'The MODE to 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 End End End End WITH PPICBOX.SCALEMODE = IOLDMODE 'Restore the original mode DrawStr = true exit functionerrhandle: DrawStr = falsend function' ********************************************* Get graphics characters ******************************* 'function name: getGraphicchar' action description: According to the given PictureBox Content, get graphic characters' parameter description: PfillChar fill in the empty character, PHEIGHT, PWIDTH characters High and wide, PMASKCOLOR The color 'PCTUREBOX' return value of PPicbox characters: Graphic Character 'Time: 2005/01/03' Person: York 'E-mail: Yorkrao@126.com' copyright information: Welcome to copy, spread, and use, please keep the above information '******************* *********************************************************** **
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 'the number of characters to fill the text Dim iCurPos As Integer' fill in the blank text current Location DIM BOVERPLUS As Boolean 'Is there any remaining DIM I as long, J AS Long Dim Stmp AS String Dim Sden As String On Error Goto Errhandle Stmp = Replace (Pfillchar, "," ")' Takes the space to 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) ' Current character else sden = sden & "end if next sden = sden & vbcrf next End with getgraphicchar = sden exit functionerrhandle: GE TGRAPHICCHAR = "" EXIT functionend function "********************************************************************************** ********************** 'Function Name: Calchar' Declaring Description: Get graphic character 'parameter description according to the given fill characters and current position: PfillChar fill in the empty character Curpos string current location, whether PoverPlus remains' return value: Current character 'Time: 2005/01/03' Author: York 'E-mail: Yorkrao@126.com' copyright information: Welcome copy, spread And use, but please keep the above information '
*********************************************************** ********************** Public Function Calchar (Byval Pfillchar As String, Curpos As INTEGER, POVERPLUS As Boolean) AS STRING DIM I AS INTEGER ON ERROR GOTO ERRHANDE IF Trim (Pfillchar) = "" "If the EXIT FUNCTION ELSEIF LEN (Pfillchar) = 1 Then 'If the fill in the blanks is one, then copy a pfillchar = Pfillchar & Pfillchar else Pfillchar = Pfillchar & Left (pfillchar, 1) end If IF CURPOS> LEN (Pfillchar) - 1 or curpos = 0 TEN CURPOS = 1 end if if poentplus = true kil textwidth (MID (Pfillchar, Curpos, 1))> TextHeight ("*") Then 'If This is the symbol of two grid Calchar = MID (Pfillchar, Curpos, 1) Curpos = CURPOS 1 'paddler number plus one POV Erplus = true 'also has the remaining else' This character occupies a piece of Calchar = MID (Pfillchar, Curpos, 1) Curpos = CURPOS 1 PoverPlus = false 'Put the remaining END IF ELSE' does not remain if Textwidth (MID (Pfillchar, Curpos, 1)> TextWidth ("*") THEN '
If you occupy two Calchar = MID (Pfillchar, Curpos, 1) Curpos = CURPOS 1 PoverPlus = false else 'If the current character occupies a piece Calchar = MID (Pfillchar, Curpos, 2)' Take two characters Curpos = Curpos 2 PoverPlus = TextWidth (MID (Pfillchar, Curpos - 1, 1)> TextHeight ("*") 'If the second character occupies two grids, the remaining end if end if EXIT functionerRhandle: Calchar = "" End FunctionPrivate Sub Form_Unload (Cancel As integer) UnHook Me.hWndend Sub
Code in 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 LongPublic Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA "(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function GetPixel Lib" gdi32 "(ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As LongPublic Declare Function GetSystemMenu Lib" user32 "(ByVal hwnd As Long, ByVal bRevert As Long) As LongPublic Declare Function AppendMenu Lib" user32 "Alias" AppendMenuA "(ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As LongPublic Const MF_STRING = & H0 & Public Const MF_SEPARATOR = & H800 & Public Const GWL_WNDPROC = (-4) Private loldWnd As LongPublic Const ConstAboutID = & H10 'on the menu ID values Public Const ConstAboutName = "on water King One" Public Const WM_SYSCOMMAND = & H112Public Function WindowProc (B Yval HWnd As Long, Byval Msg As Long, Byval WParam As Long, BYVAL LPARAM As Long AS Long WINDOWPROC = CallWindowProc (LOLDWND, HWND, MSG, WPARAM, LPARAM) 'Perform Forms IF MSG = WM_SYSCOMMAND THEN IF ( wParam And & HFFF0) = ConstAboutID Then frmAbout.Show vbModal End If End IfEnd FunctionPublic Function HookWindow (ByVal hwnd As Long) As Long loldWnd = SetWindowLong (hwnd, GWL_WNDPROC, AddressOf WindowProc) 'form subclass End FunctionPublic sub unHook (ByVal hwnd As long
Restore the original window procedure SetWindowLong hwnd, GWL_WNDPROC, loldWndEnd SubPublic 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, Pmenustrend Function Download: http://www.blogerhome.com/uploadFile/20051614213321.rar
