Drawing textures

Is there anyway that I can overlay a tileset of a texture I have on a polygonal area drawm earlier in the same code? I want it all done in the background and it should show the texture of my choice on for example everything of RGB(130,90,50).

I would really appreciate any help!
Who is Participating?

[Webinar] Streamline your web hosting managementRegister Today

KhollADConnect With a Mentor Commented:
I hope the code below is what you want :

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function BitBlt Lib "gdi32" _
  (ByVal hDCDest As Long, ByVal XDest As Long, _
   ByVal YDest As Long, ByVal nWidth As Long, _
   ByVal nHeight As Long, ByVal hDCSrc As Long, _
   ByVal XSrc As Long, ByVal YSrc As Long, _
   ByVal dwRop As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" _
  (ByVal nWidth As Long, _
   ByVal nHeight As Long, _
   ByVal nPlanes As Long, _
   ByVal nBitCount As Long, _
   lpBits As Any) As Long

Private Declare Function SetBkColor Lib "gdi32" _
   (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _
   (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
   (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _
   (ByVal hdc As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" _
   (ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
   (ByVal hObject As Long) As Long

Private Sub Form_Load()

Me.ScaleMode = 1

'PicDest - The Result Pic (Put the texture here)
PicDest.Picture = LoadPicture("c:\windows\circles.bmp")
With PicDest
    .Width = PicSource.Width
    .Height = PicSource.Height
    .AutoRedraw = True
    .ScaleMode = 1
End With

'PicSource - Your polygonal pic that contains RGB areas to fill with the texture of PicDest
With PicSource
    .AutoRedraw = True
    .Visible = False
    .ScaleMode = 3
End With

End Sub

Private Sub Command1_Click()

  Dim R As RECT

  With R
   .Left = 0
   .Top = 0
   .Right = PicSource.ScaleWidth
   .Bottom = PicSource.ScaleHeight
  End With

  TileBackground 'tile the texture on PicDest

  TransparentBlt PicDest.hdc, PicDest.hdc, PicSource.hdc, R, 0, 0, RGB(130, 90, 50)
End Sub

Private Sub TileBackground()
        Dim pic As Picture
        Dim x%, y%

        Set pic = PicDest.Picture
        y% = 0
        While y% < PicDest.Height
                x% = 0
                While x% < PicDest.Width
                        PicDest.PaintPicture pic, x%, y%
                        x% = x% + pic.Width \ 2
                y% = y% + pic.Width \ 2
End Sub

Private Sub TransparentBlt(OutDstDC As Long, _
  DstDC As Long, SrcDC As Long, SrcRect As RECT, _
  DstX As Integer, DstY As Integer, TransColor As Long)
  'DstDC- Device context into which image must be
  'drawn transparently

  'OutDstDC- Device context into image is actually drawn,
  'even though it is made transparent in terms of DstDC

  'Src- Device context of source to be made transparent
  'in color TransColor

  'SrcRect- Rectangular region within SrcDC to be made
  'transparent in terms of DstDC, and drawn to OutDstDC

  'DstX, DstY - Coordinates in OutDstDC (and DstDC)
  'where the transparent bitmap must go. In most
  'cases, OutDstDC and DstDC will be the same
  Dim nRet As Long, W As Integer, H As Integer
  Dim MonoMaskDC As Long, hMonoMask As Long
  Dim MonoInvDC As Long, hMonoInv As Long
  Dim ResultDstDC As Long, hResultDst As Long
  Dim ResultSrcDC As Long, hResultSrc As Long
  Dim hPrevMask As Long, hPrevInv As Long
  Dim hPrevSrc As Long, hPrevDst As Long

  W = SrcRect.Right - SrcRect.Left + 1
  H = SrcRect.Bottom - SrcRect.Top + 1
 'create monochrome mask and inverse masks
  MonoMaskDC = CreateCompatibleDC(DstDC)
  MonoInvDC = CreateCompatibleDC(DstDC)
  hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
  hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
  hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
  hPrevInv = SelectObject(MonoInvDC, hMonoInv)
 'create keeper DCs and bitmaps
  ResultDstDC = CreateCompatibleDC(DstDC)
  ResultSrcDC = CreateCompatibleDC(DstDC)
  hResultDst = CreateCompatibleBitmap(DstDC, W, H)
  hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
  hPrevDst = SelectObject(ResultDstDC, hResultDst)
  hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
'copy src to monochrome mask
  Dim OldBC As Long
  OldBC = SetBkColor(SrcDC, TransColor)
  nRet = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, _
                SrcRect.Left, SrcRect.Top, vbSrcCopy)
  TransColor = SetBkColor(SrcDC, OldBC)
 'create inverse of mask
  nRet = BitBlt(MonoInvDC, 0, 0, W, H, _
                MonoMaskDC, 0, 0, vbNotSrcCopy)
 'get background
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
                DstDC, DstX, DstY, vbSrcCopy)
 'AND with Monochrome mask
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
                MonoMaskDC, 0, 0, vbSrcAnd)
 'get overlapper
  nRet = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, _
                SrcRect.Left, SrcRect.Top, vbSrcCopy)
 'AND with inverse monochrome mask
  nRet = BitBlt(ResultSrcDC, 0, 0, W, H, _
                MonoInvDC, 0, 0, vbSrcAnd)
'XOR these two
  nRet = BitBlt(ResultDstDC, 0, 0, W, H, _
                ResultSrcDC, 0, 0, vbSrcInvert)
 'output results
  nRet = BitBlt(OutDstDC, DstX, DstY, W, H, _
                ResultDstDC, 0, 0, vbSrcCopy)
 'clean up
  hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
  DeleteObject hMonoMask

  hMonoInv = SelectObject(MonoInvDC, hPrevInv)
  DeleteObject hMonoInv

  hResultDst = SelectObject(ResultDstDC, hPrevDst)
  DeleteObject hResultDst

  hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
  DeleteObject hResultSrc

  DeleteDC MonoMaskDC
  DeleteDC MonoInvDC
  DeleteDC ResultDstDC
  DeleteDC ResultSrcDC

End Sub
hakanwaagAuthor Commented:
I like the idea behind this code, however, i didn't get it to work, maybe you could give me some information on how to implement it?
hi hakanwaag,

Sorry if I haven't explained it very well.

But I need to give a idea for what is heappen, Ok ?!

Can you explain more about the problem ?

See u later, Kholl.
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.

hakanwaagAuthor Commented:
I'm sorry that I was so unclear with the problem. After I had posted that message, I was experimenting with the code, hopyfully finding an answer, I found that the code did apply the texture on the texture picture object so i simply copied the texture objects content to my other picture.

Well, now that it works i will give you the points. I'll wait with it a little to give you a chance to say anything, more points or anything. But i will defenitely give you an Excellent! rating.
hi hakanwaag,

I was thinking the code get a error or some like that.

You are right. The TileBackground sub, creates a tileset of your texture using the own texture on PicDest.

After, the TransparentBlt sub makes a hole in the PicSource in whole areas that contains the RGB color that you choose and put this masked picture in PicDest.

If the code works fine for you, I'll appreciate your initials points (200)


Any doubts, send a comment here.
hakanwaagAuthor Commented:
I do not have any doubts, really, and I assure you I will give you the points. But I encounterer a minor problem when trying the same code on a larger picture (2000x1500).

If you don't know what's wrong I will give you the points anyway (I cannot say you don't deserve them when it's me who don't understand it)
hakanwaagAuthor Commented:
I thought i'll simply accept your answer now. You probably haven't got time working on my problems.
Hi hakanwaag,

I could just today work with my computer (I was traveling)  
 Firstly thank you for the points.  
 I tested the code with a picture like you mentioned (2000x1500) and works fine.  
 I need to know which sub doesn't work. TileBackground or TransparentBlt or both?  
 Make an individual test for each sub (not forgetting about REFRESH after the test)  
 Send for me the comment about your results.

hakanwaagAuthor Commented:
I am quite surprised to say that it somehow worked this time. I don't know what I've changed but it worked, so i guess everythings alright now.
Nice !! such things happen in the amazing Microsoft universe.

Sometimes these things happen with me !!

Any problems, talk to me.

See u later,

All Courses

From novice to tech pro — start learning today.