vbAccelerator - Contents of code file: frmTexturise.frm

VERSION 5.00
Begin VB.Form frmTexturise 
   Caption         =   "Texturising Demo"
   ClientHeight    =   5970
   ClientLeft      =   2325
   ClientTop       =   1980
   ClientWidth     =   7845
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTexturise.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   5970
   ScaleWidth      =   7845
   Begin VB.TextBox txtSaturation 
      Height          =   315
      Left            =   60
      TabIndex        =   13
      Text            =   "100"
      Top             =   4440
      Width           =   1500
   End
   Begin VB.PictureBox picStatus 
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      ScaleHeight     =   255
      ScaleWidth      =   7785
      TabIndex        =   3
      Top             =   5655
      Width           =   7845
   End
   Begin pTexturiseDIB.cSlider sldTexture 
      Height          =   435
      Left            =   0
      TabIndex        =   11
      Top             =   3720
      Width           =   1635
      _ExtentX        =   2884
      _ExtentY        =   767
      Min             =   0
      Max             =   255
   End
   Begin VB.CommandButton cmdGo 
      Caption         =   "&Go!"
      Height          =   315
      Left            =   60
      TabIndex        =   10
      Top             =   5340
      Width           =   915
   End
   Begin VB.TextBox txtMidValue 
      Height          =   315
      Left            =   60
      TabIndex        =   8
      Text            =   "64"
      Top             =   3360
      Width           =   1500
   End
   Begin VB.TextBox txtIntensity 
      Height          =   315
      Left            =   60
      TabIndex        =   6
      Text            =   "100"
      Top             =   2340
      Width           =   1500
   End
   Begin VB.PictureBox picTexture 
      Height          =   1335
      Left            =   60
      ScaleHeight     =   1275
      ScaleWidth      =   1440
      TabIndex        =   4
      Top             =   720
      Width           =   1500
   End
   Begin VB.ComboBox cboTexture 
      Height          =   315
      Left            =   60
      Sorted          =   -1  'True
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   300
      Width           =   1500
   End
   Begin VB.PictureBox picImage 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   5295
      Left            =   1620
      ScaleHeight     =   5235
      ScaleWidth      =   5775
      TabIndex        =   0
      Top             =   60
      Width           =   5835
   End
   Begin pTexturiseDIB.cSlider sldIntensity 
      Height          =   285
      Left            =   0
      TabIndex        =   12
      Top             =   2700
      Width           =   1635
      _ExtentX        =   2884
      _ExtentY        =   503
      Min             =   0
      Max             =   1000
      Value           =   0
   End
   Begin pTexturiseDIB.cSlider sldSaturation 
      Height          =   300
      Left            =   0
      TabIndex        =   14
      Top             =   4800
      Width           =   1635
      _ExtentX        =   2884
      _ExtentY        =   529
      Min             =   0
      Max             =   500
      Value           =   0
   End
   Begin VB.Label lblSaturation 
      Caption         =   "&Saturation (%)"
      Height          =   195
      Left            =   60
      TabIndex        =   15
      Top             =   4200
      Width           =   1500
   End
   Begin VB.Label lblChosenColour 
      BackColor       =   &H00404040&
      BorderStyle     =   1  'Fixed Single
      Height          =   195
      Left            =   840
      TabIndex        =   9
      Top             =   3120
      Width           =   735
   End
   Begin VB.Label lblMidValue 
      Caption         =   "&Mid Value:"
      Height          =   195
      Left            =   60
      TabIndex        =   7
      Top             =   3120
      Width           =   1500
   End
   Begin VB.Label lblIntensity 
      Caption         =   "&Intensity (%):"
      Height          =   195
      Left            =   60
      TabIndex        =   5
      Top             =   2100
      Width           =   1500
   End
   Begin VB.Label lblTexture 
      Caption         =   "&Texture:"
      Height          =   195
      Left            =   60
      TabIndex        =   2
      Top             =   60
      Width           =   2175
   End
End
Attribute VB_Name = "frmTexturise"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_FRAMECHANGED = &H20         '  The frame changed: send
 WM_NCCALCSIZE
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_STATICEDGE = &H20000
Private Const WS_EX_CLIENTEDGE = &H200

Private m_cDibOrig As cDIBSection
Private m_cDibWork As cDIBSection
Private WithEvents m_cTexturise As cTexturise
Attribute m_cTexturise.VB_VarHelpID = -1
Private m_sDir As String
Private m_bOrig As Boolean

