USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  Dicas

  Visual Basic    (ActiveX/Controles/DLL)

Título da Dica:  Um form ancorável
Postada em 10/1/2005 por kerplunk         
Crie uma classe e cole nela o código abaixo:
Option Explicit

Private Const vbMsgBoxTopMost As Long = &H40000

Private wrkJet As Workspace
Private dbsDockBar As Database
Private rstDefault As Recordset
Private rstEngines As Recordset
Private rstQueries As Recordset
Private rstMail As Recordset
Private rstPlugIns As Recordset

Public Function GetURL(Title As String) As String
    GetURL = ""
    With rstEngines
        .Requery
        If .BOF And .EOF Then
            Exit Function
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    GetURL = !URL
                    Exit Function
                End If
                .MoveNext
            Loop
        End If
    End With
End Function

Public Function GetProgID(Title As String) As String
    GetProgID = ""
    With rstPlugIns
        .Requery
        If .BOF And .EOF Then
            Exit Function
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    GetProgID = !ProgID
                    Exit Function
                End If
                .MoveNext
            Loop
        End If
    End With
End Function


Public Function GetDefault() As String
    GetDefault = ""
    With rstDefault
        .Requery
        If .BOF And .EOF Then
            Exit Function
        Else
            .MoveMin
            GetDefault = !Default
        End If
    End With
End Function

Public Function GetMail() As String
    GetMail = ""
    With rstMail
        .Requery
        If .BOF And .EOF Then
            Exit Function
        Else
            .MoveMin
            GetMail = !Mail
        End If
    End With
End Function


Public Sub SetMail(URL As String)
    'Validate non-blank title
    If Len(URL) = 0 Then
        MsgBox "The URL cannot be blank. Please try again", vbMsgBoxTopMost
    End If
    
    'Validate http://
    If Left(LCase(URL), 7) <> "http://" Then
        URL = "http://" & URL
    End If
        
    'add to recordset
    With rstMail
        If .BOF And .EOF Then
            .AddNew
            !Mail = URL
            .Update
        Else
            .MoveMin
            .Edit
            !Mail = URL
            .Update
        End If
    End With
End Sub


Public Sub AddEngine(Title As String, URL As String)
    Dim msg As Integer
    Dim Duplicate As Boolean
    
    'Validate non-blank title
    If Len(Title) = 0 Then
        MsgBox "The title cannot be blank. Please try again", vbMsgBoxTopMost
        Exit Sub
    End If
    
    'Validate non-blank URL
    If Len(URL) = 0 Then
        MsgBox "The URL cannot be blank. Please try again", vbMsgBoxTopMost
        Exit Sub
    End If
    
    'Validate Title <= 25 Chars
    If Len(Title) > 25 Then
        Title = Left(Title, 25)
    End If
    
    'Validate http://
    If Left(LCase(URL), 7) <> "http://" Then
        URL = "http://" & URL
    End If
    
    'validate for QueryString
    If Right(URL, 1) <> "=" Then
        msg = MsgBox("Most query URLs are constructed with a trailing '=' character. This URL may not work as expected. Do you wish to keep this URL?", vbExclamation + vbYesNo + vbMsgBoxTopMost)
        If msg = vbNo Then Exit Sub
    End If
    
    'add to recordset
    With rstEngines
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    Duplicate = True
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
        If Duplicate = False Then
            .AddNew
            !Title = Title
            !URL = URL
            .Update
        End If
    End With
End Sub

Public Sub AddPlugIn(Title As String, ProgID As String)
    Dim Duplicate As Boolean
    
    'Validate non-blank title
    If Len(Title) = 0 Then
        MsgBox "The title cannot be blank. Please try again", vbMsgBoxTopMost
        Exit Sub
    End If
    
    'Validate non-blank ProgID
    If Len(ProgID) = 0 Then
        MsgBox "The ProgID cannot be blank. Please try again", vbMsgBoxTopMost
        Exit Sub
    End If
    
    'Validate Title <= 25 Chars
    If Len(Title) > 25 Then
        Title = Left(Title, 25)
    End If
    
    'Validate Title <= 25 Chars
    If Len(ProgID) > 25 Then
        ProgID = Right(ProgID, 25)
    End If
    
    'validate ProgID
    If InStr(ProgID, ".") < 1 Then
        MsgBox "A Prog ID must contain a period The Plug-In cannot be added. This URL may not work as expected. Do you wish to keep this URL?", vbExclamation + vbMsgBoxTopMost
        Exit Sub
    End If
    
    'add to recordset
    With rstPlugIns
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    Duplicate = True
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
        If Duplicate = False Then
            .AddNew
            !Title = Title
            !ProgID = ProgID
            .Update
        End If
    End With
