Font Seçme Diyaloğu

' UserForm ve bir adet CommandButton1, bir adet TextBox1 ekleyin.
Private Const GMEM_MOVEABLE = 2
Private Const GMEM_ZEROINIT = 64
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Const LF_FACESIZE = 32

Private Const FW_BOLD = 700

Private Const CF_APPLY = 512
Private Const CF_ANSIONLY = 1024
Private Const CF_TTONLY = 262144
Private Const CF_EFFECTS = 256
Private Const CF_ENABLETEMPLATE = 16
Private Const CF_ENABLETEMPLATEHANDLE = 32
Private Const CF_FIXEDPITCHONLY = 16384
Private Const CF_FORCEFONTEXIST = 65536
Private Const CF_INITTOLOGFONTSTRUCT = 64
Private Const CF_LIMITSIZE = 8192
Private Const CF_NOFACESEL = 524288
Private Const CF_NOSCRIPTSEL = 8388608
Private Const CF_NOSTYLESEL = 1048576
Private Const CF_NOSIZESEL = 2097152
Private Const CF_NOSIMULATIONS = 4096
Private Const CF_NOVECTORFONTS = 2048
Private Const CF_NOVERTFONTS = 16777216
Private Const CF_OEMTEXT = 7
Private Const CF_PRINTERFONTS = 2
Private Const CF_SCALABLEONLY = 131072
Private Const CF_SCREENFONTS = 1
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_SELECTSCRIPT = 4194304
Private Const CF_SHOWHELP = 4
Private Const CF_USESTYLE = 128
Private Const CF_WYSIWYG = -32768
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS

Private Const LOGPIXELSY = 90

Private Type FormFontInfo
    Name      As String
    Weight    As Integer
    Height    As Integer
    UnderLine As Boolean
    Italic    As Boolean
#If VBA7 And Win64 Then
    Color     As LongLong
#Else
    Color     As Long
#End If
End Type

Private Type LOGFONT
    #If VBA7 And Win64 Then
        lfHeight                As LongLong
        lfWidth                 As LongLong
        lfEscapement            As LongLong
        lfOrientation           As LongLong
        lfWeight                As LongLong
    #Else
        lfHeight                As Long
        lfWidth                 As Long
        lfEscapement            As Long
        lfOrientation           As Long
        lfWeight                As Long
    #End If
        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

#If VBA7 And Win64 Then
    Private Type FONTSTRUC
        lStructSize       As LongLong
        hwnd              As LongLong
        hdc               As LongLong
        lpLogFont         As LongLong
        iPointSize        As LongLong
        Flags             As LongLong
        rgbColors         As LongLong
        lCustData         As LongLong
        lpfnHook          As LongLong
        lpTemplateName    As String
        hInstance         As LongLong
        lpszStyle         As String
        nFontType         As Integer
        MISSING_ALIGNMENT As Integer
        nSizeMin          As LongLong
        nSizeMax          As LongLong
    End Type
#Else
    Private Type FONTSTRUC
        lStructSize       As Long
        hwnd              As Long
        hdc               As Long
        lpLogFont         As Long
        iPointSize        As Long
        Flags             As Long
        rgbColors         As Long
        lCustData         As Long
        lpfnHook          As Long
        lpTemplateName    As String
        hInstance         As Long
        lpszStyle         As String
        nFontType         As Integer
        MISSING_ALIGNMENT As Integer
        nSizeMin          As Long
        nSizeMax          As Long
    End Type
#End If

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As LongLong
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongLong
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongLong, ByVal dwBytes As LongLong) As LongLong
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongLong)
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongLong, ByVal nIndex As LongLong) As LongLong
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongLong) As LongLong
#Else
    Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
#End If

#If VBA7 And Win64 Then
Private Function MulDiv(In1 As LongLong, In2 As LongLong, In3 As LongLong) As LongLong
Dim lngTemp As LongLong
#Else
Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long
Dim lngTemp As Long
#End If

    On Error GoTo MulDiv_err
    If In3 <> 0 Then
        lngTemp = In1 * In2
        lngTemp = lngTemp / In3
    Else
        lngTemp = -1
    End If
    
MulDiv_end:
    MulDiv = lngTemp
    Exit Function
    
MulDiv_err:
    lngTemp = -1
    Resume MulDiv_err
End Function

Private Function ByteToString(aBytes() As Byte) As String
    Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
    
    dwBytePoint = LBound(aBytes)
    While dwBytePoint <= UBound(aBytes)
        dwByteVal = aBytes(dwBytePoint)
        If dwByteVal = 0 Then
            ByteToString = szOut
            Exit Function
        Else
            szOut = szOut & Chr$(dwByteVal)
        End If
        dwBytePoint = dwBytePoint + 1
    Wend
    ByteToString = szOut
End Function

