Cấp của object font

  • Thread starter adam_tran
  • Ngày gửi
adam_tran

adam_tran

Steel Partner
17/5/05
1,373
32
48
41
Goooogle
#1
Hi All,
Tớ muốn in ra tất cả các font hiện có trong máy đúng với định dạng của nó.
Tớ viết thủ tục như sau:
Sub PrintFontList()

Dim Font as Font
For each Font in .....
'Đến đây thì chịu vì font hierachy thuộc windows, tức là parent của object application. Không biết refer nó bằng cách nào, thử Application.Parent.Fonts cũng không được!

Please help!
 
T

the7habitsman

Thành viên sơ cấp
10/9/05
89
0
0
Hà nội
#2
Using Screen object

'**************************************
' Name: ^ Font Properties ^
' Description: This little coding lets the
' user see how many fonts they have and
' what they can do with it.
' By: AnyOneYouWant
'
' Inputs:
'- Items Needed:
'- 3 - CommandButtons (Command1, Command2, Command3)
'- 1 - Listbox (List1)
'- 1 - Label (Label1)
'**************************************

Private Sub Command1_Click()

'- Declares the variables
Dim NUM As Single
Dim x As Single
'- gets the numbers of fonts you have
NUM = Screen.FontCount
'- Set the listbox properties
'- Set List1, Sorted = True
'- Goes from 1 to number of fonts

For x = 1 To NUM
List1.AddItem Screen.Fonts(x)
Next x

'- for some reason there will be a blank
' itme
'- this removes it
List1.RemoveItem (0)
'- Displays the number of fonts
Label2.Caption = List1.ListCount
End Sub

Private Sub Command2_Click()

'- Makes sure that there are fonts to choose from

If List1.ListCount <> 0 Then
'- this makes the fonts watever you select from
'- the listbox
Label1.Font = List1.Text
Else
MsgBox "you have To choose the fonts first"
End If

End Sub


Private Sub Command3_Click()

'- Makes sure that there are fonts to choose from

If List1.ListCount <> 0 Then
'- Declares the variables
Dim Size As Single
'- lets it inputbox get the font size
'- Makes it a value
Size = Val(InputBox("Enter the font size"))
Label1.FontSize = Val(Size)
Else
MsgBox "you have To choose the fonts first"
End If

End Sub


Private Sub Form_Load()
'- Sets the captions of the buttons
Command1.Caption = "Get Fonts"
Command2.Caption = "Apply Fonts"
Command3.Caption = "Get Fonts Size"
End Sub
 
adam_tran

adam_tran

Steel Partner
17/5/05
1,373
32
48
41
Goooogle
#3
7habitsman nói:
NUM = Screen.FontCount
Cám ơn tiền bối nhiều, nhưng hình như VBA của Excel không support object "Screen"! Object "Font" của VBA có thể là Property/sub-object của Range, Textbox, label etc... Nhưng em muốn refer đến object Font của Windows cơ. :wall:
The top hierachy object của Excel là Excel hay là Application, muốn refer đến 1 object ngoài Excel hình như phải... đọc thêm nhiều nữa thì phải, cuốn Dummies thôi chưa đủ!
 
T

the7habitsman

Thành viên sơ cấp
10/9/05
89
0
0
Hà nội
#4
Thế thì bó tay (ko biết Excel mà). Chịu khó ngâm cứu API đi nhé
 
L

levanduyet

Welcome
16/10/04
535
11
18
HCM
my.opera.com
#5
adam_tran nói:
Hi All,
Tớ muốn in ra tất cả các font hiện có trong máy đúng với định dạng của nó.
Tớ viết thủ tục như sau:
Sub PrintFontList()

Dim Font as Font
For each Font in .....
'Đến đây thì chịu vì font hierachy thuộc windows, tức là parent của object application. Không biết refer nó bằng cách nào, thử Application.Parent.Fonts cũng không được!

Please help!
Adam à, em chịu khó tìm trên internet. Anh không nhớ rõ, hình như anh đã thấy ở đâu rồi thì phải. Có cả định dạng font luôn.
LVD
 
D

dongho_cat

