VB5 Image Processor (163K)
VB6 Image Processor (149K)
13 Jan 2003
Added VB6 version
Softening, Blurring, Sharpening and Embossing images
Hue Luminance and Saturation (HLS) Model and Manipulating Colours
Floyd-Stucci Colour Reduction Methods and Gray Scaling
vbAccelerator - Contents of code file: mfrmMain.frm
VERSION 5.00
Begin VB.MDIForm mfrmMain
AutoShowChildren= 0 'False
BackColor = &H8000000C&
Caption = "vbaccelerator DIB Section Image Processing Sample"
ClientHeight = 7005
ClientLeft = 2565
ClientTop = 2790
ClientWidth = 8190
Icon = "mfrmMain.frx":0000
LinkTopic = "MDIForm1"
Begin VB.PictureBox picStatus
Align = 2 'Align Bottom
BorderStyle = 0 'None
Height = 315
Left = 0
ScaleHeight = 315
ScaleWidth = 8190
TabIndex = 0
Top = 6690
Width = 8190
Begin VBImageProc.ProgressBar prgMain
Height = 255
Left = 0
Top = 60
Visible = 0 'False
Width = 5055
_ExtentX = 8916
_ExtentY = 450
Smooth = -1 'True
Min = 1
End
Begin VB.Label lblSize
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 6660
TabIndex = 3
Top = 60
Width = 1515
End
Begin VB.Label lblImage
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 5100
TabIndex = 2
Top = 60
Width = 1515
End
Begin VB.Label lblStatus
BorderStyle = 1 'Fixed Single
Caption = "Ready."
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 0
TabIndex = 1
Top = 60
Width = 5055
End
End
Begin VB.Menu mnuFileTop
Caption = "&File"
Begin VB.Menu mnuFile
Caption = "&Open..."
Index = 0
Shortcut = ^O
End
Begin VB.Menu mnuFile
Caption = "&Save..."
Index = 1
Shortcut = ^S
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 2
End
Begin VB.Menu mnuFile
Caption = "&Print..."
Index = 3
Shortcut = ^P
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 4
End
Begin VB.Menu mnuFile
Caption = ""
Index = 5
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = ""
Index = 6
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = ""
Index = 7
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = ""
Index = 8
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "-"
Index = 9
Visible = 0 'False
End
Begin VB.Menu mnuFile
Caption = "&Close"
Index = 10
End
End
Begin VB.Menu mnuEditTOP
Caption = "&Edit"
Begin VB.Menu mnuEdit
Caption = "&Copy"
Index = 1
Shortcut = ^C
End
Begin VB.Menu mnuEdit
Caption = "&Paste"
Index = 2
Shortcut = ^V
End
End
Begin VB.Menu mnuImageTOP
Caption = "&Image"
Begin VB.Menu mnuImage
Caption = "&Softening Filters"
Index = 0
Begin VB.Menu mnuLowPass
Caption = "Soften"
Index = 0
End
Begin VB.Menu mnuLowPass
Caption = "Soften More"
Index = 1
End
Begin VB.Menu mnuLowPass
Caption = "Blur"
Index = 2
End
Begin VB.Menu mnuLowPass
Caption = "Blur More"
Index = 3
End
End
Begin VB.Menu mnuImage
Caption = "S&harpening Filters"
Index = 1
Begin VB.Menu mnuHighPass
Caption = "Sharpen"
Index = 0
End
Begin VB.Menu mnuHighPass
Caption = "Sharpen More"
Index = 1
End
Begin VB.Menu mnuHighPass
Caption = "Unsharp"
Index = 2
End
End
Begin VB.Menu mnuImage
Caption = "&Special Filters"
Index = 2
Begin VB.Menu mnuSpecial
Caption = "&Emboss..."
Index = 0
End
Begin VB.Menu mnuSpecial
Caption = "-"
Index = 1
End
Begin VB.Menu mnuSpecial
Caption = "Add &Noise..."
Index = 2
End
Begin VB.Menu mnuSpecial
Caption = "-"
Index = 3
End
Begin VB.Menu mnuSpecial
Caption = "Mi&nimum Rank Filter..."
Index = 4
End
Begin VB.Menu mnuSpecial
Caption = "Me&dian Rank Filter..."
Index = 5
End
Begin VB.Menu mnuSpecial
Caption = "Ma&ximum Rank Filter..."
Index = 6
End
End
Begin VB.Menu mnuImage
Caption = "&Custom Defined Filters..."
Index = 3
End
Begin VB.Menu mnuImage
Caption = "-"
Index = 4
End
Begin VB.Menu mnuImage
Caption = "&Resample..."
Index = 5
End
Begin VB.Menu mnuImage
Caption = "-"
Index = 6
End
Begin VB.Menu mnuImage
Caption = "Co&mbine..."
Index = 7
End
End
Begin VB.Menu mnuColorTOP
Caption = "&Colors"
Begin VB.Menu mnuColors
Caption = "&Darken..."
Index = 0
End
Begin VB.Menu mnuColors
Caption = "&Lighten..."
Index = 1
End
Begin VB.Menu mnuColors
Caption = "-"
Index = 2
End
Begin VB.Menu mnuColors
Caption = "&Colourise..."
Index = 3
End
Begin VB.Menu mnuColors
Caption = "-"
Index = 4
End
Begin VB.Menu mnuColors
Caption = "&Negative Image..."
Index = 5
End
Begin VB.Menu mnuColors
Caption = "-"
Index = 6
End
Begin VB.Menu mnuColors
Caption = "&Gray Scale..."
Index = 7
End
Begin VB.Menu mnuColors
Caption = "&B/W (Floyd-Steinberg)..."
Index = 8
End
Begin VB.Menu mnuColors
Caption = "&Apply Palette..."
Index = 9
End
End
Begin VB.Menu mnuWindowTop
Caption = "&Window"
WindowList = -1 'True
Begin VB.Menu mnuWindow
Caption = "Tile &Horizontally"
Index = 0
End
Begin VB.Menu mnuWindow
Caption = "Tile &Vertically"
Index = 1
End
Begin VB.Menu mnuWindow
Caption = "&Cascade"
Index = 2
End
Begin VB.Menu mnuWindow
Caption = "&Arrange Icons"
Index = 3
End
End
Begin VB.Menu mnuHelpTOP
Caption = "&Help"
Begin VB.Menu mnuHelp
Caption = "vbAccelerator on the &Web"
Index = 0
Shortcut = {F1}
End
Begin VB.Menu mnuHelp
Caption = "-"
Index = 1
End
Begin VB.Menu mnuHelp
Caption = "&About..."
Index = 2
End
End
End
Attribute VB_Name = "mfrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_cMRU As New cMRUFileList
Private m_bInIDE As Boolean
Private m_lCount As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal
nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias
"GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String,
ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal
nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc
As Long) As Long
Private Const BITSPIXEL = 12 ' Number of bits per pixel
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA"
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As
Long) As Long
Private Declare Function ShellExecuteForExplore Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile
As String, lpParameters As Any, lpDirectory As Any, ByVal nShowCmd As Long) As
Long
Public Enum EShellShowConstants
essSW_HIDE = 0
essSW_MAXIMIZE = 3
essSW_MINIMIZE = 6
essSW_SHOWMAXIMIZED = 3
essSW_SHOWMINIMIZED = 2
essSW_SHOWNORMAL = 1
essSW_SHOWNOACTIVATE = 4
essSW_SHOWNA = 8
essSW_SHOWMINNOACTIVE = 7
essSW_SHOWDEFAULT = 10
essSW_RESTORE = 9
essSW_SHOW = 5
End Enum
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Const SE_ERR_ACCESSDENIED = 5 ' access denied
Private Const SE_ERR_ASSOCINCOMPLETE = 27
Private Const SE_ERR_DDEBUSY = 30
Private Const SE_ERR_DDEFAIL = 29
Private Const SE_ERR_DDETIMEOUT = 28
Private Const SE_ERR_DLLNOTFOUND = 32
Private Const SE_ERR_FNF = 2 ' file not found
Private Const SE_ERR_NOASSOC = 31
Private Const SE_ERR_PNF = 3 ' path not found
Private Const SE_ERR_OOM = 8 ' out of memory
Private Const SE_ERR_SHARE = 26
Private Const MAX_PATH = 260
Public Property Get NewImageIndex() As Long
m_lCount = m_lCount + 1
NewImageIndex = m_lCount
End Property
Public Function ShellEx( _
ByVal sFIle As String, _
Optional ByVal eShowCmd As EShellShowConstants = essSW_SHOWDEFAULT, _
Optional ByVal sParameters As String = "", _
Optional ByVal sDefaultDir As String = "", _
Optional sOperation As String = "open", _
Optional Owner As Long = 0 _
) As Boolean
Dim lR As Long
Dim lErr As Long, sErr As Long
If (InStr(UCase$(sFIle), ".EXE") <> 0) Then
eShowCmd = 0
End If
On Error Resume Next
If (sParameters = "") And (sDefaultDir = "") Then
lR = ShellExecuteForExplore(Owner, sOperation, sFIle, 0, 0,
essSW_SHOWNORMAL)
Else
lR = ShellExecute(Owner, sOperation, sFIle, sParameters, sDefaultDir,
eShowCmd)
End If
If (lR < 0) Or (lR > 32) Then
ShellEx = True
Else
' raise an appropriate error:
lErr = vbObjectError + 1048 + lR
Select Case lR
Case 0
lErr = 7: sErr = "Out of memory"
Case ERROR_FILE_NOT_FOUND
lErr = 53: sErr = "File not found"
Case ERROR_PATH_NOT_FOUND
lErr = 76: sErr = "Path not found"
Case ERROR_BAD_FORMAT
sErr = "The executable file is invalid or corrupt"
Case SE_ERR_ACCESSDENIED
lErr = 75: sErr = "Path/file access error"
Case SE_ERR_ASSOCINCOMPLETE
sErr = "This file type does not have a valid file association."
Case SE_ERR_DDEBUSY
lErr = 285: sErr = "The file could not be opened because the target
application is busy. Please try again in a moment."
Case SE_ERR_DDEFAIL
lErr = 285: sErr = "The file could not be opened because the DDE
transaction failed. Please try again in a moment."
Case SE_ERR_DDETIMEOUT
lErr = 286: sErr = "The file could not be opened due to time out.
Please try again in a moment."
Case SE_ERR_DLLNOTFOUND
lErr = 48: sErr = "The specified dynamic-link library was not
found."
Case SE_ERR_FNF
lErr = 53: sErr = "File not found"
Case SE_ERR_NOASSOC
sErr = "No application is associated with this file type."
Case SE_ERR_OOM
lErr = 7: sErr = "Out of memory"
Case SE_ERR_PNF
lErr = 76: sErr = "Path not found"
Case SE_ERR_SHARE
lErr = 75: sErr = "A sharing violation occurred."
Case Else
sErr = "An error occurred occurred whilst trying to open or print
the selected file."
End Select
Err.Raise lErr, , App.EXEName & ".GShell", sErr
ShellEx = False
End If
End Function
Public Property Get TempDir() As String
Dim sRet As String, c As Long
sRet = String$(MAX_PATH, 0)
c = GetTempPath(MAX_PATH, sRet)
If c = 0 Then Err.Raise Err.LastDllError
TempDir = Left$(sRet, c)
End Property
Public Property Get TempFileName( _
Optional ByVal sPrefix As String, _
Optional ByVal sPathName As String) As String
Dim iPos As Long
If sPrefix = "" Then sPrefix = ""
If sPathName = "" Then sPathName = TempDir
Dim sRet As String
sRet = String(MAX_PATH, 0)
GetTempFileName sPathName, sPrefix, 0, sRet
If (Err.LastDllError <> 0) Then Err.Raise Err.LastDllError
iPos = InStr(sRet, Chr$(0))
If (iPos <> 0) Then
TempFileName = Left$(sRet, (iPos - 1))
Else
TempFileName = sRet
End If
End Property
Private Function InIDECheck() As Boolean
m_bInIDE = True
InIDECheck = True
End Function
Public Sub AddMRUFile(ByVal sFIle As String)
m_cMRU.AddFile sFIle
pShowMRU
End Sub
Public Property Let ProgressMax(ByVal lMax As Long)
prgMain.Max = lMax
End Property
Public Property Let ProgressValue(ByVal lValue As Long)
prgMain.Position = lValue
End Property
Public Property Let ShowProgress(ByVal bShow As Boolean)
prgMain.Visible = bShow
End Property
Public Sub SetStatus( _
Optional ByVal sMain As String = "#", _
Optional ByVal sImage As String = "#", _
Optional ByVal sSize As String = "#" _
)
If (sMain <> "#") Then
lblStatus.Caption = " " & sMain
End If
If (sImage <> "#") Then
lblImage.Caption = " " & sImage
End If
If (sSize <> "#") Then
lblSize.Caption = " " & sSize
End If
End Sub
Private Function GetActiveform(ByRef f As frmImage) As Boolean
If Not (Me.ActiveForm Is Nothing) Then
If (Me.ActiveForm.Name = "frmImage") Then
Set f = Me.ActiveForm
GetActiveform = True
Else
MsgBox "Please select an Image to process.", vbInformation
End If
Else
MsgBox "Please select an Image to process.", vbInformation
End If
End Function
Private Sub pOpen(Optional ByVal sFIle As String = "")
Dim c As New GCommonDialog
Dim bContinue As Boolean
bContinue = True
If (sFIle = "") Then
' Get a new file:
bContinue = False
If (c.VBGetOpenFileName(sFIle, , , , , , "Picture Files
(*.BMP;*.GIF;*.JPG;*.DIB)|*.BMP;*.GIF;*.JPG;*.DIB|Bitmap Files
(*.BMP;*.DIB)|*.BMP;*.DIB|GIF Files (*.GIF)|*.GIF|JPEG Files
(*.JPG)|*.JPG|All FIles (*.*)|*.*", 1, , , "BMP", Me.hwnd)) Then
bContinue = True
End If
End If
If (bContinue) Then
Dim f As New frmImage
If (f.OpenFile(sFIle)) Then
f.Show
Else
Unload f
End If
End If
End Sub
Private Sub pSave()
Dim f As frmImage
If (GetActiveform(f)) Then
f.SaveFile
End If
End Sub
Private Sub pShowMRU()
Dim i As Long
For i = 1 To m_cMRU.FileCount
If (m_cMRU.FileExists(i)) Then
mnuFile(i + 4).Visible = True
mnuFile(i + 4).Caption = m_cMRU.MenuCaption(i)
End If
Next i
mnuFile(9).Visible = (m_cMRU.FileCount > 0)
End Sub
Private Sub MDIForm_Load()
Dim cR As New cRegistry
Dim lHDC As Long
Dim lhWNd As Long
Dim sMsg As String
m_cMRU.MaxFileCount = 4
cR.ClassKey = HKEY_CURRENT_USER
cR.SectionKey = "Software\vbAccelerator\vbImageProc"
m_cMRU.Load cR
pShowMRU
Me.Show
Debug.Assert (InIDECheck = True)
If (m_bInIDE) Then
MsgBox "You are running this sample in the VB IDE." & vbCrLf & vbCrLf &
"Please note that the Image Processing functions run 25 - 50x quicker
when compiled to Native Code.", vbInformation
End If
lhWNd = GetDesktopWindow()
lHDC = GetDC(lhWNd)
If (GetDeviceCaps(lHDC, BITSPIXEL) <= 8) Then
sMsg = "Screen colour depths below 16 bits/pixel are not supported by
this sample."
If (m_bInIDE) Then
sMsg = sMsg & vbCrLf & vbCrLf & "You must exit out of VB, change
colour depth and re-load in VB to get it to work."
End If
MsgBox sMsg, vbExclamation
End If
ReleaseDC lhWNd, lHDC
End Sub
Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Long
If UnloadMode <> vbAppWindows And UnloadMode <> vbAppTaskManager Then
For i = 0 To Forms.Count - 1
If (Forms(i).Name = "frmImage") Then
If (Forms(i).Dirty) Then
If Not (Forms(i).QuerySave()) Then
Cancel = True
Exit Sub
End If
End If
End If
Next i
End If
Dim cR As New cRegistry
cR.ClassKey = HKEY_CURRENT_USER
cR.SectionKey = "Software\vbAccelerator\vbImageProc"
m_cMRU.Save cR
End Sub
Private Sub mnuColors_Click(Index As Integer)
Dim f As frmImage
If (GetActiveform(f)) Then
Select Case Index
Case 0
f.Fade
Case 1
f.Lighten
Case 3
pColourise f
Case 5
f.NegativeImage
Case 7
f.GrayScale
Case 8
f.BlackAndWhite
Case 9
pPalette f
End Select
End If
End Sub
Private Sub mnuEdit_Click(Index As Integer)
Dim f As frmImage
Dim sName As String
Select Case Index
Case 1
If (GetActiveform(f)) Then
f.CopyImage
End If
Case 2
On Error GoTo PasteImageError
Dim sPic As New StdPicture
Set sPic = Clipboard.GetData(vbCFBitmap)
sName = TempFileName("VBIM")
SavePicture sPic, sName
Dim fN As New frmImage
If (fN.OpenFile(sName, True)) Then
fN.Show
Else
Unload fN
End If
On Error Resume Next
Kill sName
End Select
Exit Sub
PasteImageError:
MsgBox "An error occured whilst trying to paste this image: " &
Err.Description, vbExclamation
On Error Resume Next
Kill sName
Exit Sub
Resume 0
End Sub
Private Sub mnuFile_Click(Index As Integer)
Select Case Index
Case 0
pOpen
Case 1
pSave
Case 3
MsgBox "Left as an exercise...", vbInformation
Case 5 To 8
pOpen m_cMRU.file(Index - 4)
Case 10
Unload Me
End Select
End Sub
Private Sub mnuHelp_Click(Index As Integer)
Select Case Index
Case 0
' shell
ShellEx "http://www.dogma.demon.co.uk", , , , , Me.hwnd
Case 2
frmAbout.Show vbModal, Me
End Select
End Sub
Private Sub mnuHighPass_Click(Index As Integer)
Dim f As frmImage
If (GetActiveform(f)) Then
Select Case Index
Case 0
f.ProcessImage eSharpen
Case 1
f.ProcessImage eSharpenMore
Case 2
f.ProcessImage eUnSharp
End Select
End If
End Sub
Private Sub mnuImage_Click(Index As Integer)
Dim f As frmImage
Select Case Index
Case 3
' User defined filter...
If (GetActiveform(f)) Then
pCustomFilter f
End If
Case 5
' Resample....
If (GetActiveform(f)) Then
pResample f
End If
Case 7
' Combine:
If (GetActiveform(f)) Then
pCombine
End If
End Select
End Sub
Private Function pResample(ByRef f As frmImage) As Boolean
Dim fC As New frmNewSize
fC.SetSize f.ImageWidth, f.ImageHeight
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
f.Resample fC.ImageWidth, fC.ImageHeight
pResample = True
End If
End Function
Private Function pCustomFilter(ByRef f As frmImage) As Boolean
Dim fC As New frmCustomFilter
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
f.LoadCustomFilter fC.ImageProcess
f.ProcessImage eCustom
pCustomFilter = True
End If
End Function
Private Function pCombine() As Boolean
Dim fC As New frmCombination
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
Dim f As New frmImage
f.Show
f.Combine fC
End If
End Function
Private Sub mnuLowPass_Click(Index As Integer)
Dim f As frmImage
If (GetActiveform(f)) Then
Select Case Index
Case 0
f.ProcessImage eSoften
Case 1
f.ProcessImage eSoftenMore
Case 2
f.ProcessImage eBlur
Case 3
f.ProcessImage eBlurMore
End Select
End If
End Sub
Private Sub mnuSpecial_Click(Index As Integer)
Dim f As frmImage
If (GetActiveform(f)) Then
Select Case Index
Case 0
' Emboss:
f.ProcessImage eEmboss
Case 2
' Add noise:
pAddNoise f
Case 4
' Minimum:
f.ProcessImage eMinimum
Case 5
' Median:
f.ProcessImage eMedian
Case 6
' Maximum:
f.ProcessImage eMaximum
End Select
End If
End Sub
Private Sub pAddNoise(ByRef f As frmImage)
Dim fC As New frmAddNoise
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
f.AddNoise fC.Random, fC.Percentage
End If
End Sub
Private Sub pColourise(ByRef f As frmImage)
Dim fC As New frmColourise
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
f.Colourise fC.Hue
End If
End Sub
Private Sub pPalette(ByRef f As frmImage)
Dim fC As New frmPalette
fC.Show vbModal, Me
If Not (fC.Cancelled) Then
f.ApplyPalette fC.FileName
End If
End Sub
Private Sub mnuWindow_Click(Index As Integer)
Select Case Index
Case 0
Me.Arrange vbTileHorizontal
Case 1
Me.Arrange vbTileVertical
Case 2
Me.Arrange vbCascade
Case 3
Me.Arrange vbArrangeIcons
End Select
End Sub
Private Sub picStatus_Resize()
Dim lW As Long
On Error Resume Next
lW = lblImage.Width + 2 * Screen.TwipsPerPixelX + lblSize.Width + 2 *
Screen.TwipsPerPixelX
If (Me.ScaleWidth - lW < 64 * Screen.TwipsPerPixelX) Then
lblStatus.Width = Me.ScaleWidth - lblStatus.Left * 2
prgMain.Width = lblStatus.Width
lblSize.Visible = False
lblImage.Visible = False
Else
lblSize.Visible = True
lblImage.Visible = True
lblStatus.Width = Me.ScaleWidth - lblStatus.Left * 2 - lW
prgMain.Width = lblStatus.Width
lblImage.Left = lblStatus.Left * 2 + lblStatus.Width + 2 *
Screen.TwipsPerPixelX
lblSize.Left = lblImage.Left + lblImage.Width + 2 *
Screen.TwipsPerPixelX
End If
End Sub
