Sub BrowseFolder()
    Dim fd As FileDialog, ret As Long
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    ' Açılışta geçerli dizin.
    fd.InitialFileName = "C:\"
    
    ' Pencere başlığına verilecek isim.
    fd.Title = "Klasör seçim diyaloğu"
    
    ' Butona verilecek isim.
    fd.ButtonName = "Klasörü seçiniz..."
    
    ' Diyaloğu aç.
    ret = fd.Show
    
    ' İptal tuşuna basılırsa.
    If Not ret = -1 Then Exit Sub
    
    MsgBox fd.SelectedItems(1)

End Sub

Sub FilePicker()
    Dim fd As FileDialog, ret As Long, sFile
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    ' Açılışta geçerli dizin.
    fd.InitialFileName = "C:\"
    
    ' Çoklu seçim geçerli
    fd.AllowMultiSelect = True

    ' Pencere başlığına verilecek isim.
    fd.Title = "Dosya seçim diyaloğu"
   
    ' Sonraki çağırım için filitreyi temizle
    fd.Filters.Clear
    
    ' Filitreleri ekle
    fd.Filters.Add "Resimler(*.gif; *.jpg; *.jpeg)", "*.gif; *.jpg; *.jpeg", 1
    fd.Filters.Add "Excel dosyaları(*.xls; *.xlsx; *.xlsm)", "*.xls; *.xlsx; *.xlsm", 2
    fd.Filters.Add "Metin dosyaları(*.txt)", "*.txt", 3
    fd.Filters.Add "Tüm dosyalar(*.*)", "*.*", 4
    
    ' Varsayılan filitre
    fd.FilterIndex = 3
    
    ' Diyaloğu aç.
    ret = fd.Show
    
    ' İptal tuşuna basılırsa.
    If Not ret = -1 Then Exit Sub

    If fd.SelectedItems.Count > 1 Then
        For Each vFile In fd.SelectedItems
            MsgBox vFile
        Next
    Else
        MsgBox fd.SelectedItems(1)
    End If
End Sub

Sub FilePicker2()
    Dim sFilter As String, sTitle As String, bMultiSelect As Boolean, defautFilterIndex As Integer, vFile
    
    bMultiSelect = True
    sTitle = "Bir dosya seçin"
    sFilter = "Text dosyaları(*.txt), *.txt"
    sFilter = sFilter & "," & "Excel dosyaları(*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm"
    sFilter = sFilter & "," & "Tüm dosyalar(*.*), *.*"
    defautFilterIndex = 2 ' Excel dosyaları
    
    fd = Application.GetOpenFilename(sFilter, defautFilterIndex, sTitle, , bMultiSelect)
    
    If IsArray(fd) Then
        For Each vFile In fd
            MsgBox vFile
        Next
    Else
        If fd <> False Then MsgBox fd
    End If
End Sub

Sub Farkli_Kaydet()
    Dim sFilter As String, sTitle As String, sInitialFileName As String, defautFilterIndex As Integer, vFile
    
    sInitialFileName = "" ' "deneme.xls"
    sTitle = "Bir dosya seçin"
    sFilter = "Text dosyaları(*.txt), *.txt"
    sFilter = sFilter & "," & "Excel 97-2003 dosyaları(*.xls), *.xls"
    sFilter = sFilter & "," & "Excel 2007-2013 dosyaları(*.xlsx), *.xlsx"
    sFilter = sFilter & "," & "Tüm dosyalar(*.*), *.*"
    defautFilterIndex = 2 ' Excel dosyaları
    
    fd = Application.GetSaveAsFilename(sInitialFileName, sFilter, defautFilterIndex, sTitle)
    
    If fd <> False Then MsgBox fd
End Sub

Sub WorkBook_Open()
    ' Excelin "Dosya Aç" diyaloğudur. fd.Execute ile dosya çalıştırılabilir.
    
    Dim fd As FileDialog, ret As Long, sFile
    
    Set fd = Application.FileDialog(msoFileDialogOpen)
    
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    MsgBox "'" & fd.SelectedItems(1) & "' dosyası açılacak.", vbInformation
    
    fd.Execute
End Sub

