mfrmmain.frm

Visual Basic image processing. Mainly it occupies some filters to detect some prperties of image. Re

            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