mdlbase.bas

定时备份Oracle数据库和文件的程序 支持RAR压缩功能

Attribute VB_Name = "mdlBase"
'*************************************************************************
'**模 块 名：mdlBase
'**说    明：YFHome 版权所有2003 - 2004(C)
'**创 建 人：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**描    述：
'**版    本：V1.0
'*************************************************************************
Option Explicit

Public OldWindowProc As Long       '旧的窗口进程号
Public TheForm As Form             '保存的窗体信息
Public TheMenu As Menu             '保存菜单信息

'将消息传答窗口函数
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'设置窗口附加内存长型数值
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'发送修改任务栏图标
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Public Const WM_USER = &H400
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIF_MESSAGE = &H1
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2

Public Type NOTIFYICONDATA      'ICON图标数据信息
  cbSize As Long
  hwnd As Long
  uID As Long
  uFlags As Long
  uCallbackMessage As Long
  hIcon As Long
  szTip As String * 64
End Type

Private TheData As NOTIFYICONDATA

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

Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1

Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'-----

'*************************************************************************
'**函 数 名：KeepOnTop
'**输    入：F(Form) -
'**输    出：无
'**功能描述：窗体放在最前
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Sub KeepOnTop(F As Form)
  Const SWP_NOMOVE = 2
  Const SWP_NOSIZE = 1

  Const HWND_TOPMOST = -1
  Const HWND_NOTOPMOST = -2

  SetWindowPos F.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

'*************************************************************************
'**函 数 名：NewWindowProc
'**输    入：ByVal hwnd(Long)   -
'**        ：ByVal Msg(Long)    -
'**        ：ByVal wParam(Long) -
'**        ：ByVal lParam(Long) -
'**输    出：(Long) -
'**功能描述：新的窗口进程
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If Msg = TRAY_CALLBACK Then

    ' 用户单击托盘中的图标
    If lParam = WM_LBUTTONUP Then  '单击左键显示窗体
      '窗体状态为最小化
      If TheForm.WindowState = vbMinimized Then TheForm.WindowState = TheForm.LastState
      TheForm.Visible = True
      TheForm.SetFocus
      Exit Function
    End If

    If lParam = WM_RBUTTONUP Then  '单击右键键显示菜单
      TheForm.PopupMenu TheMenu
      Exit Function
    End If

  End If
  '发送其余的消息到原先的窗口信息处理进程
  NewWindowProc = CallWindowProc(OldWindowProc, hwnd, Msg, wParam, lParam)
End Function

'*************************************************************************
'**函 数 名：AddToTray
'**输    入：frm(Form) -
'**        ：mnu(Menu) -
'**输    出：无
'**功能描述：在托盘中增加窗体的图标
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Sub AddToTray(frm As Form, mnu As Menu)
  '必须在设计状态下设置ShowInTaskbar为false，因为在运行状态下该属性只读。

  ' 保存当前窗体和菜单信息
  Set TheForm = frm
  Set TheMenu = mnu

  ' 设置新的窗口信息处理进程             '窗口进程        '窗口进程地址
  OldWindowProc = SetWindowLong(frm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)

  ' 设置窗体图标的信息
  With TheData
    .uID = 0
    .hwnd = frm.hwnd
    .cbSize = Len(TheData)
    .hIcon = frm.Icon.Handle
    .uFlags = NIF_ICON
    .uCallbackMessage = TRAY_CALLBACK
    .uFlags = .uFlags Or NIF_MESSAGE
    .cbSize = Len(TheData)
  End With

  '把图标放到图盘
  Shell_NotifyIcon NIM_ADD, TheData
End Sub

'*************************************************************************
'**函 数 名：RemoveFromTray
'**输    入：无
'**输    出：无
'**功能描述：删除托盘内的图标
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Sub RemoveFromTray()
  '删除托盘内的图标

  With TheData
    .uFlags = 0
  End With
  Shell_NotifyIcon NIM_DELETE, TheData

  ' 恢复原来窗口信息处理进程.
  SetWindowLong TheForm.hwnd, GWL_WNDPROC, OldWindowProc
End Sub

'*************************************************************************
'**函 数 名：SetTrayTip
'**输    入：tip(String) -
'**输    出：无
'**功能描述：设置新的托盘图标提示
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Sub SetTrayTip(tip As String)
  With TheData
    .szTip = tip & vbNullChar
    .uFlags = NIF_TIP
  End With
  Shell_NotifyIcon NIM_MODIFY, TheData
End Sub

'*************************************************************************
'**函 数 名：SetTrayIcon
'**输    入：pic(Picture) -
'**输    出：无
'**功能描述：设置新的托盘图标
'**全局变量：
'**调用模块：
'**作    者：杨军
'**日    期：2003年04月17日
'**修 改 人：
'**日    期：
'**版    本：V1.0
'*************************************************************************
Public Sub SetTrayIcon(pic As Picture)
  ' 如果图片的格式不是ICON类型，则退出
  If pic.Type <> vbPicTypeIcon Then Exit Sub

  '更新托盘图标
  With TheData
    .hIcon = pic.Handle
    .uFlags = NIF_ICON
  End With
  Shell_NotifyIcon NIM_MODIFY, TheData
End Sub