home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Applying_t887585312002.psc / fScreen.frm (.txt) next >
Encoding:
Visual Basic Form  |  2002-05-31  |  7.3 KB  |  229 lines
  1. VERSION 5.00
  2. Begin VB.Form fScreen 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Texturize project"
  5.    ClientHeight    =   6315
  6.    ClientLeft      =   45
  7.    ClientTop       =   330
  8.    ClientWidth     =   7860
  9.    ClipControls    =   0   'False
  10.    BeginProperty Font 
  11.       Name            =   "Verdana"
  12.       Size            =   6.75
  13.       Charset         =   0
  14.       Weight          =   400
  15.       Underline       =   0   'False
  16.       Italic          =   0   'False
  17.       Strikethrough   =   0   'False
  18.    EndProperty
  19.    LinkTopic       =   "Form1"
  20.    LockControls    =   -1  'True
  21.    MaxButton       =   0   'False
  22.    ScaleHeight     =   421
  23.    ScaleMode       =   3  'Pixel
  24.    ScaleWidth      =   524
  25.    StartUpPosition =   2  'CenterScreen
  26.    Begin VB.CommandButton cmdTexturize 
  27.       Caption         =   "&Texturize"
  28.       Height          =   375
  29.       Left            =   5385
  30.       TabIndex        =   5
  31.       Top             =   5355
  32.       Width           =   1950
  33.    End
  34.    Begin VB.HScrollBar sbWeight 
  35.       Height          =   195
  36.       LargeChange     =   5
  37.       Left            =   5445
  38.       Max             =   100
  39.       TabIndex        =   2
  40.       Top             =   4065
  41.       Value           =   50
  42.       Width           =   1830
  43.    End
  44.    Begin VB.OptionButton optDepth 
  45.       Caption         =   "Em&boss"
  46.       Height          =   210
  47.       Index           =   0
  48.       Left            =   6435
  49.       TabIndex        =   3
  50.       Top             =   4650
  51.       Value           =   -1  'True
  52.       Width           =   930
  53.    End
  54.    Begin VB.OptionButton optDepth 
  55.       Caption         =   "En&grave"
  56.       Height          =   210
  57.       Index           =   1
  58.       Left            =   6435
  59.       TabIndex        =   4
  60.       Top             =   4890
  61.       Width           =   930
  62.    End
  63.    Begin VB.PictureBox iBack 
  64.       BackColor       =   &H8000000C&
  65.       ClipControls    =   0   'False
  66.       Height          =   2685
  67.       Left            =   5018
  68.       ScaleHeight     =   175
  69.       ScaleMode       =   3  'Pixel
  70.       ScaleWidth      =   175
  71.       TabIndex        =   1
  72.       TabStop         =   0   'False
  73.       Top             =   1050
  74.       Width           =   2685
  75.       Begin VB.Image iTexture 
  76.          Height          =   2625
  77.          Left            =   0
  78.          Top             =   0
  79.          Width           =   2625
  80.       End
  81.    End
  82.    Begin VB.FileListBox flTextures 
  83.       Height          =   810
  84.       Left            =   5010
  85.       Pattern         =   "*.bmp"
  86.       TabIndex        =   0
  87.       Top             =   135
  88.       Width           =   2700
  89.    End
  90.    Begin VB.PictureBox iScr 
  91.       Appearance      =   0  'Flat
  92.       BackColor       =   &H8000000C&
  93.       ClipControls    =   0   'False
  94.       DrawMode        =   6  'Mask Pen Not
  95.       ForeColor       =   &H80000008&
  96.       Height          =   2310
  97.       Left            =   150
  98.       ScaleHeight     =   152
  99.       ScaleMode       =   3  'Pixel
  100.       ScaleWidth      =   134
  101.       TabIndex        =   7
  102.       TabStop         =   0   'False
  103.       Top             =   150
  104.       Width           =   2040
  105.    End
  106.    Begin VB.CommandButton cmdReset 
  107.       Caption         =   "&Reset"
  108.       Height          =   375
  109.       Left            =   5385
  110.       TabIndex        =   6
  111.       Top             =   5805
  112.       Width           =   1950
  113.    End
  114.    Begin VB.Label lblWeight 
  115.       Caption         =   "Texture weight"
  116.       Height          =   210
  117.       Left            =   5805
  118.       TabIndex        =   10
  119.       Top             =   3825
  120.       Width           =   1110
  121.    End
  122.    Begin VB.Label lblWeightV 
  123.       Alignment       =   2  'Center
  124.       Caption         =   "50%"
  125.       Height          =   195
  126.       Left            =   6120
  127.       TabIndex        =   9
  128.       Top             =   4320
  129.       Width           =   495
  130.    End
  131.    Begin VB.Label Label1 
  132.       Caption         =   "Depth mode"
  133.       Height          =   240
  134.       Left            =   5385
  135.       TabIndex        =   8
  136.       Top             =   4650
  137.       Width           =   1140
  138.    End
  139.    Begin VB.Image iIm 
  140.       Height          =   1275
  141.       Left            =   150
  142.       Top             =   2550
  143.       Visible         =   0   'False
  144.       Width           =   1365
  145.    End
  146. Attribute VB_Name = "fScreen"
  147. Attribute VB_GlobalNameSpace = False
  148. Attribute VB_Creatable = False
  149. Attribute VB_PredeclaredId = True
  150. Attribute VB_Exposed = False
  151. '// Texture project
  152. '// Carles P.V. - 2002
  153. Option Explicit
  154. Private iBM As BITMAPINFO 'Image bits
  155. Private tBM As BITMAPINFO 'Texture bits
  156. Private Sub Form_Load()
  157.     If (App.LogMode <> 1) Then
  158.         MsgBox "Compile me: I'll process faster.", vbExclamation
  159.         Unload Me
  160.     End If
  161.     '// Get first image from textures list
  162.     With flTextures
  163.         .Path = App.Path
  164.         If (.ListCount) Then
  165.             .ListIndex = 0
  166.         End If
  167.     End With
  168.     '// Load image
  169.     iIm = LoadPicture(App.Path & "\Sample.jpg")
  170.     iScr.Move 10, 10, iIm.Width + 2, iIm.Height + 2
  171.     '// Create Bitmap
  172.     CreateBitmap iBM, iIm.Width, iIm.Height
  173.     '// Get Bits
  174.     iBM.Bits = TakeBitsFromPicture(iIm, iIm.Width, iIm.Height)
  175. End Sub
  176. Private Sub iScr_Paint()
  177.     PaintBits iBM, iScr.hdc
  178. End Sub
  179. Private Sub cmdReset_Click()
  180.     iBM.Bits = TakeBitsFromPicture(iIm, iIm.Width, iIm.Height)
  181.     iScr_Paint
  182. End Sub
  183. Private Sub flTextures_Click()
  184.     With iTexture
  185.         .Picture = LoadPicture(flTextures.Path & "\" & flTextures.FileName)
  186.         .Move 0.5 * (175 - .Width), 0.5 * (175 - .Height)
  187.     End With
  188. End Sub
  189. Private Sub sbWeight_Change()
  190.     lblWeightV = sbWeight & "%"
  191. End Sub
  192. Private Sub sbWeight_Scroll()
  193.     sbWeight_Change
  194. End Sub
  195. ' Texturize filter is based on emboss/engrave filter:
  196. ' The emboss/engrave gets a new "3D bump field bitmap" from increment/decrement of
  197. ' RGB values of two adjacent pixels.
  198. ' The emboss filter is got subtracting R/G/B value of adjacent pixel to main pixel.
  199. ' The engrave one, subtracting R/G/B value of main pixel to adjacent pixel.
  200. ' The current emboss/engrave filters are based on NW direction: varying the relative
  201. ' position of adjacent pixel, we can get 8 possible bump directions for each filter.
  202. ' A weight parameter lets modify filter intensity (inc./decr. factor)
  203. ' And a last operation normalizes R/G/B values to median grey value + 128. Texturize filter
  204. ' works from these last values, applying a "shift" coeficient to each pixel:
  205. ' 0/128=0.0 to 255/128=2.0 (128/128=1.0 med. luminosity)
  206. ' Sorry for my English.
  207. Private Sub cmdTexturize_Click()
  208.    'Create texture bitmap
  209.     CreateBitmap tBM, iTexture.Width, iTexture.Height
  210.    'Get texture bits
  211.     tBM.Bits = TakeBitsFromPicture(iTexture, iTexture.Width, iTexture.Height)
  212.    'Generate depth (gradient) field (emboss/engrave)
  213.     If (optDepth(0)) Then
  214.         Emboss tBM.Bits, sbWeight
  215.     Else
  216.         Engrave tBM.Bits, sbWeight
  217.     End If
  218.    'Apply on source image
  219.     Texturize iBM.Bits, tBM.Bits
  220.    'Refresh
  221.     iScr_Paint
  222. End Sub
  223. Private Sub Form_Unload(Cancel As Integer)
  224.     Erase iBM.Bits
  225.     Erase tBM.Bits
  226.     Set fScreen = Nothing
  227.     End
  228. End Sub
  229.