Thành viên thân thiết
2/7/05
213
2
18
Vỉ tuyến 17
#6
Giúp em với!

Các bác có thể tạo giúp em đoạn chương trình tự động chuyển đổi dữ liệu từ dạng số sang dạng chử với được không ạ. Em cứ mày mò mải mà chẳng biết nó bị sai đoạn nào nửa(Em đang tự mày mò VBA nên cũng khập khiểng quá).
Chân thành cảm ơn các bác.
 
Secret_grasses

Secret_grasses

Thành viên sơ cấp
#7
dongho_cat nói:
Các bác có thể tạo giúp em đoạn chương trình tự động chuyển đổi dữ liệu từ dạng số sang dạng chử với được không ạ. Em cứ mày mò mải mà chẳng biết nó bị sai đoạn nào nửa(Em đang tự mày mò VBA nên cũng khập khiểng quá).
Chân thành cảm ơn các bác.
Bạn link theo đường dẫn này và dowload về nhé:http://webketoan.com/thuvien/index.php?subcat=23&PHPSESSID=dd8e50de65c4d826f408b58c6d6beb6a
 
L

levanduyet

Welcome
16/10/04
535
11
18
HCM
my.opera.com
#8
dongho_cat nói:
Các bác có thể tạo giúp em đoạn chương trình tự động chuyển đổi dữ liệu từ dạng số sang dạng chử với được không ạ. Em cứ mày mò mải mà chẳng biết nó bị sai đoạn nào nửa(Em đang tự mày mò VBA nên cũng khập khiểng quá).
Chân thành cảm ơn các bác.
Bạn nên download ASAP về sài hay lắm.
http://www.asap-utilities.com/
Thân,

Lê Văn Duyệt
 
W

workman

Thành viên sơ cấp
22/7/05
372
0
0
46
Ho Chi Minh
#9
levanduyet nói:
Adam à, em chịu khó tìm trên internet. Anh không nhớ rõ, hình như anh đã thấy ở đâu rồi thì phải. Có cả định dạng font luôn.
LVD
Adam ơi,

Cấp của font là control. Em làm thử cái này nhé

Sub ShowInstalledFonts()
Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
fontSize = 0
fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12, , , , , 1)
If fontSize = 0 Then Exit Sub
If fontSize < 8 Then fontSize = 8
If fontSize > 30 Then fontSize = 30
Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
' If Font control is missing, create a temp CommandBar
If FontNamesCtrl Is Nothing Then
Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
msoBarFloating, False, True)
Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
End If
Application.ScreenUpdating = False
fontCount = FontNamesCtrl.ListCount
Workbooks.Add
' list font names in column A and font example in column B
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
Cells(i + StartRow, 1).Formula = fontName
With Cells(i + StartRow, 2)
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(xlCountrySetting) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
.Formula = tFormula
.Font.Name = fontName
End With
Next i
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
' add heading
Columns(1).AutoFit
With Range("A1")
.Formula = "Installed fonts:"
.Font.Bold = True
.Font.Size = 14
End With
With Range("A3")
.Formula = "Font Name:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B3")
.Formula = "Font Example:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B" & StartRow & ":B" & _
StartRow + fontCount)
.Font.Size = fontSize
End With
With Range("A" & StartRow & ":B" & _
StartRow + fontCount)
.VerticalAlignment = xlVAlignCenter
End With
Range("A4").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
ActiveWorkbook.Saved = True
End Sub


Sưu tập từ: http://www.exceltip.com
 
L

levanduyet

Welcome
16/10/04
535
11
18
HCM
my.opera.com
#10
workman nói:
Adam ơi,

Cấp của font là control. Em làm thử cái này nhé

