home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / RTBackgrou215145542009.psc / frmRTB.frm < prev    next >
Text File  |  2009-05-04  |  5KB  |  115 lines
  1. VERSION 5.00
  2. Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
  3. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  4. Begin VB.Form frmRTB 
  5.    Caption         =   "Rich Text Box with Background"
  6.    ClientHeight    =   2925
  7.    ClientLeft      =   120
  8.    ClientTop       =   450
  9.    ClientWidth     =   7725
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   2925
  12.    ScaleWidth      =   7725
  13.    StartUpPosition =   3  'Windows Default
  14.    Begin MSComDlg.CommonDialog cdlBrowse 
  15.       Left            =   0
  16.       Top             =   0
  17.       _ExtentX        =   847
  18.       _ExtentY        =   847
  19.       _Version        =   393216
  20.    End
  21.    Begin VB.PictureBox pctRTB 
  22.       AutoRedraw      =   -1  'True
  23.       BorderStyle     =   0  'None
  24.       Height          =   1635
  25.       Left            =   60
  26.       ScaleHeight     =   1635
  27.       ScaleWidth      =   5355
  28.       TabIndex        =   1
  29.       TabStop         =   0   'False
  30.       Top             =   60
  31.       Width           =   5355
  32.       Begin RichTextLib.RichTextBox rtbTrans 
  33.          Height          =   1575
  34.          Left            =   0
  35.          TabIndex        =   0
  36.          Top             =   0
  37.          Width           =   5295
  38.          _ExtentX        =   9340
  39.          _ExtentY        =   2778
  40.          _Version        =   393217
  41.          ScrollBars      =   2
  42.          TextRTF         =   $"frmRTB.frx":0000
  43.       End
  44.    End
  45. End
  46. Attribute VB_Name = "frmRTB"
  47. Attribute VB_GlobalNameSpace = False
  48. Attribute VB_Creatable = False
  49. Attribute VB_PredeclaredId = True
  50. Attribute VB_Exposed = False
  51. Option Explicit
  52. Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  53. Private sBGImg As String
  54.  
  55. Private Sub Form_Load()
  56.   'A bit of test poetry
  57.   rtbTrans.TextRTF = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fnil\fprq1\fcharset0 Arial;}{\f1\fnil\fprq1\fcharset0 Times New Roman;}{\f2\fnil\fcharset0 Calibri;}}" & vbNewLine & _
  58.   "{\colortbl ;\red255\green0\blue0;\red0\green176\blue80;\red0\green77\blue187;\red255\green255\blue0;\red155\green0\blue211;\red255\green192\blue0;}" & vbNewLine & "{\*\generator Msftedit 5.41.21.2509;}\viewkind4\uc1\pard\sa200\sl276\slmult1\cf1\highlight0\lang9\b\f0\fs32 'Twas brillig and the slithy toves\par" & vbNewLine & "\cf2\b0\i Did gyre and gimble in the wabe\par" & vbNewLine & "\cf3\ul\i0 All Mimsy were the borogroves\par" & vbNewLine & "\cf4\ulnone\strike And the mome raths outgrabe\cf0\strike0\par" & vbNewLine & "\par" & vbNewLine & "\cf5\f1\fs44 ""Beware the Jabberwock my son!\par" & vbNewLine & "\cf6 The jaws that bite, the claws that catch!\par" & vbNewLine & "\cf2\b Beware the Jub-Jub bird, and shun\par" & vbNewLine & "\cf1\b0\i The frumious bandersnatch!""\cf0\highlight0\i0\f2\fs22\par" & vbNewLine & "}" & vbNewLine
  59.   'Set the default background image
  60.   sBGImg = App.Path & "\Test.jpg"
  61.   'Call the resize and draw code
  62.   Form_Resize
  63. End Sub
  64.  
  65. Private Sub Form_Resize()
  66.   'Just setting the text box and its container picturebox to the size of the window
  67.   pctRTB.Move Me.ScaleLeft, Me.ScaleTop, Me.ScaleWidth, Me.ScaleHeight
  68.   rtbTrans.Move pctRTB.ScaleLeft, pctRTB.ScaleTop, pctRTB.ScaleWidth, pctRTB.ScaleHeight
  69.   'Call the drawing code
  70.   DrawBackground
  71. End Sub
  72.  
  73. Private Sub rtbTrans_DblClick()
  74.   'Change the background image
  75.   cdlBrowse.Filter = "Image Files|*.bmp;*.jpg;*.gif"
  76.   cdlBrowse.Flags = cdlOFNHideReadOnly
  77.   cdlBrowse.ShowOpen
  78.   If LenB(cdlBrowse.FileName) & LenB(cdlBrowse.FileTitle) Then
  79.     'Set the image
  80.     sBGImg = cdlBrowse.FileName
  81.     'Call the drawing code
  82.     DrawBackground
  83.   Else
  84.     'Disable the image
  85.     sBGImg = vbNullString
  86.     'Call the drawing code
  87.     DrawBackground
  88.   End If
  89. End Sub
  90.  
  91. Private Sub DrawBackground()
  92. Dim iBG     As IPictureDisp
  93.   'Clear the image
  94.   pctRTB.Cls
  95.   If LenB(sBGImg) > 0 And LenB(Dir$(sBGImg, vbNormal Or vbHidden Or vbSystem Or vbReadOnly)) > 0 Then
  96.     'Make the rich text box background transparent
  97.     SetTransparentRTB rtbTrans.hWnd, True
  98.     'Load the picture into an IPictureDisp for easy painting
  99.     Set iBG = LoadPicture(sBGImg)
  100.     'Paint it centered
  101.     pctRTB.PaintPicture iBG, (pctRTB.ScaleWidth - pctRTB.ScaleX(iBG.Width, vbHimetric)) / 2, (pctRTB.ScaleHeight - pctRTB.ScaleY(iBG.Height, vbHimetric)) / 2
  102.   Else
  103.     'Disable the image
  104.     SetTransparentRTB rtbTrans.hWnd, False
  105.   End If
  106. End Sub
  107.  
  108. Private Sub SetTransparentRTB(ByVal hWnd As Long, ByVal Enable As Boolean)
  109.   If Enable Then
  110.     SetWindowLongA hWnd, (-20), &H20&
  111.   Else
  112.     SetWindowLongA hWnd, (-20), &H0&
  113.   End If
  114. End Sub
  115.