Доработка функции рассчета цвета - VBA - Ответ 16344828

@testuser2 · Регистрация: 08.02.2017

Author24 — интернет-сервис помощи студентам

Всех приветствую. Сделал функцию рассчета цвета в зависимости от значения. В простом варианте выглядит так.

Visual Basic

Function ColorCalc(Vl, Min, Max, ClMin, ClMax)
    Dim ClRez(3), i
    ClMin = GETRGB(ClMin)
    ClMax = GETRGB(ClMax)
    For i = 0 To 3
      ClRez(i) = ClMin(i) + (ClMax(i) - ClMin(i)) * (Vl - Min) / (Max - Min)
    Next
    Gradient = RGB(ClRez(0), ClRez(1), ClRez(2))
End Function
'возвращает массив с значениями для 3х цветов (RGB)
Function GETRGB(cl) As Long()
  Dim ar(3) As Long
  ar(2) = Int(cl / 65536)
  cl = cl - ar(2) * 65536
  ar(1) = Int(cl / 256)
  ar(0) = cl - ar(1) * 256
  GETRGB = ar  
End Function

Рассчитывается цвет для определенного значения (Vl) в зависимости от заданных макс. и мин. (Max, Min) значений и заданных 2х цветов (ClMax и ClMin).
По информации со страницы.. (можете найти по "Определить математически <<средний цвет>> из 2х"). попытался сделать рассчет по более правильной модели смешения цветов, однако немного примитивно.

Кликните здесь для просмотра всего текста

Visual Basic

Function ColorCalc(Vl, Min, Max, ClMin, ClMax, Optional adt1)
    Dim ClRez(3), i, Y, Y1, Y2, t, Cfr, Cfg, Cfb, MidVl, Hl
    ClMin = GETRGB(ClMin)
    ClMax = GETRGB(ClMax)
    MidVl = (Min + Max) / 2
    If Not IsMissing(adt1) Then
      Select Case adt1
        Case Is = 0: Cfr = 0.299: Cfg = 0.587: Cfb = 0.114 
        Case Is = 1: Cfr = 0.2125: Cfg = 0.7154: Cfb = 0.0721 
      End Select
      Y1 = ClMin(0) * Cfr + ClMin(1) * Cfg + ClMin(2) * Cfb
      Y2 = ClMax(0) * Cfr + ClMax(1) * Cfg + ClMax(2) * Cfb
      Y = (Y1 + Y2) / 2
      If Y2 > Y1 Then
        t = Y2 / Y
      Else
        t = Y1 / Y
      End If
'      Select Case Vl 
'        Case Is < MidVl: t = 1 + (t - 1) * (Vl - Min) * 2 / (Max - Min)
'        Case Is > MidVl: t = 1 + (t - 1) * (Max - Vl) * 2 / (Max - Min)
'      End Select
      Hl = (Max - Min) / 2
      t = 1 + (t - 1) * (Hl - Abs(Vl - MidVl)) / Hl
      't = 1 + (((t - 1) ^ 2) * (Hl - Abs(Vl - MidVl)) / Hl) ^ 0.5
    Else
      t = 1
    End If   
    For i = 0 To 3
          ClRez(i) = t * (ClMin(i) + (ClMax(i) - ClMin(i)) * (Vl - Min) / (Max - Min))
'          If ClRez(i) < 0 Then 
'              ClRez(i) = 0
'          ElseIf ClRez(i) > 255 Then
'              ClRez(i) = 255
'          End If
    Next
    ColorCalc = RGB(ClRez(0), ClRez(1), ClRez(2))
    CollAdd CfColl, Application.Caller.Address, Str(t)
End Function

Кратко, в чем суть - в функции рассчитывается коэффициент кореекции яркости для среднего цвета между 2х заданных (ClrMax и ClrMin) и в зависимости от заданных Vl(текущее значение), Max(максимальное), и Min(минимальное) данный коэффициент пересчитывается - ближе к "краям" (Max и Min) он должен уменьшаться до 1. Я сделал, уменьшение по линейной зависимости, правильнее было бы конечно сделать по какой-нибудь синусоиде. Собственно в чем вопрос, что нужно поменять в данном выражении t = 1 + (t - 1) * (Hl - Abs(Vl - MidVl)) / Hl, чтобы график приобрел более плавную форму?

Вернуться к обсуждению:
Доработка функции рассчета цвета VBA

Следующий ответ

