Access交流网
  • 设为首页|收藏本站|繁体中文|手机版
  •     
  • Access培训-Access开发平台-Access行业开发

  • 首页
  • 资讯
  • 技巧
  • 源码
  • 行业
  • 资源
  • 活动
  • 关于

技巧

ACCESS数据库

启动/设置/选项/背景

修复/压缩

安全/加密/解密

快捷键

版本升级/其它等

数据表

命名方式/设计规范

表设计

查询

Sql语言基础

选择查询

更新查询

删除查询

追加查询

生成表查询

交叉表查询

SQL特定查询

查询参数

查询综合应用

界面/窗体/控件

标签

文本框

命令按钮

组合框/列表框

选项组/复选框/选项按钮

选项卡

子窗体

窗体本身/综合应用

其它

报表打印

报表设计

高级报表

模块/函数/VBA/API/系统

VBA基础

内置函数

调试/跟踪/Debug

模块/类模块

API/COM/系统相关

字符数字日期

网络通信游戏

加密解密安全

文件处理

经典算法

宏/菜单/工具栏/功能区

宏/脚本

菜单/工具栏

功能区/Ribbon

图表/图形/图像/多媒体

图表

图形/图像

音频

视频/动画

DAO/链接表/ADO/ADP

DAO/链接表/ODBC

ADO/RDO

ADP

ActiveX/第三方控件/插件

Treeview树控件

ListView列表控件

Toolbar工具栏控件

微软其它控件

Dbi-Tech

CodeJock

Grid++Report

FastReport

ComponentOne

加载项/插件/Addin

OFFICE集成/导入导出/交互

Excel导入导出/交互

Word导入导出/交互

PPT交互

Outlook控制/邮件

Text文本文件/INI/CSV

PDF/SWF/XML格式

CAD格式

Sharepoint/其它Office

SqlServer/其它数据库

表

视图

存储过程/触发器

函数

用户/权限/安全

调试/维护

SqlServer其它/综合

发布/打包/文档/帮助

开发版/运行时

打包/发布/部署

开发文档/帮助制作

Access完整行业系统

采购管理系统

销售管理系统

仓库管理系统

人力资源管理HRM

CRM管理系统

MRP/ERP管理系统

BRP/流程优化

其它管理系统

心得/经验/绝招
其它/杂项
Excel技巧

Excel应用与操作

Excel开发编程

Word技巧

Word应用与操作

Word开发编程

Outlook技巧

Outlook应用与操作

Outlook开发编程

