香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 7th Jul 2006, 17:55 PM | API / Add-in | (1023 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

更新請看原文


[1]

按理说如果取得字符的长度,就可以知道自动换行的行数...但总是差一些...这是为什么
http://www.officefans.net/cdb/viewthread.php?tid=64425&extra=page%3D3


[引用] | 作者 homt398 | 6th Aug 2006 14:57 PM | [舉報垃圾留言]