文章分類: API / Add-in (Emily 分享學習 VBA)

判斷 Excel 單格是否處於編輯狀態 (Determine Excel in Edit Mode)

cat14051 — Sun, 03 Feb 2008 12:17:32 +0800

判斷 Excel 單格是否處於編輯狀態

以下代碼就是當處於編輯狀態時在Excel的狀態欄上顯示 正處於編輯狀態…

The code will display "Excel in edit mode ......" in Status bar if Excel is in edit mode

(閱讀全文)

Automatic Mouse Movement

cat14051 — Thu, 21 Jun 2007 08:19:44 +0800

Automatic Mouse Movement

Worth to read this example: Automatic Mouse Movement on UserForms

I have been using an Excel addin which I had need to automate some procedures overnight. There are a number a userforms which have certain commandbuttons to click. Unfortunately, you cannot access the Command Button click event from external code.
So I searched far and wide for a solution. I found the MouseMove API
routine and adapted it for VBA Userforms.

Mail add-in for Excel

cat14051 — Sat, 03 Mar 2007 02:31:44 +0800

Mail add-in for Excel

Outlook, Outlook Express or Windows Mail

http://www.rondebruin.nl/mail/add-in.htm

MSDN articles: Working with Excel Workbooks and Worksheets in E-Mail

Change Color when Mouse On Cell

cat14051 — Sun, 01 Oct 2006 19:30:08 +0800

Change Color when Mouse On Cell

A nice API code from Ivan F Moala but it will affect Excel performance

(閱讀全文)

INPUTBOX 延遲默認輸入

cat14051 — Thu, 31 Aug 2006 00:29:57 +0800

INPUTBOX 延遲默認輸入

Excel Home 原問題

我的要求是彈出INPUTBOX窗口（此時是空文本框）後，停頓5秒鍾，自動鍵入123。

(閱讀全文)

EXCEL窗口成爲頂層

cat14051 — Mon, 31 Jul 2006 00:12:51 +0800

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call MakeNormal(Application.hwnd)
End Sub

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  :
' Author    :
' Purpose   :
'---------------------------------------------------------------------------------------
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Public Sub MakeNormal(hwnd As Long)
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Public Sub MakeTopMost(hwnd As Long)
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Sub Test()
Call MakeTopMost(Application.hwnd)
' Call MakeNormal(Application.hwnd)
End Sub

如何取得單元格字符串的實際長度

cat14051 — Fri, 07 Jul 2006 17:55:03 +0800

如何取得單元格字符串的實際長度

EH 問題

