So Many Spreadsheets

[ZVI]

There is the code for pop-up MS Calc by double clicking on Excel cell with numeric constant value. Other type of cell (date/formula/empty etc) not triggers the Calc. Editing cell is marked by red double lines borders.

The value of the double clicked cell is auto copied into edit textbox of MS Calc and can be used as initial value of calculator. If Calc window closes or loses the focus then MsgBox is appeared with question of applying changed value or not.

This is code for standard VBA-module:

<font face=Courier New>
' ZVI:2009-03-22 Pop-up of Windows Calculator by double clicking.
' All code below should be copied into standard VBA module.
Option Explicit

Type POINTAPI
  x As Long
  y As Long
End Type

Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

Const SM_CXFULLSCREEN = 16
Const SM_CYFULLSCREEN = 17
Const WM_CL0SE = &H10
Const WM_SETTEXT = &HC
Const WM_GETTEXT = &HD
Const WM_GETTEXTLENGTH = &HE
Const HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1

Dim TimerID&, CalcHwnd&, CalcCaption$, EditHwnd&, EditText$
Dim CalcCell As Range, CalcRect As RECT, bls, bci

Sub RunCalc()
  Dim s$
  On Error Resume Next
  s = Str(CDec(ActiveCell.Value) + 0)
  If Err <> 0 Then Exit Sub
  s = s & "="
  StopCalc
  Set CalcCell = ActiveCell
  CalcCaption = CalcCell.Parent.Name & "!" & CalcCell.Address(0, 0)
  Shell "calc", vbNormalFocus
  If Err <> 0 Then MsgBox "Calc.exe not found", vbCritical, "Error": Exit Sub
  CalcHwnd = GetForegroundWindow
  SetPosition
  SetWindowText CalcHwnd, CalcCaption
  EditHwnd = FindWindowEx(CalcHwnd, 0, "Edit", vbNullString)
  SetDoubleBorders
  Application.SendKeys s
  TimerID = SetTimer(0&, 0&, 100&, AddressOf MyTimer)
End Sub

Sub StopCalc()
  Dim v#
  On Error Resume Next
  KillTimer 0&, TimerID: TimerID = 0&
  If CalcHwnd <> 0 Then
    PostMessage CalcHwnd, WM_CL0SE, 0&, 0&
    CalcHwnd = 0
    RestoreBorders
    SaveSetting "ZVI", "Calc", "X", CalcRect.Left
    SaveSetting "ZVI", "Calc", "Y", CalcRect.Top
  End If
  If Len(EditText) = 0 Then Exit Sub
  v = EditText
  If Err <> 0 Then v = Val("&H" & EditText)
  If CStr(v) <> CStr(CalcCell.Value) Then
    If MsgBox("Change the value of " & CalcCaption & " ?" & vbLf _
              & "Old:" & vbTab & CalcCell & vbLf _
              & "New:" & vbTab & v, vbYesNo, CalcCaption) = vbYes _
    Then
      CalcCell.Value = v
    End If
  End If
  Set CalcCell = Nothing
  EditText = ""
End Sub

Private Sub MyTimer(ByVal hWnd&, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTimer&)
  CheckCalc
End Sub

Private Sub CheckCalc()
  On Error Resume Next
  If GetForegroundWindow <> CalcHwnd Then
    If EditText = "" Then EditText = "0"
    StopCalc
  Else
    EditText = Space(SendMessage(EditHwnd, WM_GETTEXTLENGTH, 0&, 0&))
    SendMessage EditHwnd, WM_GETTEXT, Len(EditText) + 1, ByVal EditText
    GetWindowRect CalcHwnd, CalcRect
  End If
End Sub

Private Sub SetPosition()
  Dim pt As POINTAPI
  GetWindowRect CalcHwnd, CalcRect
  pt.x = (GetSystemMetrics(SM_CXFULLSCREEN) - (CalcRect.Right - CalcRect.Left)) / 2
  pt.y = (GetSystemMetrics(SM_CYFULLSCREEN) - (CalcRect.Bottom - CalcRect.Top)) / 2
  pt.x = GetSetting("ZVI", "Calc", "X", Str(pt.x))
  pt.y = GetSetting("ZVI", "Calc", "Y", Str(pt.y))
  SetWindowPos CalcHwnd, HWND_TOPMOST, pt.x, pt.y, 0&, 0&, SWP_NOSIZE
End Sub

Private Sub SetDoubleBorders()
  On Error Resume Next
  With CalcCell.Borders
    bls = .LineStyle
    bci = .ColorIndex
    .LineStyle = xlDouble
    .ColorIndex = 3
  End With
End Sub

Private Sub RestoreBorders()
  On Error Resume Next
  With CalcCell.Borders
    .LineStyle = bls
    .ColorIndex = bci
  End With
End Sub</FONT>

The code of ThisWorbook (class) module for double click triggering:

<font face=Courier New>
' Code of ThisWorbook VBA (class) module
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim i&
  On Error Resume Next
  If Target.HasFormula Then Exit Sub
  i = VarType(Target.Value)
  If (i < vbInteger Or i > vbCurrency) And i <> vbDecimal Then Exit Sub
  Cancel = True
  RunCalc
End Sub</FONT>

Make the Boss happy,
Vladimir

 

[ZVI]

For working in all workbooks the code of ThisWorkbook module should be like this:

<font face=Courier New>
' XLA solution
' Code of ThisWorbook VBA (class) module for working with all workbooks
Public WithEvents App As Application

Private Sub App_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim i&
  On Error Resume Next
  If Target.HasFormula Then Exit Sub
  i = VarType(Target.Value)
  If (i < vbInteger Or i > vbCurrency) And i <> vbDecimal Then Exit Sub
  Cancel = True
  RunCalc
End Sub

Private Sub Workbook_Open()
  Set App = Application
End Sub</FONT>

The workbook with such code can be saved as XLA for using as AddIn

 

[Long Nose]

I see coworkers spending most of their day banging out numbers on a calculator and running back and forth to our one centrally located printer. Yes, they have excel.

I must look like a total slacker because I rarely print anything. Perhaps I should start printing something?

 

[NateO]

I must look like a total slacker because I rarely print anything. Perhaps I should start printing something?

Save the planet - go paperless!

 

[texasalynn]

I see coworkers spending most of their day banging out numbers on a calculator and running back and forth to our one centrally located printer. Yes, they have excel.

I must look like a total slacker because I rarely print anything. Perhaps I should start printing something?

Or do like most users and print before checking the layout and end up printing pages with a single column, or many blank pages.

 

[NateO]

Or do like most users and print before checking the layout and end up printing pages with a single column, or many blank pages.

I do that from time to time...

 

[schielrn]

Save the planet - go paperless!

Don't listen to this, you should print hard copies of everything Its not like I work for a paper company or anything.

 

[Long Nose]

Don't listen to this, you should print hard copies of everything Its not like I work for a paper company or anything.

You don't also run a turnip farm with your brother, do you?

 

[SydneyGeek]

I don't print much. Maybe a ream every 6 months -- pretty well everything else is electronic (but in multiple backups). The downside is, when the desks get reorganised I'm the one who moves because it's easy to do...

Denis

 

[Andrew Fergus]

Oh dear - the other day I was asked to 'corporatise' a graph. I took this to mean that I need to make it prettier and in the process obfuscate the meaning and intention of the graph. Why or why are people stuck on the appearance of something and not the content?????