The following code is just for show, have a look below;
If someone tells you you cannot colour Excel97 / 2000 Tabs (Version < Xp > 95) then show them this. Note it is not for practical use, just an example of using the system colors.
Sub ChangeTab_Colour()
Dim Kolor As Long
Dim CurKolor As Long
Dim R As Integer, G As Integer, B As Integer
'// Initialize random-number generator.
Randomize
'// Generate random value between 0 and 255.
R = Int(255 * Rnd)
G = Int(255 * Rnd)
B = Int(255 * Rnd)
'// Try these if you want Basic Colours
'// ===============================================
'// Black 0 0 0 || Blue 0 0 255
'// Green 0 255 0 || Cyan 0 255 255
'// Red 255 0 0 || Magenta 255 0 255
'// Yellow 255 255 0 || White 255 255 255
'// ===============================================
CurKolor = GetSysColor(COLOR_WINDOW)
With Application
.ScreenUpdating = False
'// color it Randomly
Kolor = SetSysColors(1, COLOR_WINDOW, RGB(R, G, B))
ShSet
.ScreenUpdating = True
MsgBox "Tab colour has changed!", vbInformation + vbSystemModal, _
"Tab Colour Hack "
.ScreenUpdating = False
ShReset
'// Restore to Default
Kolor = SetSysColors(1, COLOR_WINDOW, CurKolor)
.ScreenUpdating = True
End With
End Sub
Sub ShSet()
Dim x As Double
Cells.Select
With Selection
.Interior.ColorIndex = 2
.Interior.Pattern = xlSolid
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
End With
For x = 7 To 12
With Selection.Borders(x)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
Next
[A1].Select
End Sub
Sub ShReset()
Cells.Select
With Selection
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = xlNone
End With
[A1].Select
End Sub
'// Set up the API's
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function FindWindowA Lib "user32" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
'// Define Message
Private Const msg As String = "Could NOT set the NameBox width!"
'// Define some Class Constants
Private Const strDropBtnClass As String = "ComboBox" 'Name Box Class
Private Const strXLClass As String = "XLMAIN" 'Main Xl Window Class
Private Const strXLChildClass As String = "EXCEL;" 'FormulaBar Class
Public Sub ReSizeNameBoxWidth()
'//////////////////////////////////////////////////////
'// Resize the Excel Name Box [ComboBox dropdown width]
'// Developement Enviroment:
'// : Excel2000 / Win 98
'// Created by Ivan F Moala 15th September 2002
'// Tests:
'// Tested Excel XP and XL2000 on WinMe
'// By Juan Pablo G.
'// MrExcel.com Consulting
'// Tom Utis
'// Tested XL 2002 on Windows 2000 SP-3
'// Windows Me - Swedish
'// Windows 2000 - Swedish SP-3
'// Windows XP - Swedish
'// Excel -versions:
'// XL 97 SR2b - Swedish
'// XL 2000 SP-1 - Swedish
'// XL 2002 SP-2 - English / Swedish.
'// Testresult: No error reported
'// Wishlist:
'// That the namebox lenght adjust automatically to the longest used named.
'// By XL Dennis
'//////////////////////////////////////////////////////
Dim hwndXl As Long '// Child window that contains combobox
Dim xlMain As Long '// Xl Window handle
Dim hwndcbo As Long '// Handle of Name Box dropdown
Dim lSetWidth As Long '// setting for new width
Dim lScrnWidth As Long '// Screen Width
Dim Ret As Long '// Return Function success variable
'// Get Xls handle ie. Main Wnd
xlMain = FindWindowA(strXLClass, vbNullString)
'// Get Child Wnd
hwndXl = FindWindowEx(xlMain, 0, strXLChildClass, vbNullString)
'// NOW Get Handle of the Name Box
hwndcbo = FindWindowEx(hwndXl, 0, strDropBtnClass, vbNullString)
lScrnWidth = GetSystemMetrics(SM_CXSCREEN)
'// Currently set @ 1/2 Screen width
'// Change as required
'// Yes I know I should probably set it to the Max Width of the Text!
'// But thats another prgming effort!
lSetWidth = lScrnWidth / 2
Ret = SendMessage(hwndcbo, CB_SETDROPPEDWIDTH, lSetWidth, 0)
If Ret = 0 Then MsgBox msg, vbInformation
End Sub
Option Explicit
Private Declare Function HtmlHelp Lib "hhctrl.ocx" _
Alias "HtmlHelpA" ( _
ByVal hwndCaller As Long, _
ByVal pszFile As String, _
ByVal uCommand As Long, _
ByVal dwData As Long) As Long
'// Some constants to use
Const HH_DISPLAY_TOPIC = &H0
Const HH_SET_WIN_TYPE = &H4
Const HH_GET_WIN_TYPE = &H5
Const HH_GET_WIN_HANDLE = &H6
Const HH_DISPLAY_TEXT_POPUP = &HE
'// Display string resource ID or text in a pop-up window.
Const HH_HELP_CONTEXT = &HF
'// Display mapped numeric value in dwData.
Const HH_TP_HELP_CONTEXTMENU = &H10
'// Text pop-up help, similar to WinHelp's HELP_CONTEXTMENU.
Const HH_TP_HELP_WM_HELP = &H11
'// Text pop-up help, similar to WinHelp's HELP_WM_HELP.
Const HH_CLOSE_ALL = &H12
Sub OpenHelp()
Dim hwndHelp As Long
'// The returned value is the window handle of the created help window.
hwndHelp = HtmlHelp(0, "C:\WINDOWS\HELP\msoe.chm", HH_DISPLAY_TOPIC, 0)
If hwndHelp = 0 Then MsgBox "Can't load"
End Sub
Sub CloseHelp()
HtmlHelp 0, "", HH_CLOSE_ALL, 0
End Sub
Sub Tester()
'// Display Alerts DOES NOT Work
With Application
.DisplayAlerts = False
ActiveWorkbook.FollowHyperlink _
Address:="C:\WINDOWS\HELP\msoe.chm", NewWindow:=True
.DisplayAlerts = True
End With
End Sub
![Goto Guest book sign in page [Home]](files/guestbk.gif)
