Sub Click(Source As Button)
Dim ui As New NotesUIWorkspace
Dim session As NotesSession
Dim thisdb As NotesDatabase
Dim stream As NotesStream
Dim filename As String
Dim css As String
Dim css1 As String
Dim uidoc As NotesUIDocument
Dim nl As String
Dim f As String
Dim p1 As Integer
Dim p2 As Integer
Dim p3 As Integer
Dim NotesProgDir As String
Dim s As String
Dim L List As String
On Error Goto err1
Set session = New NotesSession
Set thisdb = session.CurrentDatabase
Set stream = session.CreateStream
Set uidoc = ui.currentdocument
nl = Chr$(13) & Chr$(10)
' ==============================
' Get program Dirctory
' ==============================
NotesProgDir = GetRegValue (HKEY_LOCACL_MACHINE , "Software\Lotus\Notes", "Path")
If NotesProgDir="" Then
Messagebox "Cannot find registry entries"
Exit Sub
End If
Print "Notes Program Dir = " & NotesProgDir
' ==============================
' Get notes.css
' ==============================
s = Dir$(NotesProgDir & "framework\shared\eclipse\plugins\com.ibm.notes.branding_3.*", 16)
If s="" Then
Messagebox "Cannot find branding plugin"
Exit Sub
End If
Filename = NotesProgDir & "framework\shared\eclipse\plugins\" & s & "\themes\notes.css"
Print "CSS file = " & filename
If Not stream.Open(filename, "ASCII") Then
Messagebox filename,, "Open failed"
Exit Sub
End If
If stream.Bytes = 0 Then
Messagebox filename,, "File has no content"
Exit Sub
End If
css = stream.ReadText()
Call stream.Close
Print "CSS read: " & Len( css) & " characters"
' ============================================
' create a backup if no backup exists
' ============================================
On Error Resume Next
s = ""
s = Dir$( Filename & ".bak" )
On Error Goto err1
If s="" Then
f = Freefile
Open Filename & ".bak" For Output As f
Print #f,css
Close #f
Print "Backup of notes.css created"
End If
' ===========================================
' here we go to modify the css
' ===========================================
' *** unread messages ***
Erase L
L(0) = "mailtable>row>unread"
L(1)= "mailtable.Inbox>row>unread"
L(2)= "mailtable.Drafts>row>unread"
L(3)= "mailtable.Sent>row>unread"
L(4)= "mailtable.FollowUp>row>unread"
L(5)= "mailtable.AllDocuments>row>unread"
L(6)= "mailtable.Trash>row>unread"
L(7)= "mailtable.Junk>row>unread"
Forall K In L
p1=0
p2=0
p3=0
css1 = ""
p1 = Instr ( 1, css, K, 5 )
If p1>0 Then p2 = Instr ( p1, css, "{" )
If p2>0 Then p3 = Instr ( p2, css, "}" )
If p3>0 Then
css1 = css1 & nl
css1 = css1 & Chr$(9) & "color: #" & Ucase(Right$("000000" & uidoc.fieldGetText( "cUnread"),6)) & ";" & nl
css1 = css1 & Chr$(9) & "font-style: l" & uidoc.fieldGetText( "stUnread") & ";" & nl
If Listtag(K)="0" Then
css1 = css1 & Chr$(9) & "font-family: Tahoma, Times, Helvetica;" & nl
css1 = css1 & Chr$(9) & "font-size: 8pt" & uidoc.fieldGetText( "sUnread") & ";" & nl
css1 = css1 & Chr$(9) & "font-weight: " & uidoc.fieldGetText( "wUnread") & ";" & nl
End If
Print K & " changed"
css = Left$(css, p2) & css1 & Mid$( css, p3)
End If
End Forall
' *** read messages ***
Erase L
L(0) = "mailtable>row>read"
L(1)= "mailtable.Inbox>row>read"
L(2)= "mailtable.Drafts>row>read"
L(3)= "mailtable.Sent>row>read"
L(4)= "mailtable.FollowUp>row>read"
L(5)= "mailtable.AllDocuments>row>read"
L(6)= "mailtable.Trash>row>read"
L(7)= "mailtable.Junk>row>read"
Forall K In L
p1=0
p2=0
p3=0
css1 = ""
p1 = Instr ( 1, css, K, 5 )
If p1>0 Then p2 = Instr ( p1, css, "{" )
If p2>0 Then p3 = Instr ( p2, css, "}" )
If p3>0 Then
css1 = css1 & nl
css1 = css1 & Chr$(9) & "color: #" & Ucase(Right$("000000" & uidoc.fieldGetText( "cRead"),6)) & ";" & nl
css1 = css1 & Chr$(9) & "font-style: " & uidoc.fieldGetText( "stRead") & ";" & nl
If Listtag(K)="0" Then
css1 = css1 & Chr$(9) & "font-family: Tahoma, Times, Helvetica;" & nl
css1 = css1 & Chr$(9) & "font-size: " & uidoc.fieldGetText( "sRead") & ";" & nl
css1 = css1 & Chr$(9) & "font-weight: " & uidoc.fieldGetText( "wRead") & ";" & nl
End If
Print K & " changed"
css = Left$(css, p2) & css1 & Mid$( css, p3)
End If
End Forall
' *** primary selection ***
Erase L
L(0) = "mailtable > row > primarySelection"
L(1)= "mailtable>row>primarySelection"
Forall K In L
p1=0
p2=0
p3=0
css1 = ""
p1 = Instr ( 1, css, K, 5 )
If p1>0 Then p2 = Instr ( p1, css, "{" )
If p2>0 Then p3 = Instr ( p2, css, "}" )
If p3>0 Then
css1 = css1 & nl
css1 = css1 & Chr$(9) & "background-color:" & nl
css1 = css1 & Chr$(9) & Chr$(9) & "#" & Ucase(Right$("000000" & uidoc.fieldGetText( "psCol1"),6)) & nl
css1 = css1 & Chr$(9) & Chr$(9) & "#" & Ucase(Right$("000000" & uidoc.fieldGetText( "psCol2"),6)) & nl
css1 = css1 & Chr$(9) & Chr$(9) & "100%;" & nl
css1 = css1 & Chr$(9) & "color: #" & Ucase(Right$("000000" & uidoc.fieldGetText( "psCol3"),6)) & nl
Print K & " changed"
css = Left$(css, p2) & css1 & Mid$( css, p3)
End If
End Forall
Print "saving css file " & filename
f = Freefile
Open filename For Output As f
Print #f,css
Close #f
Messagebox "Colors have been changed." & nl & "You need to restart Notes"
Exit Sub
err1:
Print "Click(): " & Error$ & " in line " & Erl
Messagebox "Click(): " & Error$ & " in line " & Erl
Exit Sub
End Sub