背景图块创建器
4.88/5 (21投票s)
一个用于创建有趣背景平铺图像的小型实用程序。包含“设为墙纸”功能
引言
首先：最近的一次更新中出现了一个相当讨厌的 bug，我没有发现。该问题现已解决。对于收到有 bug 版本的 BTC 的各位，我深表歉意。
背景平铺创建器（以下简称“BTC”）是一个简单的实用程序，可以根据现有图像创建背景平铺图像。根据您的源图像以及您在其上的选择，生成的结果可能从精美到怪异不等。只需打开一张图像，用鼠标进行选择，平铺就会自动创建。
BTC 如何创建平铺
当您在源图像上拖动选区时，BTC 会创建一个大小为选区两倍的新空白图像。原始选区放置在左上角。然后，BTC 会水平翻转选区，并将此图像放置在右上角。然后，此第二个图像会垂直翻转并放置在右下角，最后，第三个图像再次水平翻转并绘制到左下角。
您可以通过将鼠标指向适当的拖动手柄并朝一个或另一个方向拖动来调整选区的大小。您还可以通过按住鼠标左键在选区内部拖动来移动选区矩形。平铺和页面背景预览都可以随着您的绘制或移动选区而更新（这看起来很有趣）。要执行此操作，请在左窗格中选中“在选择过程中更新平铺”复选框。请注意，对于大于 100x100 的选区，这可能会对性能产生不利影响。如果您注意到程序在选择过程中有任何部分变慢，只需取消选中该复选框。然后，将在您释放鼠标时更新平铺，而不是在拖动过程中更新。
您可以使用左窗格中的滑块控件来调整完成的平铺的大小。选中“顺时针旋转 90 度”复选框会将平铺顺时针旋转 90 度。考虑到图像是一个平铺，进一步的翻转/旋转操作意义不大。
要保存您的平铺，请单击工具栏中的“保存”按钮。将打开一个标准的 Windows SaveFileDialog。
已知问题：当调整完成的平铺大小以使其变大时，背景预览选项卡中各个平铺之间有时会出现细线。这仅发生在预览中。一旦图像被保存并在其他地方使用，就不会出现线条。我仍在试图弄清楚为什么会发生这种情况。
代码一瞥...
已添加一个引用：Shell32.dll
BTC 导入以下命名空间
Imports System.Windows.Forms
Imports System.IO
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Math
Imports System.Runtime.InteropServices
Imports Shell32
以下是整个项目中使用的变量和矩形
#Region "declarations"
Friend title As String = "Background Tile Creator"
Friend imgName As String 'the filename of the src image
Dim msg As String 'for messages
Dim x, y, l As Integer 'x&y coords, and width/height values
Dim WithEvents pntPnl As New PaintPanel
'-----------------------------------------------------
'sr is the selection rectangle
'r is used in drawing the source image
'RectInfo is a rectangle that holds the value of the
'last instance of the selection rectangle (sr). This
'is used to properly draw a new instance of sr. You'll
'see it used in the MouseMove sub.
'-----------------------------------------------------
Friend r, sr, RectInfo As Rectangle
'grab-handles for resizing selection
Dim grabHandles(8) As Rectangle
Dim curs() As Cursor = {Cursors.SizeNWSE, Cursors.SizeNS, Cursors.SizeNESW, _
Cursors.SizeWE, Cursors.SizeNWSE, Cursors.SizeNS, _
Cursors.SizeNESW, Cursors.SizeWE, Cursors.Default}
Friend grabSize As New Size(6, 6) 'size of grab-handle rects
Friend grabPen As New Pen(Color.Black, 1) 'grab-handle outline
Friend grabBrush As New SolidBrush(Color.White) 'grab-handle fill color
Friend rectPoints As Point 'x-y location of sel rect
Dim selSize As Size 'size of selection rect
'these are for drawing the selection rectangle
Dim myPen As New Pen(Color.White, 1)
Dim innerBrush As New SolidBrush(Color.FromArgb(60, 0, 0, 255))
Dim res As DialogResult
Dim g As Graphics 'draw the original image
'----------------------------------------------------------------
'isDown is true anytime the left mouse button is pressed inside
'the source image.
'canResize is true when the mouse button is pressed over an edge
'of the selection rectangle. You'll get a double-arrow cursor.
'canMove is true when the left mouse button is pressed more than
'two pixels inside the selection rect. This is for moving the
'selection rectangle around the image.
'----------------------------------------------------------------
Dim isDown, canResize, canMove As Boolean
'----------------------------------------------------------------
'original is a copy of the original image used as a source image.
'bmp is the "working" image - a copy of the original
'selBMP is the tile image created when you make a selection
'----------------------------------------------------------------
Friend bmp, original, selBMP As Bitmap
'for determining resize and moving operations
'of the selection rectangle (see mousemove event handler)
Enum CursorPos
TopLeft = 0
TopSide = 1
TopRight = 2
RightSide = 3
BottomRight = 4
BottomSide = 5
BottomLeft = 6
LeftSide = 7
Inside = 8
NotOnRect = 9
End Enum
Dim curPos As CursorPos = CursorPos.NotOnRect
'false after changes to tile - true when saved
Dim isSaved As Boolean = False
'full path of saved tile image
Friend tilePath As String = String.Empty
Dim openPath As String
#End Region
程序加载时要执行的一些操作...
Private Sub LoadApplication() Handles MyBase.Load
Me.WindowState = FormWindowState.Maximized
'if My.Settings.RecentFiles contains items, add them to the
'Open button's dropdown list
Dim rf() As String = My.Settings.RecentFiles.Split("|")
If rf.Length > 0 Then
For Each s As String In rf
If File.Exists(s) Then
tb_Open.DropDown.Items.Add(New ToolStripMenuItem(s))
End If
Next
End If
'--------------End of dropdown list addition---------------
AddHandler Me.Activated, AddressOf UpdateUI
myPen.DashStyle = Drawing2D.DashStyle.Dash
splt_Left.Panel2.Controls.Add(pntPnl)
pntPnl.Dock = DockStyle.Fill
UpdateUI()
End Sub
以及关闭时...
Private Sub main_FormClosing (ByVal sender As Object, _
ByVal e As System.Windows.Forms.FormClosingEventArgs) _
Handles Me.FormClosing
'update My.Settings recent items list
If tb_Open.DropDownItems.Count > 0 Then
Dim itemStr As String = String.Empty
For l = 0 To tb_Open.DropDownItems.Count - 1
If File.Exists(tb_Open.DropDownItems(l).Text) Then
itemStr &= tb_Open.DropDownItems(l).Text
If l < tb_Open.DropDownItems.Count - 1 Then
itemStr &= "|"
End If
End If
Next
My.Settings.RecentFiles = itemStr
My.Settings.Save()
End If
End Sub
要打开源图像，请单击工具栏中的“打开”按钮。这是一个 SplitButton。单击下拉菜单会显示您最近使用的五个源图像。单击按钮的左侧将打开一个 OpenFileDialog。
Private Sub OpenFileFromDialog() Handles tb_Open.ButtonClick
Try
If Directory.Exists(Path.GetDirectoryName(openPath)) Then
dialog_Open.InitialDirectory = openPath
Else
dialog_Open.InitialDirectory = _
Environment.GetFolderPath(Environment.SpecialFolder.MyPictures)
End If
Catch ex As Exception
MsgBox(ex.ToString, MsgBoxStyle.Exclamation, title)
Exit Sub
End Try
res = dialog_Open.ShowDialog
If res = Windows.Forms.DialogResult.OK Then
Try
OpenNewSourceImage(dialog_Open.FileName)
Catch ex As Exception
MsgBox(ex.ToString, MsgBoxStyle.Exclamation, title)
End Try
End If
End Sub
'open from recent files list
Private Sub OpenFromList (ByVal sender As Object, _
ByVal e As System.Windows.Forms.ToolStripItemClickedEventArgs) _
Handles tb_Open.DropDownItemClicked
Try
If File.Exists(e.ClickedItem.Text) Then
OpenNewSourceImage(e.ClickedItem.Text)
Else
tb_Open.DropDownItems.Remove(e.ClickedItem)
MsgBox("The selected file no longer exists." & Chr(10) & _
"The name has been removed from the list.", _
MsgBoxStyle.Information, title)
End If
Catch ex As Exception
MsgBox(ex.ToString, MsgBoxStyle.Exclamation, title)
End Try
End Sub
'this sub uses the value from the subs above to open a source image
Private Sub OpenNewSourceImage(ByVal imgPath As String)
Try
original = Bitmap.FromFile(imgPath)
imgName = imgPath
openPath = imgPath
r = New Rectangle(0, 0, original.Width, original.Height)
sr = Nothing
statLabel_ImgName.Text = imgPath
'set the picturebox backgroundimage to the source image
'the selection rect is drawn over the background
picbox_SrcImage.Size = original.Size
picbox_SrcImage.BackgroundImage = original
Me.Invalidate()
'clear the tile preview picturebox
picbox_TilePreview.Image = Nothing
UpdateUI()
UpdateRecentFiles()
Catch ex As Exception
MsgBox(ex.ToString, MsgBoxStyle.Exclamation, title)
End Try
End Sub
创建选区矩形
与大多数图形应用程序一样，选区矩形是通过在图像上拖动鼠标来定义的。以下是 BTC 的实现方式
- 当左鼠标按钮未按下时
- 当左鼠标按钮按下时
- 当鼠标按钮释放时...
移动鼠标定位以绘制选区，或将其移至现有选区的抓取柄上以调整大小。将鼠标放在选区内部以移动它（光标将变为 Cursors.SizeAll）。
在 MouseMove 事件期间，canResize 和 canMove 布尔变量会设置为 True 或 False。例如，如果您将鼠标指向抓取柄，canResize 变量将设置为 True，而 canMove 设置为 False。
当在源图像上按下左鼠标按钮时，isDown 布尔变量将设置为 True。这会告诉 MouseMove 事件，正在绘制、移动或调整选区的大小。
当 MouseDown 事件发生时，程序将根据在下一个 MouseMove 事件发生时，其中一个布尔值（canMove 或 canResize）是否为 true 来执行操作。
如果 canMove 和 isDown 都为 True（鼠标按钮已按下且鼠标悬停在现有选区矩形内），则在移动鼠标时会拖动选区矩形。如果 isDown 和 canResize 都为 True（鼠标按钮已按下且鼠标悬停在抓取柄上），则在移动鼠标时会调整选区大小。
当鼠标按钮释放并且 MouseUp 事件触发时，isDown 将设置为 False。在按钮释放期间，您可以将鼠标移动到另一个位置（例如，移到另一个抓取柄上），然后再次按下按钮以启动另一个移动/调整大小操作。
每次 MouseUp 事件发生时，程序都会检查是否存在选区矩形。如果存在，则会创建并显示新的平铺。
请注意，您可以通过在源图像上单击鼠标来清除当前选区。
MouseDown 事件处理程序
Private Sub picbox_MouseDown(ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs) _
Handles picbox_SrcImage.MouseDown
x = e.X : y = e.Y
isDown = True
If e.Button = Windows.Forms.MouseButtons.Left AndAlso _
Not canResize AndAlso Not canMove Then
sr.Width = 0
sr.Height = 0
Me.Invalidate()
End If
End Sub
MouseUp 事件处理程序
Private Sub picbox_MouseUp (ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs) _
Handles picbox_SrcImage.MouseUp
RectInfo = New Rectangle(sr.Left, sr.Top, sr.Width, sr.Height)
isDown = False
canMove = False
canResize = False
picbox_SrcImage.Cursor = Cursors.Default
createTile()
End Sub
MouseMove 事件处理程序...
Private Sub picbox_MouseMove(ByVal sender As Object, _
ByVal e As System.Windows.Forms.MouseEventArgs) _
Handles picbox_SrcImage.MouseMove
If Not original Is Nothing Then
If e.X < 0 Or e.X > original.Width _
Or e.Y < 0 Or e.Y > original.Height Then
Exit Sub
End If
If isDown Then 'if left mouse button is down...
sldr_SizeH.Value = 100
sldr_SizeW.Value = 100
'draw new selection rect...
If Not canResize AndAlso Not canMove Then
Dim iLeft As Integer = 0
Dim iTop As Integer = 0
Dim iRight As Integer = original.Width
Dim iBtm As Integer = original.Height
Try
If e.X >= iLeft AndAlso e.X <= iRight _
AndAlso e.Y >= iTop AndAlso e.Y <= iBtm Then
rectPoints = New Point(Min(x, e.X), Min(y, e.Y))
selSize = New Size(Max(x - e.X, e.X - x), Max(y - e.Y, e.Y - y))
BuildRects() 'build the selection rect and its resize handles
End If
Catch ex As Exception
MsgBox("Error making selection..." & Chr(10) & ex.ToString)
End Try
'My.Application.DoEvents()
End If
'------------------------------End Draw Rect------------------------------
'Here's where the CurPos enum is used. The math for resizing
'the selection changes depending upon which side or corner
'of the rectangle has been selected
'resize sel rect...
If canResize Then
Select Case curPos
Case CursorPos.BottomSide
rectPoints = New Point(RectInfo.Left, Min(e.Y, RectInfo.Top))
selSize = New Size(RectInfo.Width, Max(e.Y - RectInfo.Top, RectInfo.Top - e.Y))
BuildRects()
Case CursorPos.TopSide
rectPoints = New Point(RectInfo.Left, Min(e.Y, RectInfo.Bottom))
selSize = New Size(RectInfo.Width, Max(RectInfo.Bottom - e.Y, e.Y - RectInfo.Bottom))
BuildRects()
Case CursorPos.LeftSide
rectPoints = New Point(Min(e.X, RectInfo.Right), RectInfo.Y)
selSize = New Size(Max(RectInfo.Right - e.X, e.X - RectInfo.Right), RectInfo.Height)
BuildRects()
Case CursorPos.RightSide
rectPoints = New Point(Min(e.X, RectInfo.Left), RectInfo.Top)
selSize = New Size(Max(e.X - RectInfo.X, RectInfo.X - e.X), RectInfo.Height)
BuildRects()
Case CursorPos.BottomRight
rectPoints = New Point(Min(e.X, RectInfo.Left), Min(e.Y, RectInfo.Top))
selSize = New Size(Max(e.X - RectInfo.X, RectInfo.X - e.X), _
Max(e.Y - RectInfo.Top, RectInfo.Top - e.Y))
BuildRects()
Case CursorPos.BottomLeft
rectPoints = New Point(Min(e.X, RectInfo.Right), Min(e.Y, RectInfo.Top))
selSize = New Size(Max(RectInfo.Right - e.X, e.X - RectInfo.Right), _
Max(e.Y - RectInfo.Top, RectInfo.Top - e.Y))
BuildRects()
Case CursorPos.TopLeft
rectPoints = New Point(Min(e.X, RectInfo.Right), Min(e.Y, RectInfo.Bottom))
selSize = New Size(Max(RectInfo.Right - e.X, e.X - RectInfo.Right), _
Max(RectInfo.Bottom - e.Y, e.Y - RectInfo.Bottom))
BuildRects()
Case CursorPos.TopRight
rectPoints = New Point(Min(e.X, RectInfo.Left), Min(e.Y, RectInfo.Bottom))
selSize = New Size(Max(e.X - RectInfo.X, RectInfo.X - e.X), _
Max(RectInfo.Bottom - e.Y, e.Y - RectInfo.Bottom))
BuildRects()
End Select
End If
'------------------------end resize sel rect------------------
'move sel rect...
If canMove Then
Dim offsetX As Integer = x - RectInfo.Left
Dim offsetY As Integer = y - RectInfo.Top
If (e.X - offsetX) >= 0 AndAlso ((e.X - offsetX) + _
RectInfo.Width) <= original.Width AndAlso _
(e.Y - offsetY) >= 0 AndAlso ((e.Y - offsetY) + _
RectInfo.Height) <= original.Height Then
rectPoints = New Point(e.X - offsetX, e.Y - offsetY)
selSize = New Size(RectInfo.Width, RectInfo.Height)
BuildRects()
End If
End If
'------------------------end move sel rect----------------------
'if left mouse button is not pressed...
ElseIf Not isDown Then
'check to see if mouse is within a grab handle
For l = 0 To grabHandles.Length - 1
If IsBetween(e.X, e.Y, grabHandles(l)) Then
picbox_SrcImage.Cursor = curs(l)
canResize = True
canMove = False
curPos = l
Exit For
Else
picbox_SrcImage.Cursor = Cursors.Default
canResize = False
canMove = False
curPos = CursorPos.NotOnRect
End If
Next l
'if NOT inside a grab handle, check if mouse is inside sel rect
If Not canResize AndAlso IsBetween(e.X, e.Y, sr) Then
picbox_SrcImage.Cursor = Cursors.SizeAll
canMove = True
canResize = False
curPos = CursorPos.Inside
End If
End If 'isdown
End If 'original is nothing
My.Application.DoEvents()
End Sub
在 MouseMove 期间重新绘制选区矩形时，会调用 BuildRects() 子程序来用当前矩形更新屏幕。
Private Sub BuildRects()
' "sr" is the selection rectangle
' the "grabHandles" array as the name implies
' contains the resize handles for the selection
sr = New Rectangle(rectPoints, selSize)
grabHandles(0) = _
New Rectangle(sr.Left - (grabSize.Width / 2), _
sr.Y - (grabSize.Height / 2), grabSize.Width, _
grabSize.Height) 'top left
grabHandles(1) = _
New Rectangle((sr.Left + (sr.Width / 2)) - grabSize.Width / 2, _
sr.Y - (grabSize.Height / 2), _
grabSize.Width, grabSize.Height) 'top
grabHandles(2) = _
New Rectangle(sr.Right - (grabSize.Width / 2), _
sr.Top - (grabSize.Height / 2), _
grabSize.Width, grabSize.Height) 'top right
grabHandles(3) = _
New Rectangle(sr.Right - (grabSize.Width / 2), _
((sr.Bottom - sr.Height / 2)) _
- grabSize.Height / 2, grabSize.Width, _
grabSize.Height) 'right
grabHandles(4) = _
New Rectangle(sr.Right - (grabSize.Width / 2), _
sr.Bottom - (grabSize.Height / 2), _
grabSize.Width, grabSize.Height) 'bottom right
grabHandles(5) = _
New Rectangle((sr.Right - (sr.Width / 2)) - _
grabSize.Width / 2, sr.Bottom - _
(grabSize.Height / 2), grabSize.Width, _
grabSize.Height) 'bottom
grabHandles(6) = _
New Rectangle(sr.Left - (grabSize.Width / 2), _
sr.Bottom - (grabSize.Height / 2), _
grabSize.Width, grabSize.Height) 'bottom left
grabHandles(7) = _
New Rectangle(sr.Left - (grabSize.Width / 2), _
(sr.Bottom - (sr.Height / 2)) _
- grabSize.Height / 2, grabSize.Width, _
grabSize.Height) 'left
'if "Update tile during selection" checkbox
'is checked then create tile while dragging
'mouse. Otherwise wait until mouse button
'is released.
If chk_AutoCreate.Checked Then
createTile()
Else
Me.Invalidate()
End If
UpdateUI()
End Sub
当鼠标按钮释放时，会调用 createTile() 子程序来创建新的平铺图像。
Private Sub createTile()
If sr.Width > 0 AndAlso sr.Height > 0 Then 'if a selection rect is drawn
Try
'create image from selection
Dim flipImg As New Bitmap(sr.Width, sr.Height)
Dim flipGrph As Graphics = Graphics.FromImage(flipImg)
Dim destRect As New Rectangle(0, 0, sr.Width, sr.Height)
Dim srcRect As New Rectangle(sr.Left, sr.Top, sr.Width, sr.Height)
flipGrph.DrawImage(original, destRect, srcRect, GraphicsUnit.Pixel)
'create the empty bitmap for drawing the mirrored inner tiles
'tmp is a temporary bmp used to create the image
Dim tmp As Bitmap = New Bitmap(flipImg.Width * 2, flipImg.Height * 2)
'selBMP = New Bitmap(flipImg.Width * 2, flipImg.Height * 2)
Dim tileG As Graphics = Graphics.FromImage(tmp)
'draw inner tiles in selBMP...
'top left...
tileG.DrawImage(flipImg, 0, 0, flipImg.Width, flipImg.Height)
'top right
flipImg.RotateFlip(RotateFlipType.RotateNoneFlipX)
tileG.DrawImage(flipImg, flipImg.Width, 0, flipImg.Width, flipImg.Height)
'bottom right
flipImg.RotateFlip(RotateFlipType.RotateNoneFlipY)
tileG.DrawImage(flipImg, flipImg.Width, flipImg.Height, _
flipImg.Width, flipImg.Height)
'bottom left
flipImg.RotateFlip(RotateFlipType.RotateNoneFlipX)
tileG.DrawImage(flipImg, 0, flipImg.Height, flipImg.Width, flipImg.Height)
'-------------------------------------------------------
'rotate the finished tile 90 deg clockwise
'this is the only flip/rotate that has any meaningful
'effect. Flipping the first inner tile affects only
'what is shown at the left of the bkgnd and doesn't
'affect the rest of the display.
'--------------------------------------------------------
If chk_RotateTile90.Checked Then
tmp.RotateFlip(RotateFlipType.Rotate90FlipNone)
End If
'resize
Dim newW, newH As Integer
newW = (tmp.Width / 100) * sldr_SizeW.Value
newH = (tmp.Height / 100) * sldr_SizeH.Value
selBMP = New Bitmap(tmp, newW, newH)
picbox_TilePreview.Image = selBMP
pntPnl.BackgroundImage = selBMP
Me.Invalidate()
My.Application.DoEvents()
Catch ex As Exception
MsgBox("Error creating tile:" & Chr(10) & ex.ToString, _
MsgBoxStyle.Exclamation, title)
End Try
End If
End Sub
一旦选区矩形和平铺完成，Paint 事件就会由 Me.Invalidate() 触发。请注意，只有矩形会被绘制。由于源图像已被设置为 PictureBox 的背景图像，因此无需重绘它。
Private Sub main_Paint(ByVal sender As Object, ByVal e As _
System.Windows.Forms.PaintEventArgs) Handles Me.Paint
Try
If original IsNot Nothing Then 'if a source image is loaded
'copy of original to display
bmp = New Bitmap(original.Width, original.Height)
g = Graphics.FromImage(bmp)
'draw the selection rectangle and grab-handles
If sr.Width > 0 AndAlso sr.Height > 0 Then
g.FillRectangle(innerBrush, sr)
g.DrawRectangle(myPen, sr)
g.FillRectangles(grabBrush, grabHandles)
g.DrawRectangles(grabPen, grabHandles)
End If
picbox_SrcImage.Image = bmp
g.Dispose()
End If
UpdateUI()
Catch ex As Exception
MsgBox(ex.ToString)
End Try
End Sub
调整平铺大小
左窗格中的滑块允许调整平铺的大小。更改会立即反映在滑块上方的平铺预览和（如果选中了“在选择过程中更新平铺”复选框）其下方的页面预览中。否则，图像将在释放鼠标时更新（对于较大的平铺更好）。涉及的数学是基于百分比而不是平铺的实际尺寸，范围从 10% 到 200%。您会在 CreateTile() 子程序的末尾附近找到代码。单击滑块下方的“1:1”按钮会将两者都重置为 100%。
从 BTC 设置墙纸
此版本包含从程序设置桌面墙纸的功能。以下是它的工作原理
在项目属性中，我添加了一个对 Shell32.dll 的引用。
WinAPI 类执行实际工作
Imports System.Runtime.InteropServices
Public Class WinAPI
<DllImport("user32.dll", CharSet:=CharSet.Auto)> _
Public Shared Function SystemParametersInfo(ByVal uAction As Integer, _
ByVal uParam As Integer, ByVal lpvParam As String, _
ByVal fuWinIni As Integer) As Integer
End Function
Public Const SPI_SETDESKWALLPAPER As Integer = 20
Public Const SPIF_SENDCHANGE As Integer = &H2
Public Const SPIF_UPDATEINIFILE As Integer = &H1&
Public Const SPIF_SENDWININICHANGE As Integer = &H2&
End Class
在 BTC 窗口中，单击工具栏中的“墙纸”按钮，该按钮形似电脑显示器。首先，BTC 会检查以确保平铺已保存为 .bmp 或 .jpg 格式。这是 Windows 可以接受的唯一格式（至少我的版本是这样）。接下来，它会检查平铺是否有未保存的更改。如果有，系统会提示您在继续之前保存。当您更改平铺时，Boolean 变量 isSaved 会设置为 False，当您保存它时设置为 True。一旦完成，就会创建一个 Shell 对象，用于最小化所有打开的窗口（包括 BTC），以便可以看到桌面。最后，BTC 会打开 dialog_Wallpaper 对话框。
这是 Click 事件处理程序
Private Sub tb_SetWP_Click() Handles tb_SetWP.Click
If Not tilePath.EndsWith(".jpg") AndAlso _
Not tilePath.EndsWith(".bmp") Then
msg = "Image must be saved in either .jpg" & Chr(10)
msg &= "or .bmp format. These are the only formats" & Chr(10)
msg &= "Windows recognizes for wallpaper."
MsgBox(msg, MsgBoxStyle.Information, title)
Exit Sub
End If
If Not isSaved Then
msg = "The image has unsaved changes. You must" & Chr(10)
msg &= "first save the image. BE SURE to save it in either .jpg" & Chr(10)
msg &= "or .bmp format. These are the only formats Windows" & Chr(10)
msg &= "recognizes for wallpaper."
MsgBox(msg, MsgBoxStyle.Information, title)
Exit Sub
End If
'hide all open windows before opening wp dialog
Try
Dim sh As New Shell
sh.MinimizeAll()
dialog_WallPaper.ShowDialog()
sh = Nothing
Catch ex As Exception
MsgBox(ex.ToString, MsgBoxStyle.Exclamation, title)
End Try
End Sub
墙纸对话框
这是对话框的完整代码列表。其中包含注释以解释其作用。
Imports System.Windows.Forms
Imports System.Drawing
Imports System.IO
Imports Microsoft.Win32
Public Class dialog_WallPaper
Dim imgPath As String = main.tilePath 'the path to your saved tile
'in the event you change your mind these variables will contain your
'previous wallpaper info
Dim oldPath As String
Dim oldStyle As String
Dim oldTile As String
'the dialog's load event
Private Sub dialog_WallPaper_Load(ByVal sender As Object, _
ByVal e As System.EventArgs) Handles Me.Load
'minimize the main window
main.WindowState = FormWindowState.Minimized
'get your current wallpaper settings from the registry
oldPath = My.Computer.Registry.GetValue(_
"HKEY_CURRENT_USER\Control Panel\Desktop", "WallPaper", Nothing)
oldStyle = My.Computer.Registry.GetValue(_
"HKEY_CURRENT_USER\Control Panel\Desktop", "WallpaperStyle", Nothing)
oldTile = My.Computer.Registry.GetValue(_
"HKEY_CURRENT_USER\Control Panel\Desktop", "TileWallpaper", Nothing)
'set the wallpaper to the new tile
SetWallpaper("1", "1")
End Sub
'"Accept" button - close the dialog and leave the new tile as your WP
Private Sub OK_Button_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles OK_Button.Click
main.WindowState = FormWindowState.Maximized
Me.DialogResult = System.Windows.Forms.DialogResult.OK
Me.Close()
End Sub
'"Decline" button - close the dialog and revert to your original WP
Private Sub Cancel_Button_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles Cancel_Button.Click
'set wp back to previous image and settings before closing
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"WallPaper", oldPath)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"WallpaperStyle", oldStyle)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"TileWallpaper", oldTile)
WinAPI.SystemParametersInfo(WinAPI.SPI_SETDESKWALLPAPER, 0, oldPath, _
WinAPI.SPIF_UPDATEINIFILE Or WinAPI.SPIF_SENDWININICHANGE)
main.WindowState = FormWindowState.Maximized
Me.DialogResult = System.Windows.Forms.DialogResult.Cancel
Me.Close()
End Sub
'sets the wallpaper to the new tile
'writes the 3 necessary values to the registry
Private Sub SetWallpaper(ByVal styleNum As String, ByVal tile As String)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"WallpaperStyle", styleNum)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"TileWallpaper", tile)
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Control Panel\Desktop", _
"WallPaper", main.tilePath)
WinAPI.SystemParametersInfo(WinAPI.SPI_SETDESKWALLPAPER, 0, main.tilePath, _
WinAPI.SPIF_UPDATEINIFILE Or WinAPI.SPIF_SENDWININICHANGE)
End Sub
End Class
帮助文件
我放进去了一个纯粹为最终用户编写的帮助文件，可以从工具栏打开。HTML 包含在 My.Resources.help 中。打开的窗体包含一个 WebBrowser 控件，并且 Load 事件包含设置其 DocumentText 属性为资源的代码。
关注点
如果您想查看用 BTC 创建的平铺示例，请访问此页面。向下滚动到幻灯片放映并单击图像。页面背景将在选择每个平铺时显示。您需要在浏览器中启用 JavaScript。
在编写 BTC 的过程中，我学到的一件事是如何实现选区矩形。用鼠标绘制矩形很容易，但一个功能正常的选区矩形则更复杂一些。BTC 的选区矩形不包括在将选区拖动到显示区域之外时滚动源图像的功能。考虑到平铺通常都很小，我认为这不是必需的，尽管我以后可能会添加它。
在最近的这个版本中，我还学到了一些关于处理注册表和 Shell 的知识。我过去一直避免这两者，所以对我来说这是新的。如果您看到我在这方面应该做得不同的地方，请随时告诉我。
历史
- 首次发布：2011 年 7 月。
- 第二次发布：2011 年 8 月上传。
- 第三次发布：2011 年 8 月 29 日上传。
- 第四次发布（bug 修复）：2011 年 9 月 2 日上传。