Personal Computer World 2002 March/PCWMAR02.iso/software/turbocad/v8trial/TurboCADv8ProfessionalNoReg.exe/Data.Cab/F41941_modStyles.bas

BASIC Source File | 2001-10-16 | 5.5 KB | 178 lines

Attribute VB_Name = "modStyles"
'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2001                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'

Option Explicit

Sub ShowLineStyles()
    On Error Resume Next
    Dim st As IMSIGX.LineStyle
    Debug.Print "LineStyles"
    For Each st In ActiveDrawing.LineStyles
        ShowLineStyle st
    Next
End Sub

Sub ShowProperties(ByVal props As IMSIGX.Properties)
    On Error Resume Next
    Dim prop As IMSIGX.Property
    Debug.Print "Properties"
    For Each prop In props
        ShowProperty prop
    Next
End Sub

Sub ShowProperty(ByVal prop As IMSIGX.Property)
    On Error Resume Next
    Debug.Print "Property"
    Debug.Print " Name: " & prop.Name
    Debug.Print " Type: " & prop.Type
    Debug.Print " Value: " & prop.Value
End Sub

Function FindNamedColor(ByVal clr As Long, maxDist As Long) As IMSIGX.NamedColor
    On Error Resume Next
    Dim nclr, best As IMSIGX.NamedColor
    Dim tr, tg, tb As Long
    Dim dr, dg, db, i As Long
    Set best = Nothing
    tr = clr Mod 256&
    tg = (clr \ 256&) Mod 256&
    tb = (clr \ (256& * 256&)) Mod 256&
    Debug.Print Application.NamedColors.Count; " named colors"
    i = 0
    For Each nclr In Application.NamedColors
        clr = nclr.Color
        If clr >= 0 Then
            dr = clr Mod 256&
            dg = (clr \ 256&) Mod 256&
            db = (clr \ (256& * 256&)) Mod 256&
            dr = tr - dr
            If dr < 0 Then dr = -dr
            dg = tg - dg
            If dg < 0 Then dg = -dg
            db = tb - db
            If db < 0 Then db = -db
            Debug.Print "(" & i & ") " & nclr.Name & " " & dr & " " & dg & " " & db
            If dr < maxDist And dg < maxDist And db < maxDist Then
                If dr < dg Then
                    maxDist = dr
                Else
                    maxDist = dg
                End If
                If db < maxDist Then
                    maxDist = db
                End If
                Set best = nclr
                If maxDist = 0 Then Exit For
            End If
        End If
        i = i + 1
    Next
    Set FindNamedColor = best
End Function

Sub ShowColorProperty(ByVal prop As IMSIGX.Property)
    On Error Resume Next
    Dim r, g, b, clr, maxDist As Long
    Dim nclr As IMSIGX.NamedColor
    Debug.Print prop.Name
    clr = prop.Value
    If clr >= 0 Then
        r = clr Mod 256&
        g = (clr \ 256&) Mod 256&
        b = (clr \ (256& * 256&)) Mod 256&
        Debug.Print clr & " (&H" & Hex$(clr) & ") = RGB(" & r & ", " & g & ", " & b & ")"
        maxDist = 10
        Set nclr = FindNamedColor(clr, maxDist)
        If Not nclr Is Nothing Then
            Debug.Print "->" & nclr.Name
        End If
    Else
        Debug.Print clr
    End If
End Sub

Sub ShowBrushStyles()
    On Error Resume Next
    Dim st As IMSIGX.BrushStyle
    Debug.Print "BrushStyles"
    For Each st In ActiveDrawing.BrushStyles
        ShowBrushStyle st
    Next
End Sub

Sub ShowLineStyle(ByVal st As IMSIGX.LineStyle)
    On Error Resume Next
    Dim j As Long
    Dim dashes As Variant
    Debug.Print "LineStyle"
    Debug.Print " Name: " & st.Name
    Debug.Print " Description: " & st.Description
    Debug.Print " PatternLength: " & st.PatternLength
    Debug.Print " Dashes"
    st.GetDashes dashes
    For j = LBound(dashes) To UBound(dashes)
        Debug.Print "  (" & j & ") " & dashes(j)
    Next j
End Sub

Sub ShowBrushStyle(ByVal st As IMSIGX.BrushStyle)
    On Error Resume Next
    Debug.Print "BrushStyle"
    Debug.Print " Name: " & st.Name
    Debug.Print " Description: " & st.Description
    Debug.Print " Type: " & st.Type
    Debug.Print " Color: " & st.Color
    Debug.Print " Bitmap: " & st.Bitmap
    Debug.Print " HatchStyle: " & st.HatchStyle
    ShowBrushPatterns st.Patterns
End Sub

Sub ShowBrushPatterns(ByVal pats As IMSIGX.BrushPatterns)
    On Error Resume Next
    Debug.Print "BrushPatterns"
    Dim pat As IMSIGX.BrushPattern
    For Each pat In pats
        ShowBrushPattern pat
    Next pat
End Sub

Sub ShowBrushPattern(ByVal pat As IMSIGX.BrushPattern)
    On Error Resume Next
    Dim dashes As Variant
    Dim i, j As Long
    Dim x, y, w, h, a As Double
    Debug.Print "BrushPattern"
    pat.GetItem i, dashes, x, y, w, h, a
    Debug.Print " Item: " & i
    Debug.Print " Dashes: "
    For j = LBound(dashes) To UBound(dashes)
        Debug.Print "  (" & j & ") " & dashes(j)
    Next j
    Debug.Print " X: " & x
    Debug.Print " Y: " & y
    Debug.Print " Width: " & w
    Debug.Print " Height: " & h
    Debug.Print " Angle: " & a
End Sub

Sub ShowSelStyles()
    On Error Resume Next
    Dim gr As Graphic
    For Each gr In ActiveDrawing.Selection
        DebugPrint "Graphic -- " & gr.Type
        ShowLineStyle gr.LineStyle
        ShowBrushStyle gr.BrushStyle
        ShowColorProperty gr.Properties("PenColor")
        ShowColorProperty gr.Properties("BrushColor")
    Next
End Sub