Is there a way to tile a form with a picture (with the picture in the picturebox)?
Printable View
Is there a way to tile a form with a picture (with the picture in the picturebox)?
I tried that, the only solution I can see is to use lots of pic boxes the size of the image, with 0 borders, and tile them yourself.... time consuming, probably drains performance.... so I didnt do it :(
Use bitblt in a y loop inside a x loop to draw the tiles over the form, heres the dec:
try itCode:Declare Function BitBlt Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
I tried :)
put this in a module
those are the declares...Code:Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
put this in a module too, it doesnt matter if its the same module:
put this in the declarations section of your form.Code:Public Function TileImage(RefForm As Form, ImageToTile As PictureBox) As Boolean
On Error GoTo error_TileImage
Dim lngBitmapHandle As Long
Dim lngFormHeight As Long
Dim lngFormWidth As Long
Dim lngPictureHeight As Long
Dim lngPictureWidth As Long
Dim lngPrevScale As Long
Dim lngRet As Long
Dim lngSourceDC As Long
Dim lngX As Long
Dim lngY As Long
If Not RefForm Is Nothing And Not ImageToTile Is Nothing Then
With ImageToTile
lngPrevScale = .ScaleMode
.ScaleMode = vbPixels
lngPictureHeight = .ScaleHeight
lngPictureWidth = .ScaleWidth
.ScaleMode = lngPrevScale
End With
With RefForm
lngPrevScale = .ScaleMode
.ScaleMode = vbPixels
lngFormHeight = .ScaleHeight
lngFormWidth = .ScaleHeight
.ScaleMode = lngPrevScale
End With
lngSourceDC = CreateCompatibleDC(RefForm.hdc)
lngBitmapHandle = SelectObject(lngSourceDC, ImageToTile.Picture.Handle)
For lngX = 0 To lngFormWidth Step lngPictureWidth
For lngY = 0 To lngFormHeight Step lngPictureHeight
lngRet = BitBlt(RefForm.hdc, lngX, lngY, lngPictureWidth, lngPictureHeight, lngSourceDC, 0, 0, SRCCOPY)
Next lngY
Next lngX
lngRet = SelectObject(lngSourceDC, lngBitmapHandle)
lngRet = DeleteDC(lngSourceDC)
TileImage = True
Else
TileImage = False
End If
Exit Function
error_TileImage:
If Not RefForm Is Nothing Then
RefForm.Tag = Err.Number & " " & Err.Description
End If
TileImage = False
End Function
and in the form load put thisCode:Sub SetTile()
On Error GoTo error_SetTile
Dim blnRet As Boolean
blnRet = TileImage(Me, picTile)
Screen.MousePointer = vbDefault
Exit Sub
error_SetTile:
Screen.MousePointer = vbDefault
End Sub
add a picturebox called picTile, set autosize to true, and have no borders, and set it out of site.Code:SetTile
viola
it works good.. but it doesnt redraw itself when you resize, I tried setting autoredraw to true... no luck
I tried putting
in the forms resize, but still no luck, if you maximize it, about 1/3 of the it is blank...Code:SetTile
Well I found something. For all you people that want to know how to do this also, here you are:
Thanks for the help anyway.Code:Sub PictureTile(Frm As Form, Pic As PictureBox)
Dim i As Integer
Dim t As Integer
Frm.AutoRedraw = True
Pic.BorderStyle = 0
For t = 0 To Frm.Height Step Pic.ScaleHeight
For i = 0 To Frm.Width Step Pic.ScaleWidth
Frm.PaintPicture Pic.Picture, i, t
Next i
Next t
End Sub
usage:
'put this in Form_Activate, Form_Paint, or Form_Resize
PictureTile Me, Picture1
if your looking for performance and speed, than you better use mine, API is a hell of alot faster, when it deals with images... Vb and API encryption can be the same, I have seen some cases where Vb was faster, it really depends on what kind of encryption....
but, I would like to find someone to prove me wrong:
Graphics handling is MUCH MUCH faster, literaly by centiseconds(its alot if you are building a game) in API, than VB.....
if you build a counter using queryperformancecounter or whatever the call is, and test out the time, you will find API to be much better...
just my $0.02
Paintpicture is faster in stretching images than stretchblt. bitblt is faster than painpicture in copying images. Also Dennis, you don't need to create your own DC's, and you only need to declare two variables. ;)
just my mk0.02
Check out the sample
http://home.clara.net/doczaf/code/vbsample3.htm
The routine will work for any object which supports a paint event
DocZaf
That's cool, the code is easier to understand to.
Only thing I can't stand.
My name is spelled the traditional way, with two Ts!!
Heh, sorry, it just pisses me off when people only put 1 t, lol.
sorry maTThew,
I tried to skimp on the keystrokes and now its cost me!!!
{;->
Dennis- great code example. (I changed frm to object so I could tile in pictureboxes too :) Also, the bug where it doesn't tile the entire thing is in the RefForm object. You have scale height for both form width and height.
However I have one problem... its a little slow. My app requires something a little bit quicker/optimized to redraw the entire area, since my app requires that I do it A LOT.
Also, where do I get the DC's since kedaman said "you don't need to create your own DC's." I'll repaste the code so you don't have to scroll up :)
Any ideas that you have that would make this code faster would help me out a lot!!!Code:Public Function TileImage(RefForm As Form, ImageToTile As PictureBox) As Boolean
On Error GoTo error_TileImage
Dim lngBitmapHandle As Long
Dim lngFormHeight As Long
Dim lngFormWidth As Long
Dim lngPictureHeight As Long
Dim lngPictureWidth As Long
Dim lngPrevScale As Long
Dim lngRet As Long
Dim lngSourceDC As Long
Dim lngX As Long
Dim lngY As Long
If Not RefForm Is Nothing And Not ImageToTile Is Nothing Then
With ImageToTile
lngPrevScale = .ScaleMode
.ScaleMode = vbPixels
lngPictureHeight = .ScaleHeight
lngPictureWidth = .ScaleWidth
.ScaleMode = lngPrevScale
End With
With RefForm
lngPrevScale = .ScaleMode
.ScaleMode = vbPixels
lngFormHeight = .ScaleHeight
lngFormWidth = .ScaleHeight
.ScaleMode = lngPrevScale
End With
lngSourceDC = CreateCompatibleDC(RefForm.hdc)
lngBitmapHandle = SelectObject(lngSourceDC, ImageToTile.Picture.Handle)
For lngX = 0 To lngFormWidth Step lngPictureWidth
For lngY = 0 To lngFormHeight Step lngPictureHeight
lngRet = BitBlt(RefForm.hdc, lngX, lngY, lngPictureWidth, lngPictureHeight, lngSourceDC, 0, 0, SRCCOPY)
Next lngY
Next lngX
lngRet = SelectObject(lngSourceDC, lngBitmapHandle)
lngRet = DeleteDC(lngSourceDC)
TileImage = True
Else
TileImage = False
End If
Exit Function
error_TileImage:
If Not RefForm Is Nothing Then
RefForm.Tag = Err.Number & " " & Err.Description
End If
TileImage = False
End Function
'will an image box do
Code:Private Sub Form_Paint()
'tile an image on a form
'1) Place an image control on a form and give it a picture
'2) Set the forms AutoRedraw to False
'3) Place this code in the Form Paint Event
Dim intX As Integer
Dim intY As Integer
For intX = 0 To Me.Width Step Image1.Width
For intY = 0 To Me.Height Step Image1.Height
PaintPicture Image1, intX, intY
Next intY
Next intX
End Sub
I must disagree with you on this, Kedaman. StretchBlt is about 5 times faster than PaintPicture. The reason being is that you are accessing the API call directly from theQuote:
Originally posted by kedaman
Paintpicture is faster in stretching images than stretchblt.
library. In Visual Basic, when you draw a Line, you are, in reality, using the LineTo API Function. When you draw a
Rectangle, you are using the Rectangle API function. When you stretch a picture using PaintPicture, you are using the
StretchBlt API function. You get the picture, right? Anyhow, PaintPicture, is slower because it's already
integrated in the Visual Basic langauge, hence you would have to go through Visual Basic then the DLL and back to
accomplish the task, whereas when you use StretchBlt, you are accessing it directly through the library.
This was posted a while ago, you don't need to post anymore about it.
Posted: 05-27-2000 08:57 AM
..unless you want to make a new topic about tiling an image, it's fine with me :D.
Megatron, Save this as a form, and run it. press painpicture button and stretchblt button and tell me what you get
Code:VERSION 5.00
Begin VB.Form FrmMain
Caption = "Testengine"
ClientHeight = 7290
ClientLeft = 60
ClientTop = 345
ClientWidth = 5445
LinkTopic = "Form1"
ScaleHeight = 486
ScaleMode = 3 'Pixel
ScaleWidth = 363
StartUpPosition = 3 'Windows Default
Begin VB.Frame Frame1
Caption = "Color"
Height = 1215
Left = 120
TabIndex = 1
Top = 2160
Width = 3615
Begin VB.TextBox Text2
Height = 285
Left = 3000
TabIndex = 8
Text = "600"
Top = 720
Width = 495
End
Begin VB.TextBox Text1
Height = 285
Left = 2400
TabIndex = 7
Text = "800"
Top = 720
Width = 495
End
Begin VB.CommandButton Command5
Caption = "Paintpicture"
Height = 375
Left = 2400
TabIndex = 6
Top = 240
Width = 1095
End
Begin VB.CommandButton Command4
Caption = "Bitblt"
Height = 375
Left = 1200
TabIndex = 5
Top = 720
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "StretchBlt"
Height = 375
Left = 1200
TabIndex = 4
Top = 240
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "Pset"
Height = 375
Left = 120
TabIndex = 3
Top = 240
Width = 975
End
Begin VB.CommandButton Command2
Caption = "Setpixelv"
Height = 375
Left = 120
TabIndex = 2
Top = 720
Width = 975
End
End
Begin VB.PictureBox Picture1
BorderStyle = 0 'None
Height = 1500
Left = 2880
ScaleHeight = 1500
ScaleWidth = 1500
TabIndex = 0
Top = 360
Width = 1500
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Sub Command1_Click()
t = GetTickCount
For n = 0 To 10000
Picture1.PSet (Rnd * Picture1.ScaleWidth, Rnd * Picture1.ScaleHeight), Rnd * &H1000000
Next n
MsgBox (GetTickCount - t) / 10 & "µs"
End Sub
Private Sub Command2_Click()
t = GetTickCount
For n = 0 To 10000
SetPixelV Picture1.hdc, Rnd * Picture1.ScaleWidth / 15, Rnd * Picture1.ScaleHeight / 15, Rnd * &H1000000
Next n
Picture1.Refresh
MsgBox (GetTickCount - t) / 10 & "µs"
Picture1.Picture = Picture1.Image
End Sub
Private Sub Command3_Click()
t = GetTickCount
For n = 0 To 1000
StretchBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth / 15, Picture1.ScaleHeight / 15, Picture1.hdc, Picture1.ScaleWidth / 15, Picture1.ScaleHeight / 15, -Picture1.ScaleWidth / 15, -Picture1.ScaleHeight / 15, vbSrcCopy
Next n
Picture1.Refresh
MsgBox (GetTickCount - t) * Val(Text1) * Val(Text2) / 10000000 & "ms for " & Text1 & " * " & Text2
End Sub
Private Sub Command4_Click()
t = GetTickCount
For n = 0 To 10000
BitBlt Picture1.hdc, 0, 0, Picture1.ScaleWidth / 15, Picture1.ScaleHeight / 15, Picture1.hdc, 0, 0, vbSrcCopy
Next n
Picture1.Refresh
MsgBox (GetTickCount - t) * Val(Text1) * Val(Text2) / 100000000 & "ms for " & Text1 & " * " & Text2
End Sub
Private Sub Command5_Click()
Picture1.Picture = Picture1.Image
t = GetTickCount
For n = 0 To 1000
Picture1.PaintPicture Picture1.Picture, 0, 0, Picture1.ScaleWidth / 15, Picture1.ScaleHeight / 15, Picture1.ScaleWidth / 15, Picture1.ScaleHeight / 15, -Picture1.ScaleWidth / 15, -Picture1.ScaleHeight / 15, vbSrcCopy
Next n
Picture1.Refresh
MsgBox (GetTickCount - t) * Val(Text1) * Val(Text2) / 10000000 & "ms for " & Text1 & " * " & Text2
End Sub
Picture1.PSet (Rnd * Picture1.ScaleWidth, Rnd * Picture1.ScaleHeight), Rnd * & H100 0000
error...expected expression [&] H100 0000
Not my fault, HSJ, it just put the " " in there like it put's a smiley instead of &)
Yup, that is a bug. Anything...
with a 1 and a 0 will space in between somewhere. But it's something we all can live with, right? :pCode:1000000
1010101
1000100
1111000
1110000
And..it also spaces the code. [code ]
hmm, i mean hmm, once in a while i loose some of my time on problems like this, but on the other hand i loose time on this site more than loosing sleep for the last month
Code:Sub Object_Paint(objSource as Object,objTarget as Object)
'This routine tiles an image (objSource) all over the target object (objTarget)
'objTarget could be Form1
'objSource could be Picture1
Dim X as Integer
'Set vertical loop
For Y = 0 To objTarget.Height Step picSource.Height
'Set horizontal loop
For X = 0 To objTarget.Width Step picSource.Width
'Draw the image at location x,y
objTarget.PaintPicture picSource, X, Y
'Draw next horizontal image until row is drawn
Next X
'Draw next vertical image until all columns drawn
Next Y
End Sub
[Edited by Zaf Khan on 08-05-2000 at 07:43 PM]
Kedaman, I have done tests on this before and StretchBlt was proven to be 5 times faster.
It took StretchBlt 4.9ms average to draw a picture; and it took PaintPicture 21.9ms
average to draw the same picture.
Zaf Khan
Code:Dim X as Integer
'Set vertical loop
For Y = 0 To objTarget.Height Step picSource.Height
'Set horizontal loop
For X = 0 To objTarget.Width Step picSource.Width
'Draw the image at location x,y
objTarget.PaintPicture picSource, X, Y
'Draw next horizontal image until row is drawn
Next X
'Draw next vertical image until all columns drawn
Next Y
'<<<<<<<<<<<<<<<<<<<<<<<< >>>>>>>>>>>>>>>>>>>>>>>>>>>>>
HeSaidJoe
Dim intX As Integer
Dim intY As Integer
For intX = 0 To Me.Width Step Image1.Width
For intY = 0 To Me.Height Step Image1.Height
PaintPicture Image1, intX, intY
Next intY
Next intX
If there's enough demand, I might put a VB/API comparison benchmark together...anyone want one? Ya know, just for comparing times on different computers.
MEg, it could be hardware, for instance bitblt runs more than ten times slower on my laptop. Did you run the test? What results?
HeSaidJoe
Quote:
Code:Sub Object_Paint(objSource as Object,objTarget as Object)
'This routine tiles an image (objSource) all over the target object (objTarget)
'objTarget could be Form1
'objSource could be Picture1
Dim X as Integer
'Set vertical loop
For Y = 0 To objTarget.Height Step picSource.Height
'Set horizontal loop
For X = 0 To objTarget.Width Step picSource.Width
'Draw the image at location x,y
objTarget.PaintPicture picSource, X, Y
'Draw next horizontal image until row is drawn
Next X
'Draw next vertical image until all columns drawn
Next Y
End Sub
When using the PAINTPICTURE method, if the keyword is not pre-fixed with an object name - an object that must support the paintpicture method) then the method is implied towards the form that contains the code (MDI Form? ...I can't remember), if the code is in a module and not in a form, AND the code is not pre-fixed with an object name of an object that supports the method then an error occurs.
When pre-fixing the keyword with an object name that does support the paint picture method (Form's, Picturebox's and CUSTOM controls, then the object background can be tiled.
And finally, not everyone is over the moon with naming conventions
DocZaf
{;->
You specified your own results as 1:5, can you write down the exact figures? I need to know if this is caused by hardware or what, also turn of autoredraw and write down following results too