热门文章

  • 获取唯一的文件名
  • 未公开的SysCmd功能
  • ACCESS2007如何利..
  • VBA语句集400句(一部..
  • 如何用VBA更改数据库密码
  • 4 种常用加密算法-6-r..

最新文章

  • Access或VB VBA..
  • 关于VBA的0、""(空字..
  • Access导出函数Out..
  • Access日期与日期区间..
  • RecordSource ..
  • Access子窗体事件控制..

联系方式

Access交流网(免费Access交流)

QQ:18449932 

网  址:www.access-cn.com

当前位置:首页 > 技巧 > 模块/函数/VBA/API/系统 > VBA基础
VBA基础

自动更新链接表的模块

    刷新表链接                                 '
'                                                              '
'    这个模块包含用于刷新到后台数据库表的链接的函数,如果那    '
'    些表可用的话。改写自罗斯文商贸数据库!这可是宝库!        '
'                                                              '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit           ' 要求变量在使用以前明确声明
Option Compare Database   ' 字符串比较使用数据库次序
'=======================================================================
'设定部分:
Private Const CheckTableName = "培训项目"
'"培训项目"表是我的实例数据库中的表,你应该改成你自己后台数据库的链接表名。
Private Const TablePassword = "12345"
'"12345"是我的后台数据库打开的密码,你应该改成你自己后台数据库的打开密码。
Private Const conAppTitle = "前台数据库"
Private Const conBackAppTitle = "后台数据库.mdb"
'"前台数据库"是本数据库的名称,可以不用加“.mdb”
'"后台数据库.mdb"是链接的后台数据库的名称,必须有".mdb"

'
'以下不用改
'=======================================================================

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

Type MSA_OPENFILENAME
    ' 用于打开文件对话框过滤器的过滤字符串。
    ' 使用 MSA_CreateFilterString() 来创建它。
    ' 默认(Default) = 所有文件, *.*
    strFilter As String
    ' 用于显示的初始过滤器。
    ' 默认(Default) = 1
    lngFilterIndex As Long
    ' 对话框所作用的初始目录。
    ' 默认(Default) = 当前工作目录。
    strInitialDir As String
    ' 初始文件名。
    ' 默认(Default) = ""
    strInitialFile As String
    strDialogTitle As String
    ' 默认的文件扩展名,如果用户没有指定一个的话,将使用它。
    ' 默认(Default) = 系统值 (打开文件, 保存文件)。
    strDefaultExtension As String
    ' 所使用的标志 (参看“常量”(Const) 列表)
    ' 默认(Default) = 无标志。
    lngFlags As Long
    ' 所选取文件的完整路径。在打开文件(OpenFile)时,如果用户点取了
    ' 一个不存在的文件,将只返回 "File Name"(文件名)框中的文本。
    strFullPathReturned As String
    ' 所选取文件的文件名。
    strFileNameReturned As String
    ' 文件名(strFileNameReturned)开始位置在完整路径中的偏移。
    intFileOffset As Integer
    '文件扩展名开始位置在完整路径(strFullPathReturned)中的偏移。
    intFileExtension As Integer
End Type

Const ALLFILES = "所有文件"

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10

Function FindFile(strSearchPath, strTitle, strFilterFilename, strFilterExtname) As String
' 显示打开文件对话框让用户定位
' 特定的文件。返回文件的完整路径。
   
    Dim msaof As MSA_OPENFILENAME
   
    ' 给对话框设置选项。
    Msaof.strDialogTitle = strTitle
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString(strFilterFilename, strFilterExtname)
   
    ' 调用打开文件对话框例程。
    MSA_GetOpenFileName msaof
   
    ' 返回路径和文件名。
    FindFile = Trim(msaof.strFullPathReturned)
   
End Function


Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' 从所传递的实参中创建一个过滤器字符串。
' 如果没有传递进任何实参,将返回 "" 。
' 期望传进偶数个实参(过滤字符串、扩展名), 但
' 如果传进奇数个,将附加 *.* 。
   
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = Ubound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
' 从一个竖条分隔的字符串创建一个过滤字符串。
' 该字符串应具有(过滤名称|扩展名)对,例如,"access 数据库|*.mdb|所有文件|*.*"
' 如果最后一个过滤对没有扩展名,将加上 *.* 。
' 这里代码将忽略任何空字符串,例如, "||" 对。
' 如果传进的字符串是空的,就返回 "" 。

   
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1

    ' 一旦我们找到竖条,就加入字符串。
    ' 忽略任何空字符串(不允许空字符串)。
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
        
    ' 获取最后一个子串(假定串 strFilterIn 不以竖条 | 结尾)。
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
   
    ' 如果最后一个子串没有扩展名,那么添加 *.* 。
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
   
    ' 如果存在任何过滤字符串,添加空结尾字符 vbNullChar 。
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
   
    MSA_ConvertFilterString = strFilter
End Function

Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' 打开保存文件对话框。
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' 用默认值打开保存文件对话框。

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetSaveFileName = strRet
End Function

Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' 打开 打开文件对话框。
   
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
End Function

Function MSA_SimpleGetOpenFileName() As String
' 用默认值打开打开文件对话框。

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
   
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
   
    MSA_SimpleGetOpenFileName = strRet
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' 这一个子过程将 win32 结构转换到友好的 MSaccess 结构。
   
    Msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' 这一个子过程将友好的 MSaccess 结构转换到 win32 结构。
   
    Dim strFile As String * 512

    ' 初始化该结构的某些部分。
    Of.hwndOwner = Application.hWndaccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
   
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
   
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511

    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511

    of.lpstrTitle = msaof.strDialogTitle

    of.lpstrInitialDir = msaof.strInitialDir
   
    of.lpstrDefExt = msaof.strDefaultExtension

    of.Flags = msaof.lngFlags
   
    of.lStructSize = Len(of)
End Sub

Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接;如果链接存在且正确的话,返回 True 。
   
    Dim dbs As Database, rst As Recordset
   
    Set dbs = CurrentDb

    ' 打开链接表查看表链接信息是否正确。
    On Error Resume Next
    Set rst = dbs.OpenRecordset(CheckTableName)
    rst.Close

    ' 如果没有错误,返回 True 。
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
   
End Function

Private Function RefreshLinks(strFileName As String) As Boolean
' 刷新到提供表的数据库的链接。如果成功的话返回 True 。

    Dim dbs As Database
    Dim tdf As TableDef

    ' 循环处理此数据库的所有表。
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' 如果表有一个连接串,那么该表是一个链接表。
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName & ";PWD=" + TablePassword
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' 重新链接该表。
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf

    RefreshLinks = True        ' 完成重链接。
   
End Function

Public Function RelinkTables() As Boolean
' 尝试刷新连到“后台数据库”数据库的链接。
' 如果成功,返回 True 。

    Dim strFileName As String
    Dim intError As Integer
    Dim strError As String
    Dim BackDataDir As String
   
    Const conMaxTables = 8
    Const conNonExistentTable = 3011
    Const conNotNorthwind = 3078
    Const conNwindNotFound = 3024
    Const conaccessDenied = 3051
    Const conReadOnlyDatabase = 3027
   
   
    '在注册表中读取“后台数据库”的位置
    BackDataDir = GetSetting(conAppTitle, conAppTitle, "BackDataDir", "")
    If (Dir(BackDataDir & conBackAppTitle) <> "") Then
        strFileName = BackDataDir & conBackAppTitle
    Else
        ' 不能找到“后台数据库”,所以显示打开文件对话框。
        MsgBox "不能找到“" + conBackAppTitle + "”数据库中的链接表。您必须定位“" + _
        conBackAppTitle + "”数据库以便能使用“" _
        & conAppTitle & "”数据库程序。", vbExclamation
        strFileName = FindFile("C:\", "查找 " + conBackAppTitle, "Microsoft access 数据库", "*.mdb;*.mde")
        If Dir(strFileName) = conBackAppTitle Then
            BackDataDir = Left(strFileName, Len(strFileName) - Len(conBackAppTitle))
            SaveSetting conAppTitle, conAppTitle, "BackDataDir", BackDataDir
        Else
            strError = "抱歉, 您必须定位“" + conBackAppTitle + "”数据库以打开“" & conAppTitle & "”数据库程序。"
            GoTo Exit_Failed
            
        End If
    End If

    ' 修复链接。
    If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
   
    ' 如果失败, 显示一个错误消息。
    Select Case Err
    Case conNonExistentTable, conNotNorthwind
        strError = "文件 '" & strFileName & "' 不包含所要求的数据库表。"
    Case Err = conNwindNotFound
        strError = "直到您定位了“" + conBackAppTitle + ".mdb”数据库,您不能运行本“" & conAppTitle & "”程序。"
    Case Err = conaccessDenied
        strError = "因为 " & strFileName & " 是只读的或只读共享的,您不能打开它。"
    Case Err = conReadOnlyDatabase
        strError = "因为 " & conAppTitle & " 是只读的或只读共享的,您不能重新链接表。"
    Case Else
        strError = Err.Description
    End Select
   
Exit_Failed:
    MsgBox strError, vbCritical
    RelinkTables = False
   
End Function



(DAO_链接表_ODBC-相关文章技巧链接):
获取Access所有链接表的名称
发布人:未知-IT学院  
分享到:
点击次数:  更新时间:2006-11-18 23:35:50  【打印此页】  【关闭】
上一条:API改变主窗口背景  下一条:模块的使用技巧



相关文章

  • • Access或VB VBA判断数组的值是否为空的几种方法
  • • 关于VBA的0、""(空字符串)、Null、Empty、与 Nothing 的区别
  • • Access导出函数OutPutto解释
  • • Access日期与日期区间的筛选
  • • RecordSource SourceObject ControlSource属性的区别
  • • Access子窗体事件控制父窗体
  • • 事件​change和AfterUpdate的区别
  • • 代码修改完善方法示例(初学者必读)

热门文章

  • [2009-08-04] 判断一个表中某个字段中是否存在某个值的Acchelp_ValueIsExist函access数据库
  • [2013-09-23] vba中RecordSource与RecordSet的区别access数据库
  • [2004-01-06] 取得汉语拼音的函数access数据库
  • [2005-09-09] 将treeview中节点数据保存为嵌套格式XML文档access数据库
  • [2005-02-04] 从表的OLE字段中读写文件access数据库
  • [2013-08-12] 【技巧】format函数的妙用-解决时间错误的方法access数据库

热门产品

公司动态|在线留言|在线反馈|友情链接|会员中心|站内搜索|网站地图

Access交流网 版权所有 1999-2018 粤ICP备10043721号

QQ:18449932

Access应用 Access培训 Access开发 Access平台

access|数据库|access下载|access教程|access视频|access软件

Powered by MetInfo 5.3.12 ©2008-2023  www.metinfo.cn