Filed under: Excel VBA 範例, Top, UserForm

浮動式按鈕

by chijanzen on 十二月 28th, 2008 | View: 2,700 views

Tags

No Tags

Comments (0)

索引	B0026
主題	浮動式按鈕
版本	>= 10.0(Office 2002)
說明	這是我化名中國龍時做的一段小程式，也將它收錄到Plog範例中
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("Floating").Delete
    ThisWorkbook.Saved = True
End Sub
　

Private Sub Workbook_Open()
FormShow
End Sub　

Code

Sub FormShow()
UserForm1.Show 0
End Sub
　

Sub CreateToolBar()
Dim cbr As CommandBarButton
    On Error Resume Next
    Application.CommandBars("Formatting").Controls("Floating").Delete
    With ThisWorkbook.Sheets("Sheet1").Shapes("Image1")
        .Visible = True
        .Copy
        .Visible = False
    End With
    Set cbr = Application.CommandBars("Formatting").Controls. _
            Add(msoControlButton, , , , True)
    With cbr
        .Caption = "Floating"
        .Style = msoButtonIcon
        .PasteFace
        .OnAction = "FormShow"
        .Width = 0
    End With
End Sub　

Code

Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" ( _
        ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function SHGetSpecialFolderLocation Lib "Shell32" ( _
        ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" ( _
        ByVal pidl As Long, ByVal szPath As String) As Long
Const MAX_PATH = 260
Dim pidl As Long, S As String
Const CSIDL_DESKTOP = &H0&    '桌面
Const CSIDL_PERSONAL = &H5    'My Documents
Const CSIDL_FAVORITES = &H6&    '我的最愛
　

Sub PERSONAL()
    ID = CSIDL_PERSONAL    ' 「我的文件」資料夾
    S = String(MAX_PATH, 0)
    SHGetSpecialFolderLocation 0, ID, pidl
    SHGetPathFromIDList pidl, S
    S = (Left(S, InStr(S, Chr(0)) - 1))
    ActiveWorkbook.FollowHyperlink Address:=S, NewWindow:=True
End Sub
　

Sub FAVORITES()
    ID = CSIDL_FAVORITES    ' 「我的最愛」資料夾
    S = String(MAX_PATH, 0)
    SHGetSpecialFolderLocation 0, ID, pidl
    SHGetPathFromIDList pidl, S
    S = (Left(S, InStr(S, Chr(0)) - 1))
    ActiveWorkbook.FollowHyperlink Address:=S, NewWindow:=True
End Sub
　

Sub DESKTOP()
    ID = CSIDL_DESKTOP    ' 「桌面」資料夾
    S = String(MAX_PATH, 0)
    SHGetSpecialFolderLocation 0, ID, pidl
    SHGetPathFromIDList pidl, S
    S = (Left(S, InStr(S, Chr(0)) - 1))
    ActiveWorkbook.FollowHyperlink Address:=S, NewWindow:=True
End Sub
　

Sub IEHome()
ActiveWorkbook.FollowHyperlink Address:="http://chijanzen.net/", NewWindow:=True
End Sub
　　

Code

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, _
        ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
        ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, _
        ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
        ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
        ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
        ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, _
        ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
        ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
        lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTBOTTOMRIGHT = 2    '移動
Private hwnd As Long, Clicked As Boolean, Refresh As Boolean
　

Private Sub MakeRegion(hDC As Long, Width As Long, Height As Long)
'重新組合窗體區域
Dim X As Long, Y As Long, xStart As Long, FirstRgn As Boolean
Dim FullRgn As Long, LineRgn As Long, InLine As Boolean
    DoEvents
    For Y = 0 To Height - 1
        For X = 0 To Width
            '取得一個點(Pixel)的顏色
            If GetPixel(hDC, X, Y) = vbWhite Or X = Width Then
                If InLine Then
                    'CreateRectRgn:創建一個由點X1，Y1和X2，Y2描述的矩形區域
                    InLine = False: LineRgn = CreateRectRgn(xStart, Y, X, Y + 1)
                    If Not FirstRgn Then
                        FullRgn = LineRgn
                        FirstRgn = True
                    Else
                        'CombineRgn函數用組合兩個區域（可以是加、減、異或、或等組合）
                        '(RGN_OR)設置為兩個區域相加
                        CombineRgn FullRgn, FullRgn, LineRgn, 2
                    End If
                End If
            Else
                If Not InLine Then InLine = True: xStart = X
            End If
        Next
    Next
    'SetWindowRgn函數用於設置窗口的顯示區域
    SetWindowRgn hwnd, FullRgn, True
    DeleteObject LineRgn: DeleteObject FullRgn
End Sub
　

Private Sub Image1_Click()
PERSONAL
End Sub
　

Private Sub Image2_Click()
DESKTOP
End Sub
　

Private Sub Image3_Click()
FAVORITES
End Sub
　

Private Sub Image4_Click()
IEHome
End Sub
　

Private Sub Image5_Click()
CreateToolBar
Unload Me
End Sub
　

Private Sub Image6_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
        ByVal X As Single, ByVal Y As Single)
    hwnd = FindWindow(vbNullString, Me.Caption)
    ReleaseCapture    '為當前應用程序釋放滑鼠的擷取
    SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, ByVal 0&
End Sub
　

Private Sub UserForm_Activate()
MakeRegion GetDC(hwnd), 320, 130
End Sub
　

Private Sub UserForm_Initialize()
' Image 191 x 159 (pixels) -> 143.25 x 119.25 (points)
Dim lngMe As Long
    hwnd = FindWindow(vbNullString, Me.Caption)
    '該函數獲得有關指定窗口的信息'-16:獲得窗口風格
    'WS_CAPTION As Long = &HC00000       '(標題)
    lngMe = GetWindowLong(hwnd, -16) And Not &HC00000    '去標頭
    SetWindowLong hwnd, -16, lngMe: DrawMenuBar hwnd
    '獲得擴展窗日風格
    lngMe = GetWindowLong(hwnd, -20) And Not &H1&    '去邊框
    SetWindowLong hwnd, -20, lngMe
    Me.Width = 250: Me.Height = 119.25
End Sub
　　