Code for "Copy, Paste" and Font for a New Message

[gopikrish]

I am designing a form for New Message similar to Outlook Express.For commands like "Copy","Paste","Cut" how to code for these? And also when I click Font in the menu that standard Font window having "Font", "Style", "Size" should be displayed.So how to code for this?
Any help will be grately appreciated. Thanks.

[toughcoder]

Hello Gopi,

To copy or cut text to the Clipboard use this code. Suppose there is a textbox Text1 on ur form. And Cut, Copy & Paste on ur menu then the code is

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    Text1.text = Clipboard.GetText
End Sub
 
Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText Text1.text
End Sub
 
Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText Text1.text
End Sub

To show up the Choose Font dialog box, u can use a Common Dialog Control but its better if u use API code. Put a command button Commnad1 on ur form and insert this code.

Option Explicit
Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
 
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
 
 
Private 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 * 31
End Type
 
Private Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hDC As Long                '  printer DC/IC or NULL
        lpLogFont As Long          '  ptr. to a LOGFONT struct
        iPointSize As Long         '  10 * size in points of selected font
        flags As Long              '  enum. type flags
        rgbColors As Long          '  returned text color
        lCustData As Long          '  data passed to hook fn.
        lpfnHook As Long           '  ptr. to hook function
        lpTemplateName As String     '  custom template name
        hInstance As Long          '  instance handle of.EXE that
                                       '    contains cust. dlg. template
        lpszStyle As String          '  return the style field here
                                       '  must be LF_FACESIZE or bigger
        nFontType As Integer          '  same value reported to the EnumFonts
                                       '    call back with the extra FONTTYPE_
                                       '    bits added
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long           '  minimum pt size allowed &
        nSizeMax As Long           '  max pt size allowed if
                                       '    CF_LIMITSIZE is used
End Type
 
 
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock 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 Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Sub Command1_Click()
    MsgBox ShowFont
End Sub
Private Sub Form_Load()
    Command1.Caption = "ShowFont"
End Sub
 
Private Function ShowFont() As String
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    lfont.lfHeight = 0  ' determine default height
    lfont.lfWidth = 0  ' determine default width
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    lfont.lfWeight = FW_NORMAL  ' normal weight i.e. not bold
    lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
    lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = Form1.hWnd  ' window Form1 is opening this dialog box
'    cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
    cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = RGB(0, 0, 0)  ' black
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 10  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        Debug.Print  ' end the line
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Hope this helps...

[Abilio]

toughcoder

Exellent work !!

[gopikrish]

Ok thanks but can anyone also tell how to use that Common dialog control for showing that Font dialog box ?

[toughcoder]

Thanx Abilio

Well Mahesh, for using the CommonDialog control, place an instance of it on ur form, add a button, then put the following code

Private Sub Command1_Click()
With CommonDialog1
.Flags = cdlCFScreenFonts
.ShowFont
End With
End Sub

Hope this helps...

[gopikrish]

Ok and lastly how to code for those seperate toolbar buttons for Bold, Italic, Underline, Font Color and a dropdown listbox having font sizes. These are below the subject of the New Message window in the Outlook Express. Thanks.

[RobDog888]

Shouldn't the code for Cut be...

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetText Text1.text
    Text1.Text = vbNullString
End Sub

[gopikrish]

Yes Font window is appearing after I created this code,

Private Sub Command1_Click()
With CommonDialog1
.Flags = cdlCFScreenFonts
.ShowFont
End With
End Sub

But the text is not getting updated with my desired Font. So any code to do that? Thanks.

[RobDog888]

You need to get the selection from the fontdialog and format you
text accordingly.

Text.Font = CommonDialog1.Font
'...
'...
'...

[toughcoder]

Yep Robby, my mistake , thanx for pointing it out.

Hello Gopi, u gotta apply the Common Dialog selection to the text.
Use the following code for Bold, Italic, Underline & FontColor...

Private Sub Command1_Click()
Text1.FontBold = True
Text1.FontItalic = True
Text1.FontUnderline = True
Text1.ForeColor = vbGreen
End Sub

For applying Common Dialog values, use this code...

Private Sub Command2_Click()
With CommonDialog1
.Flags = cdlCFScreenFonts
.ShowFont
Text2.FontBold = .FontBold
Text2.FontItalic = .FontItalic
Text2.FontUnderline = .FontUnderline
Text2.Font = .FontName
Text2.FontSize = .FontSize
End With
End Sub

Happy coding...

[RobDog888]

No prob.

You may want to put some error trapping in case the user cancels
the Font dialog also.