Solved

Flat buttons - how to make them?

Posted on 1998-09-15
11
287 Views
Last Modified: 2008-03-17
i've seen in a lot of programs flat buttons. give me the code to have them in my proggy and explain how to use it and i'll pay you 150 points, i think the price is worth.
0
Comment
Question by:yordan
  • 7
  • 2
  • 2
11 Comments
 
LVL 14

Accepted Solution

by:
waty earned 150 total points
Comment Utility
Here is the code for you, and as an extra, try this code (effet garantit)

Private Sub Form_Activate()

   TextEffect Me, "", 12, 12, , 128, 0, RGB(&H80, 0, 0)
   
End Sub


' *** Make flat toolbar
' *** Make a flat toolbar
MakeFlatToolbar toolbar


Option Explicit

' *** MakeFlatToolbar
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_USER = &H400
Private Const TB_SETSTYLE = WM_USER + 56
Private Const TB_GETSTYLE = WM_USER + 57
Private Const TBSTYLE_FLAT = &H800
Private Const TBSTYLE_LIST = &H1000

' *** TextEfect
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As Long, ByVal nCharExtra As Long) As Long

Private Type RECT
    left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const COLOR_BTNFACE = 15

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4          '  Character-stream, PLP
Private Const DT_DISPFILE = 6            '  Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5            '  Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0             '  Vector plotter
Private Const DT_RASCAMERA = 3           '  Raster camera
Private Const DT_RASDISPLAY = 1          '  Raster display
Private Const DT_RASPRINTER = 2          '  Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTop = &H80
Private Const DT_Top = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

Public Sub TextEffect(obj As Object, ByVal sText As String, ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop As Boolean = False, Optional ByVal lStartSpacing As Long = 128, Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor As OLE_COLOR = vbWindowText)
   ' *** Kerning describes the spacing between characters when a font is written out.
   ' *** By default, fonts have a preset default kerning, but this very easy to modify
   ' *** under the Win32 API.

   ' *** The following (rather unusally named?) API function is all you need:

   ' *** Private Declare Function SetTextCharacterExtra Lib "gdi32" () (ByVal hdc As Long, ByVal nCharExtra As Long) As Long

   ' *** By setting nCharExtra to a negative value, you bring the characters closer together,
   ' *** and by setting to a positive values the characters space out.
   ' *** It works with VB's print methods too.

   Dim lHDC             As Long
   Dim i                As Long
   Dim X                As Long
   Dim lLen             As Long
   Dim hBrush           As Long
   Static tR            As RECT
   Dim iDir             As Long
   Dim bNotFirstTime    As Boolean
   Dim lTime            As Long
   Dim lIter            As Long
   Dim bSlowDown        As Boolean
   Dim lCOlor           As Long
   Dim bDoIt            As Boolean
   
   lHDC = obj.hdc
   iDir = -1
   i = lStartSpacing
   tR.left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY
   OleTranslateColor oColor, 0, lCOlor
   
   hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
   lLen = Len(sText)
   
   SetTextColor lHDC, lCOlor
   bDoIt = True
   
   Do While bDoIt
      lTime = timeGetTime
      If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
         bSlowDown = True
         iDir = 1
         lIter = (i + 4)
      End If
      If (i > 128) Then iDir = -1
      If Not (bLoop) And iDir = 1 Then
         If (i = lEndSpacing) Then
            ' STop
            bDoIt = False
         Else
            lIter = lIter - 1
            If (lIter <= 0) Then
               i = i + iDir
               lIter = (i + 4)
            End If
         End If
      Else
         i = i + iDir
      End If
     
      FillRect lHDC, tR, hBrush
      X = 32 - (i * lLen)
      SetTextCharacterExtra lHDC, i
      DrawText lHDC, sText, lLen, tR, DT_CALCRECT
      tR.Right = tR.Right + 4
      If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = obj.ScaleWidth \ Screen.TwipsPerPixelX
      DrawText lHDC, sText, lLen, tR, DT_LEFT
      obj.Refresh
     
      Do
         DoEvents
         If obj.Visible = False Then Exit Sub
      Loop While (timeGetTime - lTime) < 20
   
   Loop
   DeleteObject hBrush

End Sub

Public Function MakeFlatToolbar(myToolbar As toolbar, Optional isList As Boolean)
   ' *** MakeFlatToolbar
   Dim style      As Long
   Dim hToolbar   As Long
   Dim R          As Long

   hToolbar = FindWindowEx(myToolbar.hWnd, 0&, "ToolbarWindow32", vbNullString)
   style = SendMessageLong(hToolbar, TB_GETSTYLE, 0&, 0&)
   If isList Then
      style = style Or TBSTYLE_FLAT Or TBSTYLE_LIST
   Else
      style = style Or TBSTYLE_FLAT
   End If
   R = SendMessageLong(hToolbar, TB_SETSTYLE, 0, style)
   myToolbar.Refresh

End Function

0
 

Author Comment

by:yordan
Comment Utility
can you tell me how to use the code above?
for instance i want to have three flat buttons in my form - exit, about, generate
if you can make a sample proggy i can pay you more
0
 

Author Comment

by:yordan
Comment Utility
can you tell me how to use the code above?
for instance i want to have three flat buttons in my form - exit, about, generate
if you can make a sample proggy i can pay you more
0
 
LVL 14

Expert Comment

by:waty
Comment Utility
The code above is for toolbar.

Another way to have flat buttons, is setting the style to graphical.
0
 

Author Comment

by:yordan
Comment Utility
i wanted to know hpw to make Flat buttons not something else. thanks anyway
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 2

Expert Comment

by:cantrell
Comment Utility
The way I do it is to use a control called EXPLBUTT.OCX. Include this component into your project, and voila - Flat toolbars. I put this control on my ftp site for you to download at ftp.ecf.com/users/cantrell/pub/EXBUTT.OCX

It's a great control. I use it all the time.
0
 

Author Comment

by:yordan
Comment Utility
i don't need OCX , I need pure code because i want to distibute onle file (exe) only
0
 
LVL 2

Expert Comment

by:cantrell
Comment Utility
Then the answer is above (in code) by Waty for a Flat toolbar with, and, or Flat buttons.


0
 

Author Comment

by:yordan
Comment Utility
i need a clear explanation
i don't need something i can't understand
besides all i am paying a lot of points for this
0
 

Author Comment

by:yordan
Comment Utility
ok
COOL
bandit@nat.bg
thanks
0
 

Author Comment

by:yordan
Comment Utility
worked great
i'll use it always
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now