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)

READ MORE - VB6 Trik - Mengukur Dimensi String Tanpa Fungsi API

CommonDialog Font, Cara Menggunakannya

Private Sub Command1_Click()
    With CommonDialog1
        .CancelError = True
        On Error GoTo ErrHandler
        .Flags = cdlCFEffects Or cdlCFBoth
        .ShowFont
        Text1.Font.Name = .FontName
        Text1.Font.Size = .FontSize
        Text1.Font.Bold = .FontBold
        Text1.Font.Italic = .FontItalic
        Text1.Font.Underline = .FontUnderline
        Text1.FontStrikethru = .FontStrikethru
        Text1.ForeColor = .Color
    End With
    Exit Sub
ErrHandler:
    Exit Sub
End Sub

READ MORE - CommonDialog Font, Cara Menggunakannya

Menentukan Objek Font Yang Dikirimkan Ke Printer

Contoh sederhana untuk menentukan name, underline, bold, italic, size (properties objek font) yang dikirimkan ke sebuah printer. Adapun contohnya sebagai berikut:

Private Sub Command1_Click() 
    With Printer 
        .FontName = "Arial" 
        .FontUnderline = False 
        .FontBold = False
        .FontItalic = True
        .FontSize = "30"
        .Print "Ini contoh objek font dalam printer" 
        .EndDoc 
    End With 
End Sub 

READ MORE - Menentukan Objek Font Yang Dikirimkan Ke Printer

Memutarkan huruf pada watermark, bagaimana caranya?

Mengenai cara memutarkan atau merotasi font pada watermark menggunakan VB6 (belajar Visual Basic 6 untuk pemula) - Posting ini merupakan kelanjutan dari posting yang telah ditulis terdahulu. Disini kita akan menambahkan beberapa kemampuan pada project watermark yang sedang kita buat. Perhatikan kode di bawah ini:

'--------------------------------------------------------------------------------------- 
' http://khoiriyyah.blogspot.com 
' coder: Administrator 
'--------------------------------------------------------------------------------------- 
Option Explicit 
 
Private Declare Sub InitCommonControls Lib "comctl32.dll" () 
 
Dim intCurrentX As Integer 'variabel untuk menyimpan koordinat X 
Dim intCurrentY As Integer 'variabel untuk menyimpan koordinat Y 
 
Private Sub Command1_Click() 
    'memanggil prosedur RotateFont 
    RotateFont Picture1, Val(txtSize), txtFontName, intCurrentX, intCurrentY, Val(txtDegree), txtWatermark 
    'menyimpan hasil gambar yang telah diberi teks 
    SavePicture Picture1.Image, App.Path & "\watermark_sample.bmp" 'and save  Exit Sub 
End Sub 
 
Private Sub Form_Initialize() 
    InitCommonControls 'XP style 
End Sub 
 
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 
    Label3 = "X: " & x 'menampilkan koordinat X ke dalam label 
    Label4 = "Y: " & y 'menampilkan koordinat Y ke dalam label 
    intCurrentX = x 'simpan koordinat x dalam variabel intCurrentX 
    intCurrentY = y 'simpan koordinat y dalam variabel intCurrentY 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
 
Private Sub txtDegree_Change() 
    'apabila bukan angka, jadikan txtDegree.Text = 90 
  If Not IsNumeric(txtDegree.Text) Then txtDegree.Text = "90" 
End Sub 
 
Private Sub VScroll1_Scroll() 
    'panggil prosedur WaterMarkIt pada saat terjadi Scroll 
    WaterMarkIt 
End Sub 
 
Private Sub VScroll1_Change() 
    'panggil prosedur WaterMarkIt pada saat terjadi perubahan nilai 
    WaterMarkIt 
End Sub 
 
Private Sub VScroll2_Change() 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
 
Private Sub VScroll2_Scroll() 
    WaterMarkIt 'panggil prosedur WaterMarkIt 