Private Sub cboTexture_Click()
Dim lIntensity As Long
Dim lMidValue As Long
Dim lSaturation As Long

   If (cboTexture.ListIndex <= 0) Then
      picTexture.Cls
      m_bOrig = True
   Else
      m_bOrig = True
      If m_cTexturise.LoadTexture(m_sDir & "\" & cboTexture.Text & ".bmp") Then
         ' Show texture:
         picTexture.Refresh
         ' do processing:
         lIntensity = CLng(txtIntensity)
         lMidValue = CLng(txtMidValue)
         lSaturation = CLng(txtSaturation)
         m_cTexturise.ApplyTexture m_cDibOrig, m_cDibWork, lIntensity,
          lMidValue, lSaturation
         m_bOrig = False
      Else
         picTexture.Refresh
      End If
   End If
   picImage.Refresh

End Sub

Private Sub cmdGo_Click()
   cboTexture_Click
End Sub

Private Sub Form_Load()
Dim sDir As String
Dim iPos As Long
Dim lStyle As Long

   lStyle = GetWindowLong(picStatus.hwnd, GWL_EXSTYLE)
   lStyle = lStyle And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
   SetWindowLong picStatus.hwnd, GWL_EXSTYLE, lStyle
   SetWindowPos picStatus.hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or
    SWP_NOZORDER Or SWP_NOOWNERZORDER Or SWP_FRAMECHANGED

   Me.Show
   Me.Refresh
   
   sldIntensity.Value = 100
   sldTexture.Value = 64
   sldSaturation.Value = 100
   
   Set m_cTexturise = New cTexturise
   
   Set m_cDibOrig = New cDIBSection
   m_cDibOrig.CreateFromPicture LoadPicture(App.Path & "/home/VB/Code/vbMedia/Image_Processing/Texturising_Demonstration/demo.gif")
   Set m_cDibWork = New cDIBSection
   m_cDibWork.Create m_cDibOrig.Width, m_cDibOrig.Height
   m_cDibOrig.PaintPicture m_cDibWork.hDC
   
   cboTexture.AddItem "(None)"
   m_sDir = App.Path
   If Right$(m_sDir, 1) <> "\" Then m_sDir = m_sDir & "\"
   m_sDir = m_sDir & "Effects"
   sDir = Dir(m_sDir & "\*.bmp")
   If (sDir = "") Then
      MsgBox "The folder " & m_sDir & " could not be found - no textures will
       be available.", vbInformation
   Else
      Do While sDir <> ""
         iPos = InStr(UCase$(sDir), ".BMP")
         cboTexture.AddItem left$(sDir, iPos - 1)
         sDir = Dir
      Loop
   End If
   cboTexture.ListIndex = 0
      
End Sub


Private Sub Form_Resize()
On Error Resume Next
   picImage.Move picImage.left, picImage.Top, Me.ScaleWidth - picImage.left -
    Screen.TwipsPerPixelX, Me.ScaleHeight - picImage.Top - picStatus.Height - 2
    * Screen.TwipsPerPixelY
End Sub

Private Sub m_cTexturise_Progress(ByVal lValue As Long, ByVal lMax As Long)
   picStatus.Cls
   picStatus.Print "   " & lValue & " of " & lMax
End Sub

Private Sub picImage_Paint()
   If (m_bOrig) Then
      If Not m_cDibOrig Is Nothing Then
         m_cDibOrig.PaintPicture picImage.hDC
      End If
   Else
      If Not m_cDibWork Is Nothing Then
         m_cDibWork.PaintPicture picImage.hDC
      End If
   End If
End Sub

Private Sub picTexture_Paint()
   If Not m_cTexturise Is Nothing Then
      m_cTexturise.PaintTexture picTexture.hDC
   End If
End Sub


Private Sub sldIntensity_Scroll(ByVal lPos As Long)
   txtIntensity.Text = lPos
End Sub

Private Sub sldSaturation_Scroll(ByVal lPos As Long)
   txtSaturation.Text = lPos
End Sub

Private Sub sldTexture_Scroll(ByVal lPos As Long)
   txtMidValue.Text = lPos
End Sub

Private Sub txtIntensity_KeyPress(KeyAscii As Integer)
   If (KeyAscii = 8) Or (KeyAscii = Asc("-")) Or (KeyAscii >= Asc("0") And
    (KeyAscii <= Asc("9"))) Then
   Else
      KeyAscii = 0
   End If
End Sub

Private Sub txtMidValue_Change()
Dim lR As Long
   If IsNumeric(txtMidValue) Then
      lR = CLng(txtMidValue)
      If (lR > 255) Then lR = 255
      If (lR < 0) Then lR = 0
      lblChosenColour.BackColor = RGB(lR, lR, lR)
   End If
End Sub

Private Sub txtMidValue_KeyPress(KeyAscii As Integer)
   If (KeyAscii = 8) Or (KeyAscii >= Asc("0") And (KeyAscii <= Asc("9"))) Then
   Else
      KeyAscii = 0
   End If
End Sub


Private Sub txtSaturation_KeyPress(KeyAscii As Integer)
   If (KeyAscii = 8) Or (KeyAscii = Asc("-")) Or (KeyAscii >= Asc("0") And
    (KeyAscii <= Asc("9"))) Then
   Else
      KeyAscii = 0
   End If
End Sub