public.bas

就是定时刷新

Attribute VB_Name = "公用函数"
Public MyStr As String
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal xSrc As Integer, ByVal ySrc As Integer, ByVal dwRop As Long) As Integer
Const ERROR_SUCCESS = &H0
Const COPY_PUT = &HCC0020
'------------------------------------------------------------------
Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Any) As Long
Global Const HELP_QUIT = 2
Global Const HELP_INDEX = 3
Global Const HELP_HELPONHELP = 4
Global Const HELP_PARTIALKEY = &H105
'-------------------------------
'使窗体始终保持在最前面
Public 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
Const HWND_TOPMOST = -1
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Public Function PutWindowOnTop(pFrm As Form)
  Dim lngWindowPosition As Long
  lngWindowPosition = SetWindowPos(pFrm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function
' WindowOnTop.bas
'-----------------
'
' Use the following code in the form_load event of the form you
' want put onto of all the other forms on the screen.
'
'    Call PutWindowOnTop ( Me )
'
Function TeShuFont(FormName, WenBen As String, XiaoGuo As String, x, y, FontColor As Integer)
'程序说明:
'FormName 为窗体名称
'WenBen 为所要显示的文字
'XiaoGuo 为效果标志
'当XiaoGuo 为D、F、Y时对应为雕刻、浮雕及阴影效果
'x , y为文字显示的位置
'函数调用示例:
'在窗口Me中200,390处显示具有雕刻效果的文字“北京勘测设计研究院".
'Private Sub Form_Load()
'    Me.Show
'    Me.BackColor = QBColor(6)
'    Me.FontName = "隶书"
'    Me.FontSize = 20
'    TeShuFont Me, "北京勘测设计研究院", "F", 200, 390，5
'End Sub
    FormName.CurrentX = x
    FormName.CurrentY = y
    If Left(XiaoGuo, 1) = "d" Or Left(XiaoGuo, 1) = "D" Then
      X1 = -18: Y1 = -20
     ElseIf Left(XiaoGuo, 1) = "f" Or Left(XiaoGuo, 1) = "F" Then
      X1 = 10: Y1 = 20
     ElseIf Left(XiaoGuo, 1) = "y" Or Left(XiaoGuo, 1) = "Y" Then
      X1 = 50: Y1 = -20
    End If
    FormName.ForeColor = QBColor(15)
    FormName.Print WenBen
    FormName.CurrentX = x + X1
    FormName.CurrentY = y + Y1
    FormName.ForeColor = QBColor(FontColor)
    FormName.Print WenBen
End Function
Sub HelpFunction(lhWnd As Long, HelpCmd As Integer, HelpKey As String)
 Dim lRtn As Long 'declare the needed variables
 If HelpCmd = HELP_PARTIALKEY Then
   lRtn = WinHelp(lhWnd, App.Path + "\help.hlp", HelpCmd, HelpKey)
  Else
   lRtn = WinHelp(lhWnd, App.Path + "\help.hlp", HelpCmd, 0&)
 End If
End Sub
Sub Main()
    frmSplash.Show
    frmSplash.Refresh
    Load frmBrowser
    frmBrowser.Show
    If App.PrevInstance Then
      MsgBox ("程序已经运行，不能再次装载！"), vbExclamation
      Unload frmBrowser
    End If
End Sub
Function FileExist(FileName As String) As Boolean
'判断文件是否存在的函数
  FileExist = IIf(Dir(FileName) <> "", True, False)
End Function
Public Function SetFormPic(Tform As Object, TPic As Object) As Variant
'用时在Private Sub Form_Paint()下写入“SetFormPic Me, Picture2”，即将Picture2充满窗体
Dim I, J As Integer
For I = 0 To Tform.ScaleWidth \ TPic.Width
 For J = 0 To Tform.ScaleHeight \ TPic.Height
  Tform.PaintPicture TPic, I * TPic.Width, J * TPic.Height
 Next J
Next I
End Function