VB6 Trik - Mengukur Dimensi String Tanpa Fungsi API

Menjelaskan mengenai cara mengukur dimensi string yang menggunakan objek font tertentu tanpa menggunakan fungsi API.

Untuk berbagai keperluan, terkadang kita membutuhkan sebuah prosedure untuk mengukur dimensi sebuah string. Di samping dengan menggunakan fungsi API GetTextExtentPoint32, kitapun dapat mengukurnya dengan sebuah trik yang sederhana, di bawah ini adalah contohnya:

Option Explicit

Private Type hwFONT
    Height As Integer
    Width As Integer
End Type

Private Function GetWidthHeight(LabelCaption As String) As hwFONT
    Dim lbl As Label, hwF As hwFONT
    Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
    With lbl
        .Caption = LabelCaption
        .AutoSize = True
        .Refresh
    End With
    hwF.Width = lbl.Width
    hwF.Height = lbl.Height
    GetWidthHeight = hwF
    Controls.Remove "lblTestWidthHeight"
End Function

Private Function GetFontWidthHeight(LabelCaption As String, _
                                    Optional FontName As String = "MS Sans Serif", _
                                    Optional FontSize As String = 8) As hwFONT
    Dim lbl As Label, hwF As hwFONT
    Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
    With lbl
        .FontName = FontName
        .FontSize = FontSize
        .Caption = LabelCaption
        .AutoSize = True
        .Refresh
    End With
    hwF.Width = lbl.Width
    hwF.Height = lbl.Height
    GetFontWidthHeight = hwF
    Controls.Remove "lblTestWidthHeight"
End Function

Private Function GetFontObjectWH(LabelCaption As String, fntAny As StdFont) As hwFONT
    Dim lbl As Label, hwF As hwFONT
    Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
    With lbl
        .Caption = LabelCaption
        .AutoSize = True
        Set .Font = fntAny
        .Refresh
    End With
    hwF.Width = lbl.Width
    hwF.Height = lbl.Height
    GetFontObjectWH = hwF
    Controls.Remove "lblTestWidthHeight"
End Function

Private Sub cmdTest1_Click()
    Dim hwF As hwFONT
    hwF = GetWidthHeight("Test")
    List1.AddItem "Test"
    Shape1.Width = hwF.Width
    Picture1.Cls
    Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub

Private Sub cmdTest3_Click()
    Dim fntList As StdFont
    Dim hwF As hwFONT
    Set fntList = List1.Font
    Dim strString As String
    strString = "Test Font object"
    List1.AddItem strString
    hwF = GetFontObjectWH(strString, fntList)
    Shape1.Width = hwF.Width
    Picture1.Cls
    Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub

Private Sub cmdTest2_Click()
    Dim hwF As hwFONT
    hwF = GetFontWidthHeight("Just Test")
    List1.AddItem "Just Test"
    Shape1.Width = hwF.Width
    Picture1.Cls
    Picture1.Print "Height: " & hwF.Height & vbCrLf & "Widht: " & hwF.Width
End Sub

Selanjutnya, dari contoh-contoh di atas yang akan kita gunakan untuk berbagai keperluan adalah:

Private Type hwFONT
    Height As Integer
    Width As Integer
End Type

Private Function GetFontObjectWH(LabelCaption As String, fntAny As StdFont) As hwFONT
    Dim lbl As Label, hwF As hwFONT
    Set lbl = Controls.Add("VB.Label", "lblTestWidthHeight")
    With lbl
        .Caption = LabelCaption
        .AutoSize = True
        Set .Font = fntAny
        .Refresh
    End With
    hwF.Width = lbl.Width
    hwF.Height = lbl.Height
    GetFontObjectWH = hwF
    Controls.Remove "lblTestWidthHeight"
End Function

Download project: String dimension (font height and width)