Regenbogen-Zellen:)

Hallo alle miteinander!!
Ich habe da ein Makro problem, und ich hoffe ihr helft mir dabei ;)
Ich möchte ein Makro schreiben, das in Word einen Text, Zeichen für zeichen, in den Farben des Regenbogens färbt. Und das abhängig von der Anzahl der Zeichen pro zeile. Nun ist es mir nicht gelungen, eine Formel zu finden, sie es mir erlaubt, einen regenbogen in seinen Farbbestandteilen zu berrechnen. Und da dachte ich mir stell doch mal die frage an dieses Forum, vielleicht weiß da jemand mehr...
Um es excel-lastiger zu machen,wäre es vielleicht am einfachsten ein demo-makro zu erstellen, das anhand einer Zahlenvorgabe (entspricht den zeichen meines textes und in der Tabelle den zeilen) in eine Tabelle die RGB-werte einträgt und eine Zelle daneben entsprechen einfärbt.
Ich hoffe daraus genug zu erlernen um es dann in Word umzusetzen...
Danke schon mal im Voraus und natürlich euch allen eingesegnetes Weihnachtsfest, ob ihr es den nun feiert oder nicht, den ein bisschen Friede-Freude-ZimtApfelKuchen kann glaube ich jeder gebrauchen!!!
Kolja

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kolja!
Hier ein Makro für Word!
Die Sub "Regenbogen" färbt deinen Text! (Auswahl oder ganzes Dokument!)
Den restlichen Code packst du am besten in ein eigenes Modul!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Regenbogen()
Dim hsl As HSLCol
Dim RGBLong As Long
Dim iCnt As Integer, intIndex As Integer, intStep As Integer

'Mit den Werten von Lum, Sat und intStep ein wenig Experimentieren!

hsl.Lum = 125
hsl.Sat = 190
intStep = 1

With ThisDocument.Range ' Selection 'Ganzes Dokument(dauert) oder Auswahl!

  For iCnt = 1 To Len(.Text)
    If .Characters(iCnt) <> " " Then
      hsl.Hue = intIndex
      RGBLong = HSLtoRGB(hsl)
      .Characters(iCnt).Font.Color = RGB(RGBRed(RGBLong), RGBGreen(RGBLong), RGBBlue(RGBLong))
      intIndex = intIndex + intStep
      If intIndex > 255 Then intIndex = 0
    End If
  Next

End With

End Sub

' **********************************************************************
' Modul: basHSL Typ: Allgemeines Modul
' **********************************************************************

'By: Chris Jennings

'Description: HSL, Hue Saturation and Luminance, Is a "colour reference model" often chosen
'to express colours because it uses more "natural" values- as opposed to RGB. The following
'program is a simple dialog allowing the convertion from HSL to RGB and back again.
'You can perform both operations at the same time on one form so you can see how accurate
'the convertion is. I compared the results I got to the colour picker display in both
'Paint Shop Pro and Adobe Photoshop and found the convertion to be quite accurate.
'There are also inbuilt functions for splitting long colour values into seperate RGB values.
'PURE VB code- no OCX's, DLL's or even API calls. I'm sure lots of you out there will find
'this very usefull. ;)
'This file came from Planet-Source-Code.com...the home millions of lines of source code
'You can view comments on this code/and or vote on it at:
'
'http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=52733&lngWId=1
'
'The author may have retained certain copyrights to this code...
'please observe their request and the law by reviewing all copyright conditions
'at the above URL.

Option Explicit
Const HSLMAX As Long = 255
'H, S and L values can be 0 - HSLMAX. 240 matches what is used by MS Win;
'any number less than 1 byte is OK; works best if it is evenly divisible by 6
Const RGBMAX As Long = 255
'R, G, and B value can be 0 - RGBMAX
Const UNDEFINED As Long = 0
'Hue is undefined if Saturation = 0 (greyscale)

Public Type HSLCol 'Datatype used to pass HSL Color values
  Hue As Long
  Sat As Long
  Lum As Long
End Type

Public Function RGBRed(RGBCol As Long) As Long
'Return the Red component from an RGB Color
RGBRed = RGBCol And &HFF
End Function

Public Function RGBGreen(RGBCol As Long) As Long
'Return the Green component from an RGB Color
RGBGreen = ((RGBCol And &H100FF00) \ &H100)
End Function

Public Function RGBBlue(RGBCol As Long) As Long
'Return the Blue component from an RGB Color
RGBBlue = (RGBCol And &HFF0000) \ &H10000
End Function

Private Function iMax(a As Long, B As Long) As Long
'Return the Larger of two values
iMax = IIf(a > B, a, B)
End Function

Private Function iMin(a As Long, B As Long) As Long
'Return the smaller of two values
iMin = IIf(a < B, a, B)
End Function

