home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / access / diverses / msaccess / toolti.bas < prev   
BASIC Source File  |  1995-02-27  |  4KB  |  97 lines
  1. Option Compare Database   'Use database order for string comparisons
  2. Option Explicit
  3.  
  4.  
  5.  
  6. Function InsertToolTip () As Integer
  7.  
  8. '--Poor Mans Tool tips inserter routine by Angus Wood 100545,720
  9.  
  10. '--------------------------------------------------------------
  11. '-                                                            -
  12. '-      USAGE: In your AutoKeys Macro, assing a keystroke to  -
  13. '-             call this routine, then on your form <design   -
  14. '-             view> highlight the controls to "tip" and      -
  15. '-             trip the routine.                              -
  16. '-                                                            -
  17. '--------------------------------------------------------------
  18.  
  19. Dim FM As Form
  20. Dim CL As Control
  21. Dim CRLF As String
  22. Dim cntr As Integer
  23.  
  24.  
  25. CRLF = Chr$(13) & Chr$(10)
  26.  
  27. On Error Resume Next
  28. Set FM = Screen.ActiveForm
  29. If Err <> 0 Then Exit Function      'if no form is active then exit
  30.  
  31.     For cntr = 0 To FM.Count - 1    'loop throgh controls on form
  32.         Set CL = FM(cntr)
  33.         If CL.InSelection = True Then   'if control is selected then add info
  34.             CL.Tag = InputBox("Enter the tool tip", CL.Name)
  35.             On Error Resume Next
  36.             CL.OnMouseMove = "[Event Procedure]"
  37.             On Error Resume Next
  38.             FM.Module.InsertText "Sub " & CL.Name & "_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)" & CRLF & "ShowEventToolTip Me." & CL.Name & ", X, Y" & CRLF & "End Sub"
  39.         End If
  40.     Next
  41.  
  42. If MsgBox("Insert show procedure and TT control ?", MB_ICONQUESTION + MB_YESNO + MB_DEFBUTTON2, "Tool Tip Inserter") = IDYES Then
  43.    
  44.     Dim TTProc$
  45.     Dim TTCtl As Control
  46.     
  47.     Set TTCtl = CreateControl(FM.Name, 100, 0, 0, "ToolTip")
  48.     TTCtl.Name = "ToolTip"
  49.     TTCtl.BackColor = 8454143
  50.     TTCtl.Visible = False
  51.     TTCtl.BorderStyle = 1
  52.     TTCtl.BorderColor = 0
  53.     TTCtl.FontName = "MS Sans Serif"
  54.     TTCtl.FontWeight = 8
  55.     TTCtl.SpecialEffect = 0
  56.  
  57.  
  58.     FM.Module.InsertText "Sub ToolTip_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)" & CRLF & "Me.ToolTip.Visible = False" & CRLF & "End Sub"
  59.     FM.Module.InsertText "Sub Detail0_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)" & CRLF & "Me.ToolTip.Visible = False" & CRLF & "End Sub"
  60.     
  61.     TTCtl.OnMouseMove = "[Event Procedure]"
  62.     FM.Section(0).OnMouseMove = "[Event Procedure]"
  63.                 
  64.     TTProc$ = TTProc$ & "Sub ShowEventToolTip (frmCtl As Control, mseX As Single, mseY As Single)" & CRLF
  65.     TTProc$ = TTProc$ & "" & CRLF
  66.     TTProc$ = TTProc$ & "    On Error GoTo Crap_Out" & CRLF
  67.     TTProc$ = TTProc$ & "    Dim TT As Control" & CRLF
  68.     TTProc$ = TTProc$ & "    Set TT = [ToolTip]" & CRLF
  69.     TTProc$ = TTProc$ & "    Dim LeftVal As Single" & CRLF
  70.     TTProc$ = TTProc$ & "    TT.Caption = frmCtl.Tag" & CRLF
  71.     TTProc$ = TTProc$ & "    If IsNull(frmCtl.Tag) Then Exit Sub" & CRLF
  72.     TTProc$ = TTProc$ & "    TT.Width = Len(frmCtl.Tag) * 90" & CRLF
  73.     TTProc$ = TTProc$ & "    If frmCtl.Left < Me.Width / 2 Then" & CRLF
  74.     TTProc$ = TTProc$ & "        LeftVal = frmCtl.Left + frmCtl.Width" & CRLF
  75.     TTProc$ = TTProc$ & "    Else" & CRLF
  76.     TTProc$ = TTProc$ & "        LeftVal = frmCtl.Left - TT.Width" & CRLF
  77.     TTProc$ = TTProc$ & "    End If" & CRLF
  78.     TTProc$ = TTProc$ & "    TT.Left = LeftVal" & CRLF
  79.     TTProc$ = TTProc$ & "    TT.Top = mseY + frmCtl.Top" & CRLF
  80.     TTProc$ = TTProc$ & "    TT.Visible = True" & CRLF
  81.     TTProc$ = TTProc$ & "    Exit sub" & CRLF
  82.     TTProc$ = TTProc$ & "Crap_Out:" & CRLF
  83.     TTProc$ = TTProc$ & "TT.Visible = False" & CRLF
  84.     TTProc$ = TTProc$ & "Exit sub" & CRLF
  85.     TTProc$ = TTProc$ & "End sub" & CRLF
  86.     
  87.     FM.Module.InsertText TTProc$
  88.     
  89.     On Error Resume Next
  90.     DoCmd DoMenuItem 5, 3, 1    'compile
  91.  
  92.  
  93. End If
  94.  
  95. End Function
  96.  
  97.