Sub WorkBook_SaveAs()
    ' Excelin "Dosya Kaydet" diyaloğudur. fd.Execute ile dosya kaydedilebilir.
    
    Dim fd As FileDialog, ret As Long, sFile
    
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    MsgBox "Bu dosya, '" & fd.SelectedItems(1) & "' adıyla farklı kaydedilecek.", vbInformation
    
    fd.Execute
End Sub

Public Enum Root
    MasaUstu = 0
    ProgramlarDizini = 2
    DenetimMasasi = 3
    Yazicilar = 4
    Belgelerim = 5
    SikKullanilanlar = 6
    BaslangicProgramDizini = 7
    SonKullanilanOgelerDizini = 8
    SendToDizini = 9
    CopKutusu = 10
    BaslatMenuDizini = 11
    MasaUstuDizini = 16
    Bilgisayarim = 17
    NetworkKullanicilari = 18
    NetworkKisayolDizini = 19
    Fonts = 20
    TemplatesDizini = 21
End Enum

Public Enum Options
    ReturnAll = 0
    ReturnOnlyFileSystemDirs = 1
    DontIncludeNetworkDirs = 2
    IncludeStatusText = 4
    ReturnOnlySystemAncestors = 8
    EditBox = 16
    Validate = 32
    NewDialogStyle = 64
    BrowseInludeUrls = 128
    DontIncludeNewFolderButton = 512
    DontIncludeTranslateTargets = 1024
    BrowseForComputer = 4096
    BrowseForPrinter = 8192
    IncludeFiles = 16384
    Shareable = -32768
    FileJunction = 65536 ' Win7 ve sonrası. Zip dosyaları da klasör gibi ekle
End Enum

#If VBA7 And Win64 Then
    Private Type BROWSEINFO
       hwndOwner      As LongLong ' Çoğu zaman 0 veya Form Handle No
       pidlRoot       As LongLong ' Kök dizin(Root)
       pszDisplayName As String   ' Seçilen elemanın adı (Path değil)
       pszTitle       As String   ' Pencere mesajı
       ulFlags        As LongLong ' Seçenekler (Options)
       lpfn           As LongLong ' Initial Klasörü atama ve seçimi ekrana yazmak için CallBack
       lParam         As LongLong ' Açılışta ve seçimde seçili olacak klasör
       iImage         As LongLong '
    End Type
#Else
    Private Type BROWSEINFO
       hwndOwner      As Long   ' Çoğu zaman 0 veya Form Handle No
       pidlRoot       As Long   ' Kök dizin(Root)
       pszDisplayName As String ' Seçilen elemanın adı (Path değil)
       pszTitle       As String ' Pencere mesajı
       ulFlags        As Long   ' Seçenekler (Options)
       lpfn           As Long   ' Initial Klasörü atama ve seçimi ekrana yazmak için CallBack
       lParam         As Long   ' Açılışta seçili olacak klasör
       iImage         As Long   '
    End Type
#End If

#If VBA7 And Win64 Then
    ' Pencere çağıran API
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
       Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongLong
    
    ' Seçimin sonucu için
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
       Alias "SHGetPathFromIDListA" (ByVal pidl As LongLong, ByVal pszPath As String) As LongLong
    
    ' Herhangi bir dizini Root yapmak için path in sayısal karşılığı
    Private Declare PtrSafe Function SHParseDisplayName Lib "shell32.dll" _
      (ByVal pszName As LongLong, ByVal pbc As LongLong, ByRef ppidl As LongLong, _
       ByVal sfgaoIn As LongLong, ByRef psfgaoOut As LongLong) As LongLong
    
    ' Hem açılışta seçili dizin, hem de gezinirken tam yolu ekrana yazma için gerekli
    Private Declare PtrSafe Function SendMessage Lib "user32" _
       Alias "SendMessageA" (ByVal hwnd As LongLong, ByVal wMsg As LongLong, _
       ByVal wParam As LongLong, ByVal lParam As Any) As LongLong
    
    ' Diyalog pencere başlığına yazı yazmak istersek
    Private Declare PtrSafe Function SetWindowText Lib "user32" _
       Alias "SetWindowTextA" (ByVal hwnd As LongLong, ByVal lpString As String) As LongLong
    
    ' Bellekte sabit yer aç
    Private Declare PtrSafe Function LocalAlloc Lib "kernel32" _
      (ByVal uFlags As LongLong, ByVal uBytes As LongLong) As LongLong
    
    ' Belleği kopyala
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As LongLong)

    ' Belleği serbest bırak
    Private Declare PtrSafe Function LocalFree Lib "kernel32" _
      (ByVal hMem As LongLong) As LongLong
   
    ' Diayalogda sonraki çağırımda önceki çağırım ayarını sil
    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongLong)