Private Sub StringToByte(InString As String, ByteArray() As Byte)
    Dim intLbound As Integer, intUbound As Integer, intLen As Integer, intX As Integer
    
    intLbound = LBound(ByteArray)
    intUbound = UBound(ByteArray)
    intLen = Len(InString)
    
    If intLen > intUbound - intLbound Then intLen = intUbound - intLbound
    
    For intX = 1 To intLen
        ByteArray(intX - 1 + intLbound) = Asc(Mid(InString, intX, 1))
    Next
End Sub


Private Function DialogFont(ByRef f As FormFontInfo) As Boolean
    Dim LF As LOGFONT, FS As FONTSTRUC
#If VBA7 And Win64 Then
    Dim lLogFontAddress As LongLong, lMemHandle As LongLong, fHeight As LongLong
#Else
    Dim lLogFontAddress As Long, lMemHandle As Long, fHeight As Long
#End If
    
    fHeight = f.Height
    LF.lfWeight = f.Weight
    LF.lfItalic = f.Italic * -1
    LF.lfUnderline = f.UnderLine * -1
    LF.lfHeight = -MulDiv(fHeight, GetDeviceCaps(GetDC(hWndAccessApp), LOGPIXELSY), 72)
    Call StringToByte(f.Name, LF.lfFaceName())
    FS.rgbColors = f.Color
    
#If VBA7 And Win64 Then
    FS.lStructSize = CLngLng(Len(FS))
    lMemHandle = GlobalAlloc(CLngLng(GHND), CLngLng(Len(LF)))
#Else
    FS.lStructSize = Len(FS)
    lMemHandle = GlobalAlloc(GHND, Len(LF))
#End If
    
    If lMemHandle = 0 Then
        DialogFont = False
        Exit Function
    End If
    
    lLogFontAddress = GlobalLock(lMemHandle)
    If lLogFontAddress = 0 Then
        DialogFont = False
        Exit Function
    End If

    #If VBA7 And Win64 Then    
        CopyMemory ByVal lLogFontAddress, LF, CLngLng(Len(LF))
    #Else
        CopyMemory ByVal lLogFontAddress, LF, Len(LF)
    #End If
    
    FS.lpLogFont = lLogFontAddress
    FS.Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
    
    If ChooseFont(FS) = 1 Then
    #If VBA7 And Win64 Then
        CopyMemory LF, ByVal lLogFontAddress, CLngLng(Len(LF))
    #Else
        CopyMemory LF, ByVal lLogFontAddress, Len(LF)
    #End If
        f.Weight = CInt(LF.lfWeight)
        f.Italic = CBool(LF.lfItalic)
        f.UnderLine = CBool(LF.lfUnderline)
        f.Name = ByteToString(LF.lfFaceName())
    #If VBA7 And Win64 Then
        f.Height = CLngLng(FS.iPointSize / 10)
    #Else
        f.Height = CLng(FS.iPointSize / 10)
    #End If
        f.Color = FS.rgbColors
        DialogFont = True
    Else
        DialogFont = False
    End If
End Function

Private Sub UserForm_Activate()
    Me.Height = 265
    Me.Width = 615
End Sub

Private Sub CommandButton1_Click()
    Dim ffi As FormFontInfo, bool As Boolean
    
    ' Diyalogta seçili gelecek default biçimler
    ffi.Color = TextBox1.ForeColor
    ffi.Height = TextBox1.Font.Size
    ffi.Weight = TextBox1.Font.Weight
    ffi.Italic = TextBox1.Font.Italic
    ffi.UnderLine = TextBox1.Font.UnderLine
    ffi.Name = TextBox1.Font.Name
    
    ' Diyaloğu çağır
    bool = DialogFont(ffi)
    
    If bool = False Then Exit Sub
    
    ' Diyalogta seçilen biçimleri Textboxa ata
    TextBox1.Font.Name = ffi.Name
    TextBox1.Font.Size = ffi.Height
    TextBox1.Font.Weight = ffi.Weight
    TextBox1.Font.Italic = ffi.Italic
    TextBox1.Font.UnderLine = ffi.UnderLine
    TextBox1.ForeColor = ffi.Color
End Sub

Private Sub UserForm_Initialize()
    TextBox1.Top = 10
    TextBox1.Left = 10
    TextBox1.Height = 100
    TextBox1.Width = 500
    TextBox1.MultiLine = True
    TextBox1.Text = "Bu metin kutusundaki yazıyı" & vbNewLine & _
                    "aşağıdaki butonu" & vbNewLine & "kullanarak biçimlendirin"

    CommandButton1.Top = 200
    CommandButton1.Left = 200
    CommandButton1.Height = 25
    CommandButton1.Width = 85
    CommandButton1.Caption = "Diyaloğu göster"
End Sub

Yazar: mmustafaaslan

2004 yilindan itibaren ozel bir sirketin finans departmaninda calismaktadir. Kendini excel, visual basic kullaniminda gelistirmis olan yazarimiz; Meslegi geregi SAP konusunda ileri derecede bilgilidir.

“Font Seçme Diyaloğu” için 1 yorum

Bir Cevap Yazın

E-posta hesabınız yayımlanmayacak. Gerekli alanlar * ile işaretlenmişlerdir


3 + 2 =