香港新浪網 MySinaBlog
Emily | 31st Jul 2006, 00:12 AM | API / Add-in | (2435 Reads)

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


Emily | 18th Jul 2006, 10:32 AM | WB & WS | (2612 Reads)

如何判斷一個檔案內是否包含宏

 Sub Check_VBA_Exist()
    Dim fd As FileDialog
    Dim FFs As FileDialogFilters
    Dim stFileName As String
    Dim vaItem
    Dim VBC As Object
    Dim HasCode As Boolean
    Dim wb As Workbook
    Set fd = Application.FileDialog(msoFileDialogOpen)
    With fd
        Set FFs = .Filters
        With FFs
            .Clear
            .Add "Excel文件", "*.xls;*.xla"
        End With
        .AllowMultiSelect = True
        If
.Show = -1 Then
            For Each
vaItem In .SelectedItems
                Application.EnableEvents = False
                Application.ScreenUpdating = False
                Set
wb = Workbooks.Open(vaItem)
                HasCode = False

               '  当档案有工程密码是,出错 , amended on 30 Jul 2006

               If wb.VBProject.Protection = 1 Then    ' 判斷vbe是否保護
                    MsgBox "檔案" & Dir(vaItem) & " VBA 專案被鎖定"
                    wb.Close 0
                    
' Exit Sub
                ' End If

               Else

                For Each VBC In wb.VBProject.VBComponents
                    If VBC.Type <> 100 Then
                        HasCode = True: Exit For
                    ElseIf
VBC.CodeModule.CountOfDeclarationLines < VBC.CodeModule.CountOfLines Then
                        HasCode = True: Exit For
                    End If
                Next
                If
HasCode = True Then
                    MsgBox "檔案" & Dir(vaItem) & " 有宏"
                Else
                    MsgBox "檔案" & Dir(vaItem) & " 無宏"
                End If
                wb.Close 0
                Application.EnableEvents = True
                Application.ScreenUpdating = True

            End If
            Next
vaItem
        End If
    End With
End Sub

Ref: http://www.officefans.net/cdb/viewthread.php?tid=39838&extra=page%3D1


Emily | 11th Jul 2006, 23:36 PM | WB & WS | (2047 Reads)

合并格行高

 Private Sub MergeCell_AutoHeight()

Dim snCurrRowH As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim stCell As String

With ActiveCell.MergeArea
    If .Rows.Count = 1 And .WrapText = True Then
        Application.ScreenUpdating = False
        snCurrRowH = .RowHeight
        ActiveCellWidth = ActiveCell.ColumnWidth
        For Each CurrCell In Selection
          MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
        Next
       .MergeCells = False
       .Cells(1).ColumnWidth = MergedCellRgWidth
       .EntireRow.AutoFit
        PossNewRowHeight = .RowHeight
       .Cells(1).ColumnWidth = ActiveCellWidth
       .MergeCells = True
       .RowHeight = IIf(snCurrRowH > PossNewRowHeight, snCurrRowH, PossNewRowHeight)
      End If
End With

End Sub


Emily | 10th Jul 2006, 01:25 AM | WB & WS | (658 Reads)

Almost-Langford numbers

Self-describing numbers: between two digits "d" there are d digits. Almost-Langford numbers have an even number of digits and no two identical pairs of digits.

Please read http://www.research.att.com/~njas/sequences/A108116

Full List in Excel

 (閱讀全文)

Emily | 8th Jul 2006, 12:00 PM | Script | (1818 Reads)

Monitor a Directory for Creation & Deletion of Files

A very impressive topic (WMI) by Ivan F Moala

 

Details: http://www.dailydoseofexcel.com/archives/2006/07/07/monitor-directory/

 


Emily | 7th Jul 2006, 17:55 PM | API / Add-in | (1022 Reads)

 

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

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

更新請看原文


Emily | 1st Jul 2006, 17:35 PM | API / Add-in | (2238 Reads)

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