Mastering Visual Basic 5/MasteringVisualBasic5.iso/olympus/ik32_15t/vb4.shr/commands.bas

BASIC Source File | 1996-09-04 | 7.2 KB | 243 lines

Attribute VB_Name = "IKCommands"
Option Explicit

'***Used for IKOD_GetScreenDepth***
Private Const CCHDEVICENAME = 8
Private Const CCHFORMNAME = 8

Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Sub GetFont(Picbuf As Control, CommonDialog As Control)
On Error GoTo Cancel_Click
    CommonDialog.FontName = Picbuf.Font.Name
    CommonDialog.FontSize = Picbuf.Font.Size
    CommonDialog.ShowFont
    Picbuf.Font.Name = CommonDialog.FontName
    Picbuf.Font.Size = CommonDialog.FontSize
    Picbuf.Font.Bold = CommonDialog.FontBold
    Picbuf.Font.Italic = CommonDialog.FontItalic
    Picbuf.Font.Strikethrough = CommonDialog.FontStrikethru
    Picbuf.Font.Underline = CommonDialog.FontUnderline
    Exit Sub

Cancel_Click:
    If Err.Number = 32755 Then
        Exit Sub
    Else
        MsgBox Err.Description
    End If
End Sub
Function GetBlue(ByVal RGBColor As Long) As Integer
    Dim ColorComponentValue As Integer
    ColorComponentValue = RGBColor \ 65536

    If ColorComponentValue < 0 Or ColorComponentValue > 255 Then
        MsgBox "Assertion Falure:" + Chr(13) + "ColorComponentValue < 0 or > 255.  Invalid value of:" + Str(ColorComponentValue)
    End If

    GetBlue = ColorComponentValue
End Function


Function GetColor(CommonDialog As Object) As Long
    On Error GoTo Cancel_Click
    CommonDialog.CancelError = True
    CommonDialog.ShowColor
    GetColor = CommonDialog.Color
    Exit Function

Cancel_Click:
    If Err.Number = 32755 Then
        Exit Function
    Else
        MsgBox Err.Description
    End If
End Function

Function getGreen(RGBColor As Long) As Integer
    Dim ColorComponentValue As Integer
    ColorComponentValue = (RGBColor And 65535) \ 256

    If ColorComponentValue < 0 Or ColorComponentValue > 255 Then
        MsgBox "Assertion Falure:" + Chr(13) + "ColorComponentValue < 0 or > 255.  Invalid value of:" + Str(ColorComponentValue)
    End If

    getGreen = ColorComponentValue
End Function


Function getRed(RGBColor As Long) As Integer
    Dim ColorComponentValue As Integer
    ColorComponentValue = RGBColor And 255

    If ColorComponentValue < 0 Or ColorComponentValue > 255 Then
        MsgBox "Assertion Falure:" + Chr(13) + "ColorComponentValue < 0 or > 255.  Invalid value of:" + Str(ColorComponentValue)
    End If

    getRed = ColorComponentValue
End Function


Sub ExitProgram()
    End
End Sub




Function GetScreenColorDepth() As Integer
    Const BitsPixel = 12
    Dim TempDevMode As DEVMODE
    Dim ColorDepth, hDC, RetVar As Integer

    hDC = CreateDC("DISPLAY", "", "", TempDevMode)
    ColorDepth = (GetDeviceCaps(hDC, BitsPixel))
    RetVar = DeleteDC(hDC)

    GetScreenColorDepth = ColorDepth
End Function



Sub LoadImage(Picbuf As Control, CommonDialog As Control)

    CommonDialog.DialogTitle = "Load Image"
    CommonDialog.Filter = "all files|*.*|picture files|*.bmp;*.dib;*.jpg;*.pcx;*.png;*.tga;*.tif;*.fif|BMP|*.bmp|DIB|*.dib|JPEG|*.jpg|PCX|*.pcx|PNG|*.png|Targa|*.tga|TIFF|*.tif|FIF|*.fif"
    CommonDialog.FilterIndex = 2
    CommonDialog.InitDir = App.Path + "\..\Images\"
    On Error GoTo Cancel_Click
    CommonDialog.CancelError = True
    CommonDialog.ShowOpen
    Picbuf.Filename = CommonDialog.Filename
    Picbuf.Load
    Exit Sub

Cancel_Click:
    If Err.Number = 32755 Then
        Exit Sub
    Else
        MsgBox Err.Description
    End If
End Sub
Sub SaveImage(Picbuf As Control, CommonDialog As Control)
    Dim strFileExtension As String

    CommonDialog.DialogTitle = "Save Image"
    CommonDialog.Filter = "TIFF|*.tif|Targa|*.tga|BMP|*.bmp|GIF|*.gif|DIB|*.dib|PCX|*.pcx|JPEG|*.jpg|FIF|*.fif|PNG|*.png"

    'this code sets the index for the CMDialog
    If Picbuf.ImageFormat = 0 Then
        'The following should work, but does not because the Right Function is not working correctly
        'strFileExtension = UCase(Right(Picbuf.Filename, 3))
        strFileExtension = UCase(Mid(Picbuf.Filename, Len(Picbuf.Filename) - 2, 3))
    Else
    strFileExtension = Picbuf.ImageFormat
    End If

    Select Case strFileExtension
        Case "TIF", 1
            CommonDialog.FilterIndex = 1
        Case "TGA", 2
            CommonDialog.FilterIndex = 2
        Case "BMP", 3
            CommonDialog.FilterIndex = 3
        Case "GIF", 4
            CommonDialog.FilterIndex = 4
        Case "DIB", 5
            CommonDialog.FilterIndex = 5
        Case "PCX", 6
            CommonDialog.FilterIndex = 6
        Case "JPG", 7
            CommonDialog.FilterIndex = 7
        Case "PNG", 8
            CommonDialog.FilterIndex = 9
        Case Else
            CommonDialog.FilterIndex = 3
    End Select


    On Error GoTo Cancel_Click
    CommonDialog.CancelError = True
    CommonDialog.ShowSave
    strFileExtension = UCase(Mid(CommonDialog.Filename, Len(CommonDialog.Filename) - 2, 3))
    If Picbuf.ImageFormat = 0 Then
        Select Case strFileExtension
            Case "TIF"
                Picbuf.ImageFormat = 1
            Case "TGA"
                Picbuf.ImageFormat = 2
            Case "BMP"
                Picbuf.ImageFormat = 3
            Case "GIF"
                Picbuf.ImageFormat = 4
            Case "DIB"
                Picbuf.ImageFormat = 5
            Case "PCX"
                Picbuf.ImageFormat = 6
            Case "JPG"
                Picbuf.ImageFormat = 7
                If Picbuf.WriteCompression = 0 Then
                    Picbuf.WriteCompression = 65
                End If
            Case "FIF"
                Picbuf.ImageFormat = 9
            Case "PNG"
                Picbuf.ImageFormat = 10
        End Select
    End If
    Picbuf.Filename = CommonDialog.Filename
    Picbuf.Store
    Picbuf.ImageFormat = 0
    Picbuf.WriteCompression = 0
    Exit Sub

Cancel_Click:
    If Err.Number = 32755 Then
        Exit Sub
    Else
        MsgBox Err.Description
    End If
End Sub




Sub SetSelect(Picbuf As Object, intLeft As Integer, intTop As Integer, intWidth As Integer, intHeight As Integer)
    Picbuf.SelectTop = intTop
    Picbuf.SelectLeft = intLeft
    Picbuf.SelectWidth = intWidth
    Picbuf.SelectHeight = intHeight
End Sub