Hỏi về Font chữ: Làm sao biết được FileName khi cho trước FontName?

Chia sẻ bởi:hands

★★★★★

‹ Chập chững đến VBA! Code ứng dụng: Gõ TCVN3 sheet này,... ›

Quảng cáo

Giả sử trong 1 cell tôi định dạng font chữ Arial, tức FontName của nó là Arial —> Vậy có code gì có thể biết được Font này có tên file là ARIAL.TTF hay không?
Nói tóm lại: Cho trước FontName, làm sao biết được FileName?

Có nhiều cách để làm việc này nhưng công cụ quan trọng nhất không thể thiếu được đó là Registry. Tôi xin giới thiệu với bác một cách làm ví dụ nhé:
1. Bổ sung các hàm API để đọc được System Registry.
2. Xác định phiên bản hệ điều hành.
3. Truy vấn khu vực lưu trữ Font trong Registry và kiểm chứng tên Font.
Cách này còn phải hoàn thiện khá nhiều nhưng nhìn chung mọi người đều phải làm thế thì sẽ biết được tên thật của tập tin chứa Font chữ.
Option Explicit
' This part is for registry creator
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_CURRENT_CONFIG = &H80000004

Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259

Private Const KEY_READ = &H20019
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_MULTI_SZ = 7
Private Const ERROR_MORE_DATA = 234

Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long

'=============================================
' Registry read and write
'———————————————
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
Dim lValue As Long
Dim sValue As String

Select Case lType
Case REG_SZ
sValue = vValue
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
Case REG_DWORD
lValue = vValue
SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
End Select
End Function

Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

On Error GoTo QueryValueExError
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5

Select Case lType
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
lrc = -1
End Select

QueryValueExExit:
QueryValueEx = lrc
Exit Function

QueryValueExError:
Resume QueryValueExExit

End Function

Private Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
' Description:
' This Function will return the data field of a value
Dim lRetVal As Long
Dim hKey As Long
Dim vValue As Variant
lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function

' Just a help to retrieve physical file name of a font with its screen name and type

Function GetFontFile(XFontName As String, XFontBold As Boolean, XFontItalic As Boolean)
' [HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows NTCurrentVersionFonts]
' First we should have to build the correct font registry key so that reading can be done
' Second query the key and return value.
' Just read registry key
'TrueType,Bold Italic
Dim tRet As String

If XFontBold Then XFontName = XFontName & " Bold"
If XFontItalic Then XFontName = XFontName & " Italic"
XFontName = XFontName & " (TrueType)"
tRet = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWAREMicrosoftWindows NTCurrentVersionFonts", XFontName)
GetFontFile = tRet
End Function

Sub Test()
Debug.Print GetFontFile("Verdana", True, True)
End Sub

Hi vọng có thể giúp bác được phần nào

Học được 1 chiêu mới cho font.
Hỏi thêm paulsteigel 2 câu :
1. Hàm GetFontFile có font ra kết quả, còn có font thì không được (như Tahoma, Ariston) ?
2. Làm sao biết được trong bảng tính sử dụng mấy font ? Tên các font đó ?

Từ FileName xác định FontName khá đơn giản, không ngờ làm điều ngược lại rắc rối đến thế!
Cảm ơn paulsteigel –> Để tôi nghiên cứu xem

————————

Xin trả lời bác như thế này:
1. Có thể lấy được một số còn một số khác sai vì chuỗi đăng ký tên font của ta bị sai (bác xem thứ tự của các ký hiệu, Bold, Italic …). Em giới thiệu để làm ví dụ thôi, còn nếu muốn làm để nó chạy ngon thì dùng thêm một số thủ tục để loại bỏ các cách kết hợp sai hoặc tìm trong toàn bộ registry chứa Font để tìm tên Font cho đúng.
2. Câu hỏi của bác có thể làm theo cách đơn giản dưới đây ạ (em cũng chỉ làm ví dụ thôi ạ).
Function CountFontUsed() As String
Dim ws As Worksheet, theFont As String, cl As Object, rng As Range
For Each ws In Worksheets
Set rng = ws.UsedRange
For Each cl In rng.Cells
' check the used font to avoid duplication
If InStr(theFont, cl.Font.Name) <= 0 Then
theFont = cl.Font.Name & "/" & theFont
End If
Next cl
Next ws
' Now break the string into array and get number of font used
Dim myFontArray As Variant
myFontArray = Split(theFont, "/")
theFont = Left(theFont, Len(theFont) – 1)
CountFontUsed = "There is/are: " & UBound(myFontArray) & " fonts (" & Replace(theFont, "/", ", ") & ") used in this workbook!"
End Function
Bổ sung thêm phần của bác ndu
À, câu hỏi của bác thì lại liên quan đến danh sách font hợp lệ đã được Wíndow đăng ký. Quả thật, logic cũng khá đơn giản:
+ Từ tập tin thì có thể đọc chính tập tin là ra font name.
+ Từ font name thì lại phải xem nó đã được đăng ký vào sổ sách của Windows ra sao rồi mới quay ra xem địa chỉ tập tin ở chỗ nào.
Với Windows XP thì bác xem khóa
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts]thì thấy rõ điều này.
Thêm nữa, nếu bác xuất Registry này ra thì cũng thấy cấu trúc của thẻ lưu font.
"Roman (All res)"="ROMAN.FON"
"Script (All res)"="SCRIPT.FON"
"Modern (All res)"="MODERN.FON"
"Small Fonts (VGA res)"="SMALLE.FON"
"Arial (TrueType)"="ARIAL.TTF" Hy vọng giúp đựoc gì đó cho bác.

Đếm font ta dùng Dictionary Object sẽ ngon ăn hơn rất nhiều… Khỏi nối chuổi, khỏi Split gì cả, kiểu vầy:

Function CountFontUsed() As String
Dim ws As Worksheet, Clls As Range, Dic
Application.Volatile
On Error Resume Next
Set Dic = CreateObject("Scripting.Dictionary")
For Each ws In Worksheets
For Each Clls In ws.UsedRange.Cells
Dic.Add Clls.Font.Name, ""
Next Clls
Next ws
CountFontUsed = "There is/are: " & Dic.Count & " fonts (" & Join(Dic.Keys, ", ") & ") used in this workbook!"
End Function

Cảm ơn bác về việc dùng Dictionary object, cái này thì rất hay và mạnh, đặc biệt trong mảng nhiều chiều và thao tác tìm kiếm, sort.
Cái em vừa làm thì chỉ nhằm đếm phân biệt (distinctive count)
Và mục tiêu cuối chỉ để làm ra câu hỏi của bác long thôi ạ.
Cách đó là các hơi củ chuối nhưng không cần dùng đến món scripting object.
Cám ơn bác đã chỉ giáo ạ!

www.giaiphapexcel.com/diendan/threads/h%E1%BB%8Fi-v%E1%BB%81-font-ch%E1%BB%AF-l%C3%A0m-sao-bi%E1%BA%BFt-%C4%91%C6%B0%E1%BB%A3c-filename-khi-cho-tr%C6%B0%E1%BB%9Bc-fontname.28046/#post-189658