Excel japanese

Excel

Ivan F Moala

This page was last updated on: March 22, 2009

You are visitor number:

Can Do

Open ANY Program

Change Worksheet Tab Colour:

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.

Get example workbook Here

In the Userform Code;

Private Sub UserForm_Click()

Application.CommandBars.FindControl(ID:=927).Execute

End Sub

Method 2: By Colo

This method was supplied by my good friend Colo. Thankyou Colo

Option Explicit

'---Standard module

Sub Test()

UserForm1.Show

End Sub

Option Explicit

'---Userform1 module

Private Sub CommandButton1_Click()

' If Error message is shown, delete or comment out of following.

CommandButton1.TakeFocusOnClick = False

ActiveCell.Activate

ActiveCell.Value = "What?"

End Sub

'---Userform1 module

Private Sub UserForm_Activate()

With Application

.SendKeys "{esc}", True

.GetOpenFilename

.SendKeys "{esc}", True

End With

End Sub

Visits here

Phoning using Excel:

You can use your micorphone and the Dialer to make a call from within Excel:

Option Explicit

Public Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" ( _

ByVal Dest As String, _

ByVal AppName As String, _

ByVal CalledParty As String, _

ByVal Comment As String) As Long

Sub PhoneCall()

Dim strNumber As String, strName As String

Dim lRetVal As Long

strNumber = "09 2751179"

strName = "Work"

'// Make a voice call using the default call manager application

lRetVal = tapiRequestMakeCall(Trim(strNumber), vbNull, Trim(strName), "")

'// Let the call manager application handle the errors!

End Sub

'// Routine goes in the ThisWorkBook Object

'// Start



Private Sub Workbook_SheetActivate(ByVal Sh As Object)

   ChangeTab_Colour

End Sub



'// End





'// Routine goes into a Standard Module



Option Explicit



'// Routine to change the colour of the Spreadsheet Tabs





'// API's for System Colours

Private Declare Function GetSysColor Lib "user32" ( _

   ByVal nIndex As Long) As Long



Private Declare Function SetSysColors Lib "user32" ( _

   ByVal nChanges As Long, _

   lpSysColor As Long, _

   lpColorValues As Long) As Long



'// Define Colour Constant

Private Const COLOR_WINDOW = 5



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

Option Explicit



'// 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 Scrn Constants

Private Const SM_CXSCREEN = 0



'// Define ComboBox Constants

Private Const CB_SETDROPPEDWIDTH = &H160

Private Const CB_GETDROPPEDWIDTH = &H15F



'// 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