End Sub

Public Sub DeleteQueries()
    With rstEngines
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                .Delete
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub AddQuery(Query As String)
    Dim msg As Integer
    Dim Duplicate As Boolean
    
    'Validate non-blank Query
    If Len(Query) = 0 Then
        MsgBox "The query cannot be blank. Please try again", vbMsgBoxTopMost
    End If
    
    'Validate Query <= 255 Chars
    If Len(Query) > 255 Then
        Query = Left(Query, 255)
    End If
        
    'add to recordset
    With rstQueries
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Query = Query Then
                    Duplicate = True
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
        If Duplicate = False Then
            .AddNew
            !Query = Query
            .Update
        End If
    End With
End Sub

Public Sub DeleteEngine(Title As String)
    With rstEngines
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    .Delete
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub DeletePlugIn(Title As String)
    With rstPlugIns
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    .Delete
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub RefreshLBPlugins(LB As ListBox)
    LB.Clear
    With rstPlugIns
        .Requery
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                LB.AddItem !Title & vbTab & !ProgID
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub RefreshLBEngines(LB As ListBox)
    LB.Clear
    With rstEngines
        .Requery
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                LB.AddItem !Title & vbTab & !URL
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub RefreshCBEngines(CB As ComboBox)
    CB.Clear
    CB.AddItem "Add Item"
    CB.AddItem "MSDN"

    With rstEngines
        .Requery
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                CB.AddItem !Title
                .MoveNext
            Loop
        End If
    End With
End Sub

Public Sub ChangeDefault(Title As String)
    Dim Duplicate As Boolean
    With rstEngines
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                If !Title = Title Then
                    Duplicate = True
                    Exit Do
                End If
                .MoveNext
            Loop
        End If
    End With
    With rstDefault
        If Duplicate = True Then
            .MoveMin
            .Edit
            !Default = Title
            .Update
        End If
    End With
End Sub

Public Sub RefreshCBQueries(CB As ComboBox)
    CB.Clear
    With rstQueries
        .Requery
        If .BOF And .EOF Then
        Else
            .MoveMin
            Do Until .EOF
                CB.AddItem !Query
                .MoveNext
            Loop
        End If
    End With
End Sub

Private Sub Class_Initialize()
    Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
    Set dbsDockBar = wrkJet.OpenDatabase(App.Path & "settings.mdb")

    Set rstDefault = dbsDockBar.OpenRecordset("SELECT Default FROM tblDefault")
    Set rstEngines = dbsDockBar.OpenRecordset("SELECT Title, URL FROM tblEngines ORDER BY Title ASC")
    Set rstQueries = dbsDockBar.OpenRecordset("SELECT Query FROM tblQueries ORDER BY Query ASC")
    Set rstMail = dbsDockBar.OpenRecordset("SELECT Mail FROM tblMail")
    Set rstPlugIns = dbsDockBar.OpenRecordset("SELECT Title, ProgID FROM tblPlugIns ORDER BY Title ASC")
End Sub

Public Sub RunPlugIn(Title As String)
    On Error GoTo errtrap
    Dim ProgID As String
    Dim objPlugIn As Object
    Dim strResponse As String
    
    ProgID = GetProgID(Title)
    
    If ProgID = vbNullString Then Exit Sub
    
    Set objPlugIn = CreateObject(ProgID)
    strResponse = objPlugIn.Run
    
    'if the plug-in returns an error, let us know
    If strResponse <> vbNullString Then
        MsgBox strResponse
    End If
        
    Exit Sub
    'Good error trapping is a must when trying something like this
errtrap:
    Select Case Err.Number
        Case 429 'can't create object
            'The ProgID can't be found. Either it is misspelled or the component hasn't been registered!
            MsgBox "You have selected an invalid plug-in ID. Please check that the name is correct and the component is registered."
            Exit Sub
        Case 5 'Invalid proceedure call or argument
            'The 'run' function cannot be found in the class module
            MsgBox "The plug-in you have selected does not have a valid entry point. Please verify the object module with specified guidelines."
            Exit Sub
        Case Else
            'do NOT use the stop statement except for testing purposes.
            Stop
    End Select
End Sub

Public Function PlugInList() As Variant
    Dim arrTemp() As String
    Dim intX As Integer
    
    intX = 1
    With rstPlugIns
        .Requery
        If .BOF And .EOF Then
            PlugInList = vbNullString
            Exit Function
        Else
            .MoveMin
            Do Until .EOF
                ReDim Preserve arrTemp(1 To intX)
                arrTemp(intX) = !Title
                .MoveNext
                intX = intX + 1
            Loop
        End If
    End With
    
    PlugInList = arrTemp()