Другие темы раздела
VBA Word Application.visible affects the result of data upload execution When uploading data from sql server to word via axapta, application.visible affects whether macros for formatting the final table will work or not. If I set visible = true, then everything is correct, if false, then it falls on one unremarkable line of the macro, which formats the width of one of the columns. In this regard, a question. What does this property affect at a deep level? Thank you! ... https://www.cyberforum.ru/ vba/ thread3006414.html	VBA Сохранение листов в формате pdf раздельно Добрый день, подскажите, какие есть решения у следующей задачи: Есть книга с фиксированным кол-вом листов В данной книге на 1-м листе формируется список с помощью макроса с именами необходимых листов. Необходимо: (основная задача) 1. сохранить только те листы из данной книги (в формате pdf), имена которых содержаться в списке (доп. задача) 2. задать сохраняемым листам имена из также...
VBA Посчитать размах и вывести на экран наибольший Всем доброго дня! Мне очень нужна помощь программистов. В ВБА эксель разбираюсь слабо, поэтому никак не могу додуматься решить одну простенькую задачку. А задание следующее: дан массив данных: объект\|дата проведения исследования\|найденный параметр 1 \|1.01.1999 \|2.3 1 \|2.01.1999 \|-1.4 2 \|1.01.1999 ... https://www.cyberforum.ru/ vba/ thread3006376.html	VBA Поменять цифры местами согласно заявленных позиций https://www.cyberforum.ru/ vba/ thread3006351.html Как поменять цифры местами согласно указанных позиций. Под А:D исходные позиции цифр. Под K:N указаны новые позиции для перемещения этих цифр. Под F:I получился финальный результат перемещения цифр А:D. C уважением Александр.
VBA Создать столбец с формулой даты текстом Нужно создать макрос, который создает столбец "Месяц" после столбца "Дата", с формулой =ТЕКСТ(Значение ячейки в столбце "Дата;"ММММ")) все что смог сам написать, формула срабатывает только на первую строку, как ее растянуть до конца столбца? Sub InsertColumns() Dim iSh As Worksheet Dim clmName As Range For Each iSh In Worksheets With iSh Set clmName = .Rows(1).Find("Дата")	VBA События умных таблиц. Кто-нибудь пользовался? PivotTableAfterValueChange PivotTableChangeSync PivotTableUpdate и др. Чт это, как это работает? Тема сырая судя по всему, но все же. https://www.cyberforum.ru/ vba/ thread3006178.html
VBA Счетчик подсчета количество замен в Selection.Find https://www.cyberforum.ru/ vba/ thread3006167.html Обрабатываю текст "сжимая" лишнии пробелы,более двух, в один. Хочется узнать сколько раз отрабатывал цикл. Как заставить правильно отрабатывать - всегда пишет что 3 раза. Sub SJIM() prsch0 = 0 ' Сжимание более 2х пробелов в один Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "( {2;})" ...	VBA Макрос в WORD замена всех картинок в документе на текст image1, image2, image3 и т.д. последовательно Добрый день! Собственно вопрос: Макрос в WORD замена всех картинок в документе на текст image1, image2, image3 и т.д. последовательно. Помогите пожалуйста!
VBA Конвертация С в VBA https://www.cyberforum.ru/ vba/ thread3005989.html typedef int item; typedef int tblIndex; #define compGT(a,b) (a > b) void insertSort(T a, tblIndex lb, tblIndex ub) { item t; tblIndex i, j; /**********************	VBA Создать Макрос добавление текста в выделенном фрагменте https://www.cyberforum.ru/ vba/ thread3005687.html Помогите создать Макрос для Word, который в выделенном фрагменте текста в Word к каждому слову будет добавлять цифру. Например есть текст: Простой выделенный текст. При выделении этого текста, он должен замениться на: Простой 1 выделенный 2 текст 3. Причем эти цифры с пробелом должны добавляться с другим шрифтом, например весь текст Times New Roman, а цифры с пробелом добавляются шрифтом...
VBA Выбор данных из таблицы Вновь обращаюсь с просьбой. Возникла трудность в написании макроса, по выбору данных из таблицы, суть процесса (описываю только часть в которой есть вопрос, остальное уже будет дополняться мной позже): 1. Есть уже введенные значения температуры кипения, (Q4) и t уличного воздуха скорректированная (T4) - лист "data" - по этим значениям мы получаем пересечение. В данном пересечении нам интересны...	VBA Скрипт дробилка с копированием форматов ячеек по образцу https://www.cyberforum.ru/ vba/ thread3005613.html Добрый день, нужна ваша помощь. Есть скрип дробилка, но в нем не хватает функции форматирования ячеек. Т.е. он копирует одни данные в новый файл но не может протянуть формат по образцу. option explicit dim xls, r0, c0, aa, Row0, PreStr, ii, jj, tmpl const fDir="Путь" 'путь до папки исходного файла const BigFilename = "БОЛЬШОЙ ФАЙЛ" ' название исходного файла const tmpname="шаблончег.xltx"...

	08.07.2022, 15:22