Option Explicit
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetOEMCP Lib "kernel32" () As Long
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size)
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function FindWindowA Lib "user32" (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 GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Type Size
cx As Long ' 字體的寬度
cy As Long ' 字體的高度
End Type

Sub test1()

MsgBox "字體長度:" & GetFontsWidthHeightA(Range("A1")) & "Pixels"

End Sub

'調查單元格字體的寬度
Private Function GetFontsWidthHeightA(ByVal rng As Range) As Long

     Dim hXLMAIN As Long, hxldc As Long
     Dim objFont As Font
     Dim lpSize As Size, lngSize As Long
     Dim hFont As Long

     Const LOGPIXELSX = 88 '行

     Set objFont = rng.Font

     hXLMAIN = FindWindowA("XLMAIN", vbNullString) 'XLMAIN hwnd
     hxldc = GetDC(hXLMAIN) 'XLMAIN 場景

     lngSize = objFont.Size * (GetDeviceCaps(hxldc, LOGPIXELSX) / 72) '

     hFont = CreateFont(lngSize, 0, 0, 0, 0, 0, 0, 0, _
                  GetOEMCP(), 0, 0, 0, 0, objFont.Name) '創建字體

     SelectObject hxldc, hFont  '裝入

     GetTextExtentPoint32& hxldc, rng.Value, LenB(StrConv(rng.Value, vbFromUnicode)), lpSize '測量

     DeleteObject (hFont) '刪除字體對象
     ReleaseDC hXLMAIN, hxldc '釋放
     GetFontsWidthHeightA = lpSize.cx

End Function

更新請看原文

Easy Filter Add-in

cat14051 — Sat, 01 Jul 2006 17:35:31 +0800

Easy Filter Add-in

Filter Options are on separate tabbed User Interface and options available are:

Equal-Not Equal [Filters for up to five alternative = or <> criteria]
Blanks [Filters for Blanks or non Blanks or Formulas that evaluate to "" or not]
Greater-Less [Filters for >= OR > AND / OR <= OR <]
Begins-Contains-Ends [Ideal for filtering text fields]
Unique-Duplicate [At last an easy way to hunt out uniques and duplicates]
Special [Text searching with wild cards with up to 5 Or / And criteria]
Dates [Not enabled unless you are filtering a field containing dates]
Color [Fill/Font colors (Normal and Conditional Formatting colors) and Bold cells]

Details and download: http://www.rondebruin.nl/easyfilter.htm

Prevent Excel Close

cat14051 — Fri, 26 May 2006 11:14:00 +0800

Prevent Excel Close

'---------------------------------------------------------------------------------------
' Module    : ThisWorkbook
' DateTime  : 26/5/2006 11:12
' Author    :
' Purpose   : Prevent Excel Close
'---------------------------------------------------------------------------------------
' Tested in WinXp + Office 2003

Option Explicit
Private Sub Workbook_Open()
On Error Resume Next
    'Activate the 1st worksheet using the workbooks worksheet index
    Worksheets(1).Activate
    'Or If you want to use the actual worksheet name
    'Worksheets("
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim Msg, Style, Title, Response
Dim MyFlag As Long, Ret As String
'Set ShutDown Constants
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

' Define message.
Msg = "Do you want to continue ?" _
    & vbCr & vbCr & "You are about to exit the excel program." _
    & vbCr & vbCr & "You will need to Reboot Computer" _
    & vbCr & "to restore the program!"
Style = vbYesNoCancel + vbCritical + vbDefaultButton3    ' Define buttons.
Title = "Exiting Program"    ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
'Test the variable Response
Select Case Response
  Case vbYes
    'Save the file, Force Windows Closed
    Me.Save
'   Call Exit_Windows
    Ret = InputBox("Enter Password", "Password Required")
        If Ret = "testing" Then    ' 更改你的密碼
        Ret = InputBox("Exit Excel or Logoff User" _
        & vbCr & " Enter: E or L", "What Action")
        Else
        MsgBox "Invalid Password", vbCritical, "Wrong Password"
        Cancel = False
        Exit Sub
        End If
    If Ret = "E" Or Ret = "e" Then
        Application.Quit
    Else
        If Ret = "L" Or Ret = "l" Then
            SetShutDownPrivilege 'Set the shutdown privilege - else reboot will fail
            ' Always execute a force shutdown if a shutdown is required
            MyFlag = EWX_LOGOFF  'LogOff
            ' Grab the shutdown privilege - else reboot will fail
            SetShutDownPrivilege
            'Do the required action
            Call ExitWindowsEx(MyFlag, 0)
        End If
    End If
  Case vbNo
    Worksheets(1).Activate
    Cancel = True
  Case vbCancel
    Cancel = True
  Case Else
  'Do Nothing
End Select

End Sub

(閱讀全文)

Excel Loader

cat14051 — Wed, 10 May 2006 11:29:49 +0800

Excel Loader

Excel Kb article
Excel Loader is a standalone utility that let the user choose which add-ins should be loaded or not when launching Microsoft Excel.

http://www.excelkb.com/article.aspx?id=10192

API Get Default Printer Name

cat14051 — Sun, 23 Apr 2006 10:44:25 +0800

API Get Default Printer Name

'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 23/4/2006 10:43
' Author    :
' Purpose   : API Get Default Printer Name
'---------------------------------------------------------------------------------------
Private Declare Function GetProfileString Lib "kernel32.dll" Alias "GetProfileStringA" _
        (ByVal lpAppName As String, _
        ByVal lpKeyName As String, _
        ByVal lpDefault As String, _
        ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long
Function Get_DefaultPrinterName() As String
Const BUFFSIZE As Long = 254

Dim strBuffer As String * BUFFSIZE
Dim lngRetVal As Long

    lngRetVal = GetProfileString("windows", "device", ",,,", strBuffer, BUFFSIZE)
    Get_DefaultPrinterName = Left(strBuffer, InStr(strBuffer, ":"))

End Function

参考:Get Printer Port , Printer Status

Clear Window and Office Clipoards

cat14051 — Wed, 12 Apr 2006 13:53:07 +0800

Clear Window and Office Clipoards

請注意兩個 clipboards 是不同的

(閱讀全文)

利用 API 當Excel 閑置時登出電腦

cat14051 — Wed, 11 Jan 2006 21:39:58 +0800

利用 API 當Excel 閑置時登出電腦

' Module
Option Explicit

Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal wReserved&)
Global Const EWX_LOGOFF = 0
Dim IdleTime As Date
Dim Action&

(閱讀全文)

Printer Status

cat14051 — Sat, 07 Jan 2006 12:37:23 +0800

Printer Status

請參看 TechTrax Controlling the Printer from Word VBA , Excel 同樣地可以

例子下載

(閱讀全文)

IE收藏夹中的信息 (2)

cat14051 — Mon, 26 Dec 2005 19:00:21 +0800

IE收藏夹中的信息

以下是 API 方法列出及建立 url

(閱讀全文)