End Sub 
'-------------------------------------------------------------------- 
' Prosedur WaterMarkIt 
'-------------------------------------------------------------------- 
Private Sub WaterMarkIt() 
    Command1_Click 'panggil Command1_Click (Rotasi dan simpan image) 
    txtDegree.Text = VScroll1.Value 'txtDegree berdasarkan nilai VScroll1 
    txtSize.Text = VScroll2.Value 'txtSize berdasarkan nilai VScroll2 
End Sub 

Download Project

READ MORE - Memutarkan huruf pada watermark, bagaimana caranya?

Rotasi Font Menggunakan Visual Basic 6.0

Modul untuk memutarkan atau merotasi font berdasarkan derajat tertentu serta koordinat tertentu menggunakan VB6 - Bagaimana kode serta contoh penggunaannya, bisa Anda lihat di bawah ini:

Option Explicit 
 
Public 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 As String * 33
End Type 
 
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long 
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long 
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 
 
Public Sub RotateFont(pic As PictureBox, fontsize As Integer, fontname As String, x As Integer, y As Integer, degree As Integer, txt As String) 
         
    On Error GoTo ErrHandler
     
    Dim F As LOGFONT
    Dim hPrevFont As Long 
    Dim hFont As Long
    pic.Cls
 
    F.lfEscapement = 10 * Val(degree)
    F.lfFacename = fontname 
    F.lfHeight = (fontsize * -20) / Screen.TwipsPerPixelY 
    pic.fontname = "Arial Black" + Chr$(0) 
    hFont = CreateFontIndirect(F) 
    hPrevFont = SelectObject(pic.hdc, hFont) 
 
    pic.CurrentX = x
    pic.CurrentY = y
    pic.Print txt
     
    hFont = SelectObject(pic.hdc, hPrevFont)
    DeleteObject hFont 
    Exit Sub 
    
ErrHandler: 
 
    MsgBox Err.Description
     
End Sub 

Modul di atas memiliki 7 parameter, Adapun contoh penggunaannya sebagai berikut:

Private Sub Command1_Click() 
    RotateFont Picture1, 12, "Arial", 90, 2500, _ 
    40, "khoiriyyah.blogspot.com" 
'Keterangan: 
'    1. Picture1 = PictureBox 
'    2. 12 = ukuran huruf 
'    3. Arial = nama huruf 
'    4. 90 = koordinat X 
'    5. 2500 = koordinat Y 
'    6. 40 = derajat putaran (0 derajat = normal, 90 derajat = tegak lurus) 
'    7. khoiriyyah.blogspot.com = text yang dimasukan ke dalam PictureBox 
End Sub 

READ MORE - Rotasi Font Menggunakan Visual Basic 6.0

Menggunakan Fonts Tanpa Menginstalnya

Di bawah ini merupakan kode untuk menggunakan fonts tanpa harus menginstalnya.

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" ByVal lpFileName As String) As Long 
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" ByVal lpFileName As String) As Long 
 
Public Function AddFontToResource(Filename As String) 
    Dim lFont As Long 
    lFont = RemoveFontResource(Filename) 
End Function 
 
Public Function RemoveFontFromResource(Filename As String) 
    Dim lFont As Long 
    lFont = AddFontResource(Filename) 
End Function  

Contoh penggunaan fungsi di atas:

Private Sub Form_Load() 
    AddFontResource App.Path & "\Fonts\Trado.ttf" 
    Text1.FontName = "Traditional Arabic" 
End Sub 

READ MORE - Menggunakan Fonts Tanpa Menginstalnya

Cara Termudah Untuk Mengisi Seluruh Fonts Ke dalam ListBox

Di bawah ini merupakan fungsi untuk mengisi seluruh fonts yang ada dalam komputer Anda ke dalam objek ListBox

Public Function LoadAllFonts(lst As Control) 
    Dim i As Integer 
    For i = 1 To 1000 
        If Screen.Fonts(i) = "" Then Exit For 
        lst.AddItem Screen.Fonts(i) 
    Next i 
End Function 

Contoh penggunaan fungsi untuk mengisi seluruh fonts ke dalam ListBox

Private Sub Form_Load() 
    LoadAllFonts List1 
End Sub 

READ MORE - Cara Termudah Untuk Mengisi Seluruh Fonts Ke dalam ListBox