Cấp của object font

Thảo luận trong 'Ứng dụng Excel' bắt đầu bởi adam_tran, 19 Tháng mười 2005.

4,462 lượt xem

  1. adam_tran

    adam_tran Steel Partner

    Bài viết:
    1,373
    Đã được thích:
    32
    Nơi ở:
    Goooogle
    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!
     
    #1
  2. the7habitsman

    the7habitsman Thành viên sơ cấp

    Bài viết:
    89
    Đã được thích:
    0
    Nơi ở:
    Hà nội
    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
     
    #2
  3. adam_tran

    adam_tran Steel Partner

    Bài viết:
    1,373
    Đã được thích:
    32
    Nơi ở:
    Goooogle
    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 đủ!
     
    #3
  4. the7habitsman

    the7habitsman Thành viên sơ cấp

    Bài viết:
    89
    Đã được thích:
    0
    Nơi ở:
    Hà nội
    Thế thì bó tay (ko biết Excel mà). Chịu khó ngâm cứu API đi nhé
     
    #4
  5. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #5
  6. dongho_cat

    dongho_cat Thành viên thân thiết

    Bài viết:
    213
    Đã được thích:
    2
    Nơi ở:
    Vỉ tuyến 17
    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.
     
    #6
  7. Secret_grasses

    Secret_grasses Thành viên hoạt động

    Bài viết:
    317
    Đã được thích:
    3
    Nơi ở:
    Ngôi nhà nhỏ trên thảo nguyên.
    Bạn link theo đường dẫn này và dowload về nhé:http://webketoan.com/thuvien/index.php?subcat=23&PHPSESSID=dd8e50de65c4d826f408b58c6d6beb6a
     
    #7
  8. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Bạn nên download ASAP về sài hay lắm.
    http://www.asap-utilities.com/
    Thân,

    Lê Văn Duyệt
     
    #8
  9. workman

    workman Thành viên hoạt động

    Bài viết:
    372
    Đã được thích:
    0
    Nơi ở:
    Ho Chi Minh
    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
     
    #9
  10. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    Sao tôi thử thì báo lổi tại dòng in đậm trên?
    LVD
     
    #10
  11. workman

    workman Thành viên hoạt động

    Bài viết:
    372
    Đã được thích:
    0
    Nơi ở:
    Ho Chi Minh
    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.
     
    Last edited: 20 Tháng mười 2005
    #11
  12. adam_tran

    adam_tran Steel Partner

    Bài viết:
    1,373
    Đã được thích:
    32
    Nơi ở:
    Goooogle
    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ỉ!
     
    #12
  13. the7habitsman

    the7habitsman Thành viên sơ cấp

    Bài viết:
    89
    Đã được thích:
    0
    Nơi ở:
    Hà nội
    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...
     
    Last edited: 21 Tháng mười 2005
    #13
  14. Tuanktcdcn

    Tuanktcdcn Lão già ham vui

    Bài viết:
    548
    Đã được thích:
    50
    Nơi ở:
    Hà Nội
    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.
     
    #14
  15. StonyHeartedMan

    StonyHeartedMan Thành viên sơ cấp

    Bài viết:
    306
    Đã được thích:
    2
    Nơi ở:
    Hà 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)
     
    #15
  16. levanduyet

    levanduyet Welcome

    Bài viết:
    535
    Đã được thích:
    11
    Giới tính:
    Nam
    Nơi ở:
    HCM
    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
     
    #16
  17. workman

    workman Thành viên hoạt động

    Bài viết:
    372
    Đã được thích:
    0
    Nơi ở:
    Ho Chi Minh
    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:
     
    #17
  18. hoxulee

    hoxulee Thành viên sơ cấp

    Bài viết:
    16
    Đã được thích:
    0
    Nơi ở:
    Vietnam
    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.
     
    Last edited: 5 Tháng mười một 2005
    #18

Chia sẻ trang này