'=========================================================================== ' ファイル名 : basToolBar.bas ' ファイル説明 : ツールバー関連の関数群 ' 作成者 : Uz ' E-Mail : uz@violet.plala.or.jp ' HomePage : http://www1.plala.or.jp/uz/ ' 作成日 : 1998/03/08 (Sun) ' 修正日 : 1998/03/08 (Sun) ' 備考 : なし '=========================================================================== Option Explicit '-- API 定数 Private Const GW_CHILD = 5 Private Const TBSTYLE_FLAT = &H800 Private Const WM_USER = &H400 Private Const TB_SETSTYLE = (WM_USER + 56) Private Const TB_GETSTYLE = (WM_USER + 57) '-- API 関数 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 Declare Function GetWindow Lib "user32" ( _ ByVal hwnd As Long, _ ByVal wCmd As Long _ ) As Long '//////////////////////////////////////////////////////////// ' 関数名 : SetFlatToolBar ' 目的説明 : ツールバーをフラットにする ' 前提条件 : なし ' 結果 : なし ' 引数 : tbToolBar ツールバーコントロール ' 戻り値 : なし '//////////////////////////////////////////////////////////// Public Sub SetFlatToolBar(ByRef tbToolBar As Toolbar) Dim lnghWnd As Long Dim lngOldStyle As Long Dim lngNewStyle As Long 'ウィンドウハンドルを取得 lnghWnd = GetWindow(tbToolBar.hwnd, GW_CHILD) '今のスタイルの取得 lngOldStyle = SendMessageLong(lnghWnd, TB_GETSTYLE, 0&, 0&) 'フラットのスタイルを付加 lngNewStyle = lngOldStyle Or TBSTYLE_FLAT '新しいスタイルを設定 Call SendMessageLong(lnghWnd, TB_SETSTYLE, 0&, lngNewStyle) '再描画 tbToolBar.Refresh End Sub '=========================================================================== ' ファイル名 : frmMain.frm ' ファイル説明 : フラットツールバーのテストフォーム ' 作成者 : Uz ' E-Mail : uz@violet.plala.or.jp ' HomePage : http://www1.plala.or.jp/uz/ ' 作成日 : 1998/03/08 (Sun) ' 修正日 : 1998/03/08 (Sun) ' 備考 : なし '=========================================================================== Option Explicit Private Sub Form_Load() 'ツールバーのオブジェクトを引数に渡すだけ(^_^) Call SetFlatToolBar(tlbToolbar) End Sub |