Microsoft Visual Basic's MDI window can set a window background diagram through the window's Picture property, making the program to beautify a lot. However, when the image loads, the window will appear in different resolutions, such as the image designed at 800 * 600, and a piece of empty (background color is out of background, very Ugly). And when the size of the window is changed by the user, the picture will also be loaded, making the very beautiful picture of the original design change, "the author is explored during the development of the project, wrote it with Windows Set a similar function with a desktop background. Good things don't dare to enjoy exclusive, write out with you.
The program source code can be downloaded on my website: http://www.j2soft.cn/
Author: Cuizhan Min EMAIL: CUIZM@163.COM 2004.6.8
The following is the program code:
Option expedition
'MDI window code
'/ ================================================ ============================ / '| author: Cuizhan Min 2003.6.21 |' | EMAIL: CUIZM@163.COM | '| Add a MDI main window, a normal window, the sub-window set to MDI (Mdichild property is set to true) | Add a module to set the API function and structure of the Open File dialog | "in the MDI main window In the middle plus a menu, the menu is called background, adds four submenus, which is: Select background diagram, | '| Default background, stretching and tiling, its code as shown below |' | | '/ == ============================================================================================================================================================================================================= ======================================================================================================================================================================================================================================================================================- shop, then set the menu item ls_tmp = GetSetting ( "OrientZiXun", "BackGround", "LaShen") If ls_tmp = "True" then mnuPull.Checked = True mnuLay.Checked = False Else mnuPull.Checked = False mnuLay.Checked = True End ifend sub
Private sub mdiform_resize () on error resume next frMback.setback frMBack.hidend Sub
'Setting the default picture private sub mnudefault_click () if msgbox ("Do you make sure you want to clear the current background, do you choose the default background?", Vbquestion vbyesno) = vbno dam screen.mousepointer = 11 doevents Savesetting "Orientzixun", "Orientzixun" backGround "," PathValue "," "frmBack.SetBack frmBack.Hide Screen.MousePointer = 0End Sub 'tiled background Private Sub mnuLay_Click () mnuPull.Checked = False mnuLay.Checked = True SaveSetting" OrientZiXun "," backGround "," Lashen, "false" frMback.Setback frMckack.hidend Sub
'Stretching background private sub mnupull_click () mnupull.checked = true mnulay.checked = false savesetting "orientzixun", "background", "true", "true" frMback.setback frMback.hidend Sub
'Select a background image Private Sub mnuSelBack_Click () On Error GoTo Errhandle Dim fName As String, sName As String, OfName As OPENFILENAME OfName.lStructSize = Len (OfName) OfName.hwndOwner = hWnd OfName.hInstance = App.hInstance OfName.lpstrFilter = " Image file "& chr (0) &" * .bmp; *. Jpg; *. JPEG; *. Gif; *. ICO "OFNAME.LPSTRFILE = Space (255) & chr (0) OFNAME.NMAXFILE = 256 ofname. lpstrFileTitle = Space (255) & Chr (0) OfName.nMaxFileTitle = 256 OfName.lpstrTitle = "select image ..." OfName.flags = OFN_LONGNAMES OFN_PATHMUSTEXIST OFN_FILEMUSTEXIST OFN_HIDEREADONLY If GetOpenFileName (OfName) Then Screen.MousePointer = 11 DoEvents SaveSetting "OrientZiXun", "BackGround", "PathValue", OfName.lpstrFile frmBack.SetBack frmBack.Hide Screen.MousePointer = 0 End If Exit SubErrhandle: Screen.MousePointer = 0 MsgBox Err.DescriptionEnd subOption Explicit
'Background window code
'/ ================================================ ============================ / '| author: Cuizhan Min 2003.6.21 |' | EMAIL: CUIZM@163.COM | '| Add a PictureBox control and an image control in the window, named: Picback and | '| IMGDEFAULT |' | | | | | | | '/ =============== ============================================================================================================================================================================================================= =========== /
'Setting up background functions Public Sub setback () ON Error Resume Next Dim I as long, j as long, ls_path as string' reads background image path from the registry LS_PATH = GetSetting ("Orientzixun", "Background", "PathValue" IF TRIM (LS_PATH) <> "" THEN IF DIR (LS_PATH) <> "" "The picback.picture = loadingPicture (ls_path) 'exists, display the picture in the buffer Else Picback.Picture = IMGDEFAULT.PICTURE' Picture Does not exist, with the default picture end if else picback.picture = imgdefault.picture 'path is empty, with the default picture end ifif frmmain.mnupull.checked the' if it is stretching me.paintPicture Picback.Picture, 0, 0, frmMain.Width, frmMain.Height Else 'if tiling For j = 0 to frmMain.ScaleHeight Step picBack.ScaleHeight For i = 0 to frmMain.ScaleWidth Step picBack.ScaleWidth Me.PaintPicture picBack.Picture, i, j Next Next End IF
Me.font.name = "体 _GB2312" me.forecolor = vbplue me.font.size = 24 me.fontbold = true me.currentx = frmmain.scalewidth - 3500 me.currenty = frmmain.scaleHeight - 1000 me.print " Consultation management system "frmmain.picture = me.image frmmain.backcolor = frmmain.backcolor - 1 'For the MDI window, the background will not change the end sub
Private Sub Form_Load () ON Error ResMe Next Me.Autoredraw = true Picback.autosize = TrueEnd SUB
Option expedition
'Module code
Public Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As StringEnd TypePublic Const OFN_LONGNAMES = & H200000Public Const OFN_PATHMUSTEXIST = & H800Public Const OFN_FILEMUSTEXIST = & H1000Public Const OFN_HIDEREADONLY = & H4Public Const OFN_EXPLORER = & H80000Public Const OFN_OVERWRITEPROMPT = & H2
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As LongPublic Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