End Function

***********Fim do código de classe**************

Agora crie um módulo e cole nele o código abaixo:
Option Explicit

Public jPath As String
Public jData As String

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

Private Type APPBARDATA
        cbSize As Long
        hwnd As Long
        uCallBackMessage As Long
        uEdge As Long
        rc As RECT
        lParam As Long '  message specific
End Type

Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage As Long, pData As APPBARDATA) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Const WM_USER = &H400
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const SM_CYSCREEN = 1
Private Const SM_CXSCREEN = 0
Private Const ABM_NEW = &H0&
Private Const ABM_REMOVE = &H1&
Private Const ABM_QUERYPOS = &H2&
Private Const ABM_SETPOS = &H3&
Private Const ABM_GETSTATE = &H4&
Private Const ABM_GETTASKBARPOS = &H5&
Private Const ABM_ACTIVATE = &H6&          'lParam == TRUE/FALSE means activate/deactivate
Private Const ABM_GETAUTOHIDEBAR = &H7&
Private Const ABM_SETAUTOHIDEBAR = &H8&
Private Const ABE_LEFT = 0
Private Const ABE_TOP = 1
Private Const ABE_RIGHT = 2
Private Const ABE_BOTTOM = 3
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90
Private Const nTwipsPerInch = 1440
Private Const GWL_STYLE = (-16)

Public Enum jPosition
    jBottom = ABE_BOTTOM
    jtop = ABE_TOP
End Enum

Private jABD As APPBARDATA

Public Function ConvertTwipsToPixels(nTwips As Long, nDirection As Long) As Integer
    Dim hdc As Long
    Dim nPixelsPerInch As Long
      
    hdc = GetDC(0)
    If (nDirection = 0) Then       'Horizontal
        nPixelsPerInch = GetDeviceCaps(hdc, WU_LOGPIXELSX)
    Else                            'Vertical
        nPixelsPerInch = GetDeviceCaps(hdc, WU_LOGPIXELSY)
    End If
    
    hdc = ReleaseDC(0, hdc)
    ConvertTwipsToPixels = (nTwips / nTwipsPerInch) * nPixelsPerInch
End Function

Public Sub CreateAppBar(jForm As Form, jPos As jPosition)
    With jABD
        .cbSize = Len(jABD)
        .hwnd = jForm.hwnd
        .uCallBackMessage = WM_USER + 100
    End With
    Call SHAppBarMessage(ABM_NEW, jABD)
    
    Select Case jPos
        Case jBottom
            jABD.uEdge = ABE_BOTTOM
        Case jtop
            jABD.uEdge = ABE_TOP
    End Select
    
    Call SetRect(jABD.rc, 0, 0, GetSystemMetrics(SM_CXSCREEN), GetSystemMetrics(SM_CYSCREEN))
    Call SHAppBarMessage(ABM_QUERYPOS, jABD)
    
    Select Case jPos
        Case jBottom
            jABD.rc.Top = jABD.rc.Bottom - ConvertTwipsToPixels(jForm.Height, 1)
        Case jtop
            jABD.rc.Bottom = jABD.rc.Top + ConvertTwipsToPixels(jForm.Height, 1)
    End Select
    
    Call SHAppBarMessage(ABM_SETPOS, jABD)

    Select Case jPos
        Case jBottom
            Call SetWindowPos(jABD.hwnd, 0, jABD.rc.Left, jABD.rc.Top, jABD.rc.Right - jABD.rc.Left, jABD.rc.Bottom - jABD.rc.Top, SWP_NOZORDER Or SWP_NOACTIVATE)
        Case jtop
            Call SetWindowPos(jABD.hwnd, 0, jABD.rc.Left, jABD.rc.Top, jABD.rc.Right - jABD.rc.Left, jABD.rc.Bottom - jABD.rc.Top, SWP_NOZORDER Or SWP_NOACTIVATE)
    End Select
End Sub

Public Sub DestroyAppBar()
     Call SHAppBarMessage(ABM_REMOVE, jABD)
End Sub

Public Sub AppBarActivateMsg()
    Call SHAppBarMessage(ABM_ACTIVATE, jABD)
End Sub
*************** Fim do Módulo ******************

Depois disso dentro do evento load do form digite o comando:
CreateAppBar Me, jTop

e pronto seu form cai ancorar na parte de cima da tela.

E era isso. Até a próxima!
 


CyberWEB Network Ltda.    © Copyright 2000-2021   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página