#Else
    ' Pencere çağıran API
    Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
       Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    
    ' Seçimin sonucu için
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
       Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    
    ' Herhangi bir dizini Root yapmak için path in sayısal karşılığı
    Private Declare Function SHParseDisplayName Lib "shell32.dll" _
      (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, _
       ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long
    
    ' Diyalog pencere başlığına yazı yazmak istersek
    Private Declare Function SetWindowText Lib "user32" _
       Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    
    ' Hem açılışta seçili dizin, hem de gezinirken tam yolu ekrana yazma için gerekli
    Private Declare Function SendMessage Lib "user32" _
       Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
       ByVal wParam As Long, ByVal lParam As Any) As Long
    
    ' Bellekte sabit yer aç
    Private Declare Function LocalAlloc Lib "kernel32" _
      (ByVal uFlags As Long, ByVal uBytes As Long) As Long
    
    ' Belleği kopyala
    Private Declare Sub CopyMemory Lib "kernel32" _
       Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

    ' Belleği serbest bırak
    Private Declare Function LocalFree Lib "kernel32" _
      (ByVal hMem As Long) As Long
   
    ' Diayalogda sonraki çağırımda önceki çağırım ayarını sil
    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
#End If

Private mCaption As String

Public Function BrowseFolder(Optional vCaption As String = "", Optional Msg As String = "", _
                             Optional vOptions As Options = ReturnAll, Optional LongRoot As Root = MasaUstu, _
                             Optional StrRoot As String = "", Optional DefaultDir As String = "") As String
    
    #If VBA7 And Win64 Then
        Dim pidl As LongLong, pidl2 As LongLong, lpDefaultDir As LongLong
    #Else
        Dim pidl As Long, pidl2 As Long, lpDefaultDir As Long
    #End If
    
    mCaption = vCaption ' Pencere başlığında görünecek yazı
    
    Dim bi As BROWSEINFO, strRet As String, spath As String * 260
    
    With bi
        .hwndOwner = 0
        .pidlRoot = LongRoot
    If Trim$(StrRoot) <> "" Then ' İsteğe bağlı Root için başla
        Call SHParseDisplayName(StrPtr(StrRoot), 0, pidl2, 0, 0)
        .pidlRoot = pidl2
    End If
        .pszTitle = Msg ' İleti
        .pszDisplayName = Space$(260) ' Seçimin yalnız başlığı için String Buffer
        .ulFlags = vOptions
        .lpfn = Dummy(AddressOf BrowseCallback) ' Hem açılınca, hem seçim anında seçimi görme için
        
        lpDefaultDir = LocalAlloc(64, Len(DefaultDir) + 1)
        CopyMemory ByVal lpDefaultDir, ByVal DefaultDir, Len(DefaultDir) + 1
        
        .lParam = lpDefaultDir
    End With
    
    pidl = SHBrowseForFolder(bi) ' Diyaloğu aç
 
    If pidl = 0 Then GoTo Clean ' İptal butonuna basıldıysa
    
    If SHGetPathFromIDList(pidl, spath) <> 0 Then ' Path'i spath değişkenine ata
        strRet = TrimNull(spath)
    End If
    
    ' Yazıcı ve Bilgisayar isimleri Path olmadığı için aşağıdaki satır ile alıyoruz. İstersek,
    ' seçime bağlı olarak CallBack içinde Path kontrolu ile Tamam butonunu aktif/pasif yapabiliriz.
    ' Ancak, bu fonk.sonucunun bir Path olup olmadığı kontrolünü çağırdığınız yerde yapmanız uygun olur.
    If strRet = "" Then strRet = TrimNull(bi.pszDisplayName)
    
    BrowseFolder = strRet
    
Clean:
    Call CoTaskMemFree(pidl)
    Call LocalFree(lpDefaultDir)
End Function

#If VBA7 And Win64 Then
    Private Function BrowseCallback(ByVal hwnd As LongLong, ByVal uMsg As LongLong, ByVal lParam As LongLong, _
                                   ByVal lpData As LongLong) As LongLong