Public Function RGBtoHSL(RGBCol As Long) As HSLCol
'Returns an HSLCol datatype containing H ue, Luminescence
'and Saturation; given an RGB Color value
Dim R As Long, G As Long, B As Long
Dim cMax As Long, cMin As Long
Dim RDelta As Double, GDelta As Double, BDelta As Double
Dim H As Double, s As Double, L As Double
Dim cMinus As Long, cPlus As Long

R = RGBRed(RGBCol)
G = RGBGreen(RGBCol)
B = RGBBlue(RGBCol)

cMax = iMax(iMax(R, G), B) 'Highest and lowest
cMin = iMin(iMin(R, G), B) 'color values

cMinus = cMax - cMin 'Used to simplify the
cPlus = cMax + cMin 'calculations somewhat.

'Calculate luminescence (lightness)
L = ((cPlus * HSLMAX) + RGBMAX) / (2 * RGBMAX)

If cMax = cMin Then 'achromatic (r=g=b, greyscale)
  s = 0 'Saturation 0 for greyscale
  H = UNDEFINED 'Hue undefined for greyscale
Else
  'Calculate color saturation


  If L <= (HSLMAX / 2) Then
    s = ((cMinus * HSLMAX) + 0.5) / cPlus
  Else
    s = ((cMinus * HSLMAX) + 0.5) / (2 * RGBMAX - cPlus)
  End If

  'Calculate hue
  RDelta = (((cMax - R) * (HSLMAX / 6)) + 0.5) / cMinus
  GDelta = (((cMax - G) * (HSLMAX / 6)) + 0.5) / cMinus
  BDelta = (((cMax - B) * (HSLMAX / 6)) + 0.5) / cMinus



  Select Case cMax
    Case Clng(R)
      H = BDelta - GDelta
    Case Clng(G)
      H = (HSLMAX / 3) + RDelta - BDelta
    Case Clng(B)
      H = ((2 * HSLMAX) / 3) + GDelta - RDelta
  End Select

  If H < 0 Then H = H + HSLMAX
End If

RGBtoHSL.Hue = Clng(H)
RGBtoHSL.Lum = Clng(L)
RGBtoHSL.Sat = Clng(s)
End Function

Public Function HSLtoRGB(HueLumSat As HSLCol) As Long
Dim R As Long, G As Long, B As Long
Dim H As Long, L As Long, s As Long
Dim Magic1 As Long, Magic2 As Long
H = HueLumSat.Hue
L = HueLumSat.Lum
s = HueLumSat.Sat

If s = 0 Then 'Greyscale
  R = (L * RGBMAX) / HSLMAX 'luminescence,
  'converted to the proper range
  G = R 'All RGB values same in greyscale
  B = R


  If H <> UNDEFINED Then
    'This is technically an error.
    'The RGBtoHSL routine will always return
    '
    'Hue = UNDEFINED when Sat = 0.
    'if you are writing a color mixer and
    'letting the user input color values,
    'you may want to set Hue = UNDEFINED
    'in this case.
  End If
Else
  'Get the "Magic Numbers"


  If L <= HSLMAX / 2 Then
    Magic2 = (L * (HSLMAX + s) + (HSLMAX / 2)) / HSLMAX
  Else
    Magic2 = L + s - ((L * s) + (HSLMAX / 2)) / HSLMAX
  End If
  Magic1 = 2 * L - Magic2
  'get R, G, B; change units from HSLMAX range
  'to RGBMAX range
  R = (HuetoRGB(Magic1, Magic2, H + (HSLMAX / 3)) * RGBMAX + (HSLMAX / 2)) / HSLMAX
  G = (HuetoRGB(Magic1, Magic2, H) * RGBMAX + (HSLMAX / 2)) / HSLMAX
  B = (HuetoRGB(Magic1, Magic2, H - (HSLMAX / 3)) * RGBMAX + (HSLMAX / 2)) / HSLMAX
End If
HSLtoRGB = RGB(Cint(R), Cint(G), Cint(B))
End Function

Private Function HuetoRGB(mag1 As Long, mag2 As Long, Hue As Long) As Long
'Utility function for HSLtoRGB
'Range check

If Hue < 0 Then
  Hue = Hue + HSLMAX
ElseIf Hue > HSLMAX Then
  Hue = Hue - HSLMAX
End If
'Return r, g, or b value from parameters
'

Select Case Hue 'Values get progressively larger.
    'Only the first true condition will exec
    ' ute
  Case Is < (HSLMAX / 6)
    HuetoRGB = (mag1 + (((mag2 - mag1) * Hue + (HSLMAX / 12)) / (HSLMAX / 6)))
  Case Is < (HSLMAX / 2)
    HuetoRGB = mag2
  Case Is < (HSLMAX * 2 / 3)
    HuetoRGB = (mag1 + (((mag2 - mag1) * ((HSLMAX * 2 / 3) - Hue) + (HSLMAX / 12)) / (HSLMAX / 6)))
  Case Else
    HuetoRGB = mag1
End Select
End Function

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread