Re: Новый цвет

Написал wOxxOm в 21/02/2010 0:18:29

по-хорошему проанализировать самому в коде принадлежность исходя из диапазона номеров и букв, либо брутфорсом перебрать в цикле все палитры))

set myColor = paletteSearch( Label1.Caption )
...............

Function paletteSearch(colorName$) As Color
    Dim pal As Palette, var As Variant, index&, i&, bClose As Boolean
    
    On Error Resume Next
    For Each var In Array(cdrTRUMATCH, cdrPANTONEProcess, cdrPANTONECorel8, cdrFOCOLTONE, cdrSpectraMaster, cdrTOYO, cdrDIC, cdrLab, cdrHKS, cdrWebSafe, cdrPANTONEMetallic, cdrPANTONEPastelCoated, cdrPANTONEPastelUncoated, cdrPANTONEHexCoated, cdrPANTONEHexUncoated, cdrPANTONEMatte, cdrPANTONECoated, cdrPANTONEUncoated, cdrPANTONEProcessCoatedEURO, cdrPANTONESolid2ProcessEURO)
        
        'keep user opened palettes
        bClose = True
        For i = 1 To Palettes.Count
            If Palettes(i).PaletteID = var Then bClose = False: Exit For
        Next
        
        'search palette
        Set pal = Palettes.OpenFixed(var)
        If Not pal Is Nothing Then
            index = pal.FindColor(colorName)
            
            If bClose Then
                ' close palette bug workaround
                For i = 1 To Palettes.Count
                    If Palettes(i).PaletteID = pal.PaletteID Then Palettes(i).Close: Exit For
                Next
            End If
            Set pal = Nothing
            
            'found?
            If index > 0 Then
                Set paletteSearch = CreateFixedColor(var, index)
                Exit Function 'color is found
            End If
        End If
    Next
    ' color was not found, 'paletteSearch' is nothing
End Function