#Else
    Private Function BrowseCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, _
                                   ByVal lpData As Long) As Long
#End If

        '*** BrowseCallback fonksiyonu bir .bas modul içinde olmak zorundadır. ***'
        
        On Error Resume Next ' Excel çökmesin
        
        Dim sBuffer As String * 260
                
        #If VBA7 And Win64 Then
            Dim btnOK As LongLong
        #Else
            Dim btnOK As Long
        #End If
        
        Select Case uMsg
            Case 1 ' Initialize modunda belirtilen dizin seçili gelecektir (DefaultDir)
                If lpData <> 0 Then
                    If mCaption <> "" Then _
                    Call SetWindowText(hwnd, mCaption) ' Diyalog başlığına yaz
                    Call SendMessage(hwnd, 1126, 1, ByVal lpData) ' Diyalog Status Text e yaz
                End If
            Case 2 ' Selection modunda dizinler üzerinde gezinirken seçimi göster
                If SHGetPathFromIDList(lParam, sBuffer) <> 0 Then ' Seçim, bir Path ise
                    'btnOK = 1
                    'Call SendMessage(hwnd, 1125, 0, btnOK) ' Tamam aktif
                    Call SendMessage(hwnd, 1124, 0, sBuffer)
                    'Call SetWindowText(hwnd, TrimNull(sBuffer)) ' Seçimi pencere başlığına yazdırmak istersek
                Else
                    'btnOK = 0
                    'Call SendMessage(hwnd, 1125, 0, btnOK) ' Tamam pasif
                End If
        End Select
    End Function

#If VBA7 And Win64 Then
    Private Function Dummy(lpProcName As LongLong) As LongLong
#Else
    Private Function Dummy(lpProcName As Long) As Long
#End If
    ' BrowseCallback'in adresini AddressOf ile alabilmek için gerekli kıytırık fonksiyon.
        Dummy = lpProcName
    End Function

Private Function TrimNull(metin As String) As String
' API metnini VB metnine çevirme
    TrimNull = Left$(Trim$(metin), Len(Trim$(metin)) - 1)
End Function

#If VBA7 And Win64 Then
    Private Type OpenFileName
        lStructSize       As LongLong
        hwndOwner         As LongLong
        hInstance         As LongLong
        lpstrFilter       As String
        lpstrCustomFilter As String
        nMaxCustFilter    As LongLong
        nFilterIndex      As LongLong
        lpstrFile         As String
        nMaxFile          As LongLong
        lpstrFileTitle    As String
        nMaxFileTitle     As LongLong
        lpstrInitialDir   As String
        lpstrTitle        As String
        flags             As LongLong
        nFileOffset       As Integer
        nFileExtension    As Integer
        lpstrDefExt       As String
        lCustData         As LongLong
        lpfnHook          As LongLong
        lpTemplateName    As String
    End Type
#Else
    Private Type OpenFileName
        lStructSize       As Long
        hwndOwner         As Long
        hInstance         As Long
        lpstrFilter       As String
        lpstrCustomFilter As String
        nMaxCustFilter    As Long
        nFilterIndex      As Long
        lpstrFile         As String
        nMaxFile          As Long
        lpstrFileTitle    As String
        nMaxFileTitle     As Long
        lpstrInitialDir   As String
        lpstrTitle        As String
        flags             As Long
        nFileOffset       As Integer
        nFileExtension    As Integer
        lpstrDefExt       As String
        lCustData         As Long
        lpfnHook          As Long
        lpTemplateName    As String
    End Type
#End If

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As LongLong
#Else
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
#End If
    
Public Function OpenFileName() As String
    Dim OFName As OpenFileName
#If VBA7 And Win64 Then
    OFName.lStructSize = CLngLng(Len(OFName))
#Else
    OFName.lStructSize = Len(OFName)
#End If
    'OFName.hwndOwner = Form1.hWnd
    'OFName.hInstance = App.hInstance
    OFName.lpstrFilter = "Excel Dosyaları (*.xls;*.xlsm)" + Chr(0) + "*.xls;*.xlsm" + Chr(0) ' NullChar ile bitecek
    OFName.lpstrFile = Space(254)
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space(254)
    OFName.nMaxFileTitle = 255
    OFName.lpstrInitialDir = CurDir
    OFName.lpstrTitle = "Kaynak Excel dosyasını seçin"
    OFName.flags = 0

    If GetOpenFileName(OFName) Then
        OpenFileName = Trim(OFName.lpstrFile)
    End If