Sub ShowInstalledFonts()
Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
fontSize = 0
fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
"Select Sample Font Size", 12, , , , , 1)
If fontSize = 0 Then Exit Sub
If fontSize < 8 Then fontSize = 8
If fontSize > 30 Then fontSize = 30
Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
' If Font control is missing, create a temp CommandBar
If FontNamesCtrl Is Nothing Then
Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
msoBarFloating, False, True)
Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
End If
Application.ScreenUpdating = False
fontCount = FontNamesCtrl.ListCount
Workbooks.Add
' list font names in column A and font example in column B
For i = 0 To FontNamesCtrl.ListCount - 1
fontName = FontNamesCtrl.List(i + 1)
Application.StatusBar = "Listing font " & _
Format(i / (fontCount - 1), "0 %") & " " & _
fontName & "..."
Cells(i + StartRow, 1).Formula = fontName
With Cells(i + StartRow, 2)
tFormula = "abcdefghijklmnopqrstuvwxyz"
If Application.International(xlCountrySetting) = 47 Then
tFormula = tFormula & "æøå"
End If
tFormula = tFormula & UCase(tFormula)
tFormula = tFormula & "1234567890"
.Formula = tFormula
.Font.Name = fontName
End With
Next i
Application.StatusBar = False
If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
Set FontCmdBar = Nothing
Set FontNamesCtrl = Nothing
' add heading
Columns(1).AutoFit
With Range("A1")
.Formula = "Installed fonts:"
.Font.Bold = True
.Font.Size = 14
End With
With Range("A3")
.Formula = "Font Name:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B3")
.Formula = "Font Example:"
.Font.Bold = True
.Font.Size = 12
End With
With Range("B" & StartRow & ":B" & _
StartRow + fontCount)
.Font.Size = fontSize
End With
With Range("A" & StartRow & ":B" & _
StartRow + fontCount)
.VerticalAlignment = xlVAlignCenter
End With
Range("A4").Select
ActiveWindow.FreezePanes = True
Range("A2").Select
ActiveWorkbook.Saved = True
End Sub


Sưu tập từ: http://www.exceltip.com
Sao tôi thử thì báo lổi tại dòng in đậm trên?
LVD
 
W

workman

Thành viên sơ cấp
22/7/05
372
0
0
46
Ho Chi Minh
#11
levanduyet nói:
Sao tôi thử thì báo lổi tại dòng in đậm trên?
LVD
Tôi thử thì thấy chạy vù vù, ra một đống font trong excel, không thấy báo lỗi gì cả.

Bác Duyệt đừng chạy trực tiếp trên VBA mà chịu khó bấm Atl+F8 từ Excel thử xem. Tôi dốt VBA lắm, chỉ xài đồ chùa thôi nên vụ này tôi chịu chết không giúp gì được.
 
Sửa lần cuối:
adam_tran

adam_tran

Steel Partner
17/5/05
1,373
32
48
41
Goooogle
#12
levanduyet nói:
Sao tôi thử thì báo lổi tại dòng in đậm trên?
LVD
Em nghỉ mỗi font thường có 4 dạng: Regular, Bold, Italic, Bold+Italic nhưng không phải tất cả các font đều có đủ 4 dạng này. Thí dụ Arial Black không có font Bold, em chưa đọc code nhưng phải chăng nó lỗi chỗ này?
Hà hà, giải thuật này "móc" font từ toolbar ra, xem font như là 1 item của fontname button... Thế mà mình không nghĩ ra nhỉ!
 
T

the7habitsman

Thành viên sơ cấp
10/9/05
89
0
0
Hà nội
#13
System Font List Using API

'**************************************
' Name: VNUNI's System Font List
' Description: Function To Get The System
' Font List. Just Place A ListBox In The Form
'
' By: The7Habits
'
'**************************************

'=========This Goes In A Module=========
'

Public Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hdc As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, lParam As Any) As Long

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Const TmPF_FIXED_PITCH = &H1
Public Const TmPF_TRUETYPE = &H4
Public Const RASTER_FONTTYPE = &H1
Public Const TRUETYPE_FONTTYPE = &H4
Public ShowFontType As Integer
Public SelectedFont As String
Public SelectedStyle As String
Public SelectedSize As Integer
Public fUnderline As Boolean
Public fStrikethru As Boolean
Public Const Lf_FACESIZE = 32


Type LOGFONT
LfHeight As Long
LfWidth As Long
LfEscapement As Long
LfOrientation As Long
LfWeight As Long
LfItalic As Byte
LfUnderline As Byte
LfStrikeOut As Byte
LfCharSet As Byte
LfOutPrecision As Byte
LfClipPrecision As Byte
LfQuality As Byte
LfPitchAndFamily As Byte
LfFaceName(Lf_FACESIZE) As Byte
End Type

