|
|
|
|
|
|
|
|
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!
|
|
|
|
|