End Function

#If VBA7 And Win64 Then
    Private Type OpenFileName
        lStructSize       As LongLong
        hwndOwner         As LongLong
        hInstance         As LongLong
        lpstrFilter       As String
        lpstrCustomFilter As String
        nMaxCustFilter    As LongLong
        nFilterIndex      As LongLong
        lpstrFile         As String
        nMaxFile          As LongLong
        lpstrFileTitle    As String
        nMaxFileTitle     As LongLong
        lpstrInitialDir   As String
        lpstrTitle        As String
        flags             As LongLong
        nFileOffset       As Integer
        nFileExtension    As Integer
        lpstrDefExt       As String
        lCustData         As LongLong
        lpfnHook          As LongLong
        lpTemplateName    As String
    End Type
#Else
    Private Type OpenFileName
        lStructSize       As Long
        hwndOwner         As Long
        hInstance         As Long
        lpstrFilter       As String
        lpstrCustomFilter As String
        nMaxCustFilter    As Long
        nFilterIndex      As Long
        lpstrFile         As String
        nMaxFile          As Long
        lpstrFileTitle    As String
        nMaxFileTitle     As Long
        lpstrInitialDir   As String
        lpstrTitle        As String
        flags             As Long
        nFileOffset       As Integer
        nFileExtension    As Integer
        lpstrDefExt       As String
        lCustData         As Long
        lpfnHook          As Long
        lpTemplateName    As String
    End Type
#End If

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As LongLong
#Else
    Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OpenFileName) As Long
#End If
 
Public Function SaveFileName() As String
    Dim OFName As OpenFileName
#If VBA7 And Win64 Then
    OFName.lStructSize = CLngLng(Len(OFName))
#Else
    OFName.lStructSize = Len(OFName)
#End If
    'OFName.hwndOwner = Form1.hWnd
    'OFName.hInstance = App.hInstance
    OFName.lpstrFilter = "Excel Dosyaları (*.xlsm;*.xlsb)" + Chr(0) + "*.xlsm;*.xlsb" + Chr(0) ' NullChar ile bitecek
    OFName.lpstrFile = Space(254)
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space(254)
    OFName.nMaxFileTitle = 255
    OFName.lpstrInitialDir = "C:\"
    OFName.lpstrTitle = "Kayıt için dosya seçin"
    OFName.flags = 0

    If GetSaveFileName(OFName) Then
        SaveFileName = Trim(Replace(OFName.lpstrFile, Chr(0), ""))
    End If
End Function

' UserForm ve bir adet CommandButton1 ekleyin.
#If VBA7 And Win64 Then
    Private Type CHOOSECOLOR_TYPE
        lStructSize    As LongLong
        hwndOwner      As LongLong
        hInstance      As LongLong
        rgbResult      As LongLong
        lpCustColors   As String
        flags          As LongLong
        lCustData      As LongLong
        lpfnHook       As LongLong
        lpTemplateName As String
    End Type
#Else
    Private Type CHOOSECOLOR_TYPE
        lStructSize    As Long
        hwndOwner      As Long
        hInstance      As Long
        rgbResult      As Long
        lpCustColors   As String
        flags          As Long
        lCustData      As Long
        lpfnHook       As Long
        lpTemplateName As String
    End Type
#End If

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR_TYPE) As LongLong
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongLong
#Else
    Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR_TYPE) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Private Function ShowColor() As Long
    Dim cc As CHOOSECOLOR_TYPE
    Dim Custcolors(0 To 63) As Byte

    ' Renk diyaloğu ekranın sol üst köşesi yerine form üzerinde çıkması için hWnd
    cc.hwndOwner = FindWindow(vbNullString, Me.Caption)
#If VBA7 And Win64 Then
    cc.lStructSize = CLngLng(Len(cc))
#Else
    cc.lStructSize = Len(cc)
#End If
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    cc.flags = 0

    ShowColor = IIf(ChooseColor(cc) <> 0, cc.rgbResult, -1)
End Function

Private Sub CommandButton1_Click()
    Dim NewColor As Long
    
    NewColor = ShowColor
    
    If NewColor <> -1 Then
        Me.BackColor = NewColor
    End If
End Sub

' 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