Type NEWTEXTMETRIC
TmHeight As Long
TmAscent As Long
TmDescent As Long
TmInternalLeading As Long
TmExternalLeading As Long
TmAveCharWidth As Long
TmMaxCharWidth As Long
TmWeight As Long
TmOverhang As Long
TmDigitizedAspectX As Long
TmDigitizedAspectY As Long
TmFirstChar As Byte
TmLastChar As Byte
TmDefaultChar As Byte
TmBreakChar As Byte
TmItalic As Byte
TmUnderlined As Byte
TmStruckOut As Byte
TmPitchAndFamily As Byte
TmCharSet As Byte
NTmFlags As Long
NTmSizeEM As Long
NTmCellHeight As Long
NTmAveWidth As Long
End Type

Private Function EnumFontFamTypeProc(LFont As LOGFONT, Ntm As NEWTEXTMETRIC, ByVal FontType As Long, lParam As ListBox) As Long

Dim FontFaceName As String

If ShowFontType = FontType Then
FontFaceName = StrConv(LFont.LfFaceName, vbUnicode)
lParam.AddItem Left(FontFaceName, InStr(FontFaceName, vbNullChar) - 1)
End If
EnumFontFamTypeProc = 1

End Function


Public Sub GetFontList(oListBox As ListBox)
oListBox.Clear
ShowFontType = 4
EnumFontFamilies GetDC(oListBox.hwnd), vbNullString, AddressOf EnumFontFamTypeProc, oListBox
End Sub

'=========This Goes In A Form=========
'
Private Sub Form_Load()
GetFontList List1
End Sub


Is it easy to understand for all of you?

Hope this helps!

P/S 1: In VB, there is one more way as I mentioned earlier:

Function AddFontsList(oList As ListBox)

For x = 0 To Screen.FontCount - 1
oList.AddItem Screen.Fonts(x)
Next x

End Function

P/S 2: Khi comment cho code, mình tự nhiên lại có thói quen ko thể bỏ đi được, đó là phải comment = tiếng anh. Đó là 1 trong các rules mình đặt ra từ hồi mới bắt đầu biết lập trình. (mình copy từ các đoạn code của mình trước kia mà). Mong các bạn thông cảm nhé.

P/s 3: Với APIs, bạn có thể install a font in WIN16/WIN32 (Add Font), có thể Adjust for screen font size, Change System (Message, Menu, Caption) Fonts, v.v... Nói tóm lại là khi đã master 1 cái gì đó rồi, nhiều khi bạn có thể làm rất nhiều thứ với kỹ năng & kinh nghiệm của bạn. (Một vài ví dụ nhỏ: Bắt các text trên mọi window y như Click & See hay Lạc Việt từ điển, Hook KeyBoard như các phần mềm gõ tiếng việt, làm các giao diện trở nên cực kỳ đẹp như (thậm chí hơn) đồ của Microsoft, thậm chí, với 1 listbox control, chỉ cần vài APIs là biến nó thành 1 windows đầy đủ (có titlebar, sysmenu, min, max, close buttons và v + h scrollbars,...). Đặc biệt, bạn có thể nhúng code ASM trong VB để làm nhiều điều ko tưởng khác...
 
Sửa lần cuối:
T

Tuanktcdcn

Lão già ham vui
18/6/04
548
51
28
41
Hà Nội
www.bluesofts.net
#14
Code trên chỉ chạy trong VB thôi, trong VBA ngoài Form ra thì các Control trong bộ FM20.DLL không có Hwnd nên các bạn phải sửa lại một số dòng lệnh thì mới chạy được.
 
S

StonyHeartedMan

Thành viên sơ cấp
2/10/04
306
2
0
Hà nội
www.vnuni.net
#15
He he, M$ ... "đểu" thật. Đúng là M$ ko muốn các nhà sử dụng MS Application thâm nhập sâu vào các objects của nó nên nó Private cái Hwnd của bộ controls Form 2.0 này đi. Có lẽ chính vì thế mà FM20.DLL là công cụ chỉ đi kèm để phục vụ bộ MS Office. (Thế mà bộ này lại hỗ trợ Unicode trong khi đó các Controls chuẩn của VB lại ko support Unicode nên cứ phải dùng thêm APIs để Unicode hóa các VB controls)
 
L

levanduyet

Welcome
16/10/04
535
11
18
HCM
my.opera.com
#16
Thực sự ra có lúc được lúc không??? Không hiểu tại sao??? Chắc phải hỏi bác Bill.
Tôi đã debug nhiều lần rồi cứ một lần được một lần k!
Có ai cao kiến gì k?
Thân,
LVD
workman nói:
Tôi thử thì thấy chạy vù vù, ra một đống font trong excel, không thấy báo lỗi gì cả.

Bác Duyệt đừng chạy trực tiếp trên VBA mà chịu khó bấm Atl+F8 từ Excel thử xem. Tôi dốt VBA lắm, chỉ xài đồ chùa thôi nên vụ này tôi chịu chết không giúp gì được.
 
W

workman

Thành viên sơ cấp
22/7/05
372
0
0
46
Ho Chi Minh
#17
levanduyet nói:
Thực sự ra có lúc được lúc không??? Không hiểu tại sao??? Chắc phải hỏi bác Bill.
Tôi đã debug nhiều lần rồi cứ một lần được một lần k!
Có ai cao kiến gì k?
Thân,
LVD
Hà hà, cao thủ như bác Duyệt mà còn không hiểu thì ai mà giải thích được. Thôi thì mỗi lần nó báo lỗi cứ "chửi đổng" bác Bill ... cũng nguôi giận phần nào. hì hì :) :banana:
 
H

hoxulee

Thành viên sơ cấp
25/6/05
16
0
0
42
Vietnam
#18
StonyHeartedMan nói:
He he, M$ ... "đểu" thật. Đúng là M$ ko muốn các nhà sử dụng MS Application thâm nhập sâu vào các objects của nó nên nó Private cái Hwnd của bộ controls Form 2.0 này đi. Có lẽ chính vì thế mà FM20.DLL là công cụ chỉ đi kèm để phục vụ bộ MS Office. (Thế mà bộ này lại hỗ trợ Unicode trong khi đó các Controls chuẩn của VB lại ko support Unicode nên cứ phải dùng thêm APIs để Unicode hóa các VB controls)
Tôi thì quan tâm làm cách nào để in có chọn lọc char của một unicode font, chẳng hạn Times New Roman? Để từ đó lọc ra các ký tự tiếng Việt, thêm một vài symbol và quan trọng là char code của nó.
Nếu cho chạy:

For i = 0 to 65535
Cells(i,1)= i
Cells(i,2) = CharW(i)
Next

thì có mà oải, vì quá nhiều và nó hiện ra rất nhiều ô vuông (chỉ ra char code này chưa có ký tự), vấn đề của tôi là làm sao xác định nó để không in ra nó.
Còn tham khảo trong charmap, phần group by unicode subrange thì thủ công quá, mặc khác chữ lại nhỏ khó xem, xác định char code của từng cái thì tết mới xong.

Đôi lời về VBA và MSForm2 của MS:
VBA quả thật là lợi hại, nó có trong tất cả mọi phần mềm thông dụng, như bộ Office, AutoCAD, thậm chí cả trong Corel..., tôi thì sử dụng thường xuyên AutoCAD và Excel trong công việc, rất quan tâm đến VBA trong Excel và AutoCAD. Dạo này OpenOffice đang lên, không biết nó có công cụ lập trình nào hỗ trợ không nhỉ?
Còn MSForm2 kèm theo VBA, có hỗ trợ unicode nhưng giao diện nó quá xấu, thậm chí tui có người bạn không thèm dùng MSForm2 mà chuyển qua dùng MSExcel5Dialog vì nó có giao diện bắt mắt và quan trọng hơn là có thể gõ unicode trực tiếp lúc design.
 
Sửa lần cuối:

Thành viên trực tuyến

  • homeclassic3
  • vananhkl
  • hoang lao ta
  • THANGMAYHS
  • Phượng180881
  • daongocnam0603

Xem nhiều