access数据库：常见的VBA问题，ＦＱＡ一。

先在VBA中引用"Microsoft Office 10.0 Object Library"以上的版本.

只用ado列出所有的表:
Public Function listalltable()

    Dim rstSchema As ADODB.Recordset
    Dim strCnn As String
       
    Set cnn2 = CurrentProject.Connection
       
    Set rstSchema = cnn2.OpenSchema(adSchemaTables)

        Do Until rstSchema.EOF
            Debug.Print "Table name: " & _
                rstSchema!TABLE_NAME & vbCr & _
                "Table type: " & rstSchema!TABLE_TYPE & vbCr
            rstSchema.MoveNext
        Loop
    rstSchema.Close
   
    cnn2.Close
   
End Function
------------------------------------------------------
如何把文本字段的输入法模式全部关掉？不要手动
把下面这个函数运行一遍

Function getTableInfo()
'引用DAO
Dim mydb As DAO.DATABASE
Dim myT As DAO.TableDef
Dim myFld As DAO.Field
Dim p
Set mydb = CurrentDb
For Each myT In mydb.TableDefs
    For Each myFld In myT.Fields
        Debug.Print myFld.Name
        For Each p In myFld.Properties
            Debug.Print p.Name
        Next
        If myFld.Properties("type") = dbText And Left(myT.Name, 4) <> "msys" Then
            myFld.Properties("ImeMode") = 2
            '1 开
            '2 关
            '0 随便
        End If
    Next
Next
End Function
--------------------------------------------------------
如何隐藏access数据库窗口:
access窗口分3种,

主窗口,就是有access菜单的那个
数据库窗口,就是显示表名称,查询名称,你自己的窗体名称的那个窗口
用户自建窗口,就是你自己建立的窗口

答:

把下面代码放在窗体中
DoCmd.SelectObject acForm,"你的窗体名", True

DoCmd.RunCommand acCmdWindowHide
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
如何关闭已经打开的所有窗体？
 
Private Sub FORM_Load()
　　Do Until Application.FORMs.Count = 1
　　　　If Application.FORMs(0).Name <> Me.Name Then
　　　　　　DoCmd.Close acFORM, Application.FORMs(0).Name
　　　　Else
　　　　　　DoCmd.Close acFORM, Application.FORMs(1).Name
　　　　End If
　　Loop
End Sub
因为每次关闭一个窗体，Application.FORMs对象集合都会发生变化，所以不能用 for each...in　Application.FORMs 来循环关闭窗体。

用 for each 也可以

Private Sub FORM_Load()
    dim frm as form
    do until application.forms.count = 1
        for each frm in application.forms
            if frm.name <> "username" then docmd.close acform, frm.name
        next
    loop
End Sub
 
 >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
如何保存子窗体的动态查询结果？

有一包含子窗体的窗体，主窗体有一文本框，子窗体的数据根据文本框的内容显示，在主窗体上加一“保存”按钮，可将子窗体的动态查询结果保存到一个新表中，请问该按钮的代码如何写，（急需！）向各位高手求助，谢谢！

你先新建一个结构和结果数据一样的空表，然后在按钮的 click 事件里面写入以下代码
DoCmd.RunSQL "INSERT INTO 表 " & ch1.Form.RecordSource
' ch1 为子窗体控件的名称

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

用 VBA 打开一个文件夹。（如 E:/temp）就好象打开“我的文档”文件夹一样，可以看到里面的东东。
：：：：：可以用通用对话框先得到文件名，再利用VBA打开不就可以了吗
有现成控件_ commondialog:
commondialog1.showopen
mypath = commondialog1.filename
myfile = commondialog1.filetitle
添加部件（工程--》部件--》Microsoft Common Dialog Control 6.0）然后就在工具箱有commondialog控件了
commondialog1.showopen
mypath = commondialog1.filename
myfile = commondialog1.filetitle

》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》》

当用ShowOpen控件让用户选择打开文件的时候，怎么获得用户选择了“打开”还是“取消”？或者是“X”？多谢！
With CommonDialog1
        .CancelError = False
        .InitDir = StrAppPath
        .DialogTitle = "请选择数据库"
        .Filter = "*.mdb|*.MDB"
        .ShowOpen
    End With
    If CommonDialog1.FileTitle <> "" Then
         msgbox "取消"
    else
         msgbox "已选择"
    end if
111111111111111111
With dlgCommonDialog
        .DialogTitle = "Open"
        .Flags = &H4
        .CancelError = True
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "java文件(*.java)|*.java|HTML文件(*.html;*.htm)|*.html;*.htm|文本文件(*.txt)|*.txt|All Files (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
----------------------------------------------------------
用excel.application打开一个个excel工作薄，如何在关闭时不弹出（是否要保存对工作薄的修改的对框）。

也就是说不保存修改的内容就退出
xlsheet.Application.DisplayAlerts=false
xlsheet.quit
。。。。。。。。。。。。。。。。。。。。
dim xlApp as excel.application
    dim xlBook as excel.workbook
    dim xlsheet as excel.worksheet
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False ‘隐藏EXCEL应用程序窗口
    Set xlBook = xlApp.Workbooks.Open("excel.xls")
    Set xlSheet = xlBook.Worksheets(1) 
    ...
    xlbook.save
    xlbook.close
    xlapp.quit
    set xlbook=nothing
    set xlapp=nothing

2.控件数组，text(0)-text(40)，用index循环
或者：me.control("text" & i).text = ""
3.open "c:/" & format(NOW(),"YYYYMMDDHHMMSS") & ".tmp" for output as #1
4.用报表工具画（水晶或者Active Report）
------------------------------------------------------------------------------------------------能否将一个文件作为一条记录保存在ACCESS数据库里？：

可以将文件以长二进制方式存放在OLE字段中
Public Function GetFromFile(strTable As String, strField As String, strFilter As String, objFileName As String) As Boolean

'============================================================
'　过程函数名： CommModule.GetFromFile　类型：Function
'　参数：
'　　　　 strTable (String)　　：准备保存图形数据的表名称
'　　　　 strField (String)　　：准备保存图形数据的字段名称
'　　　　 strFilter (String)　 ：打开表的过滤字符串，用于定位并确保被打开的表的数据的唯一性
'　　　　 objFileName (String) ：准备输入到表里边的图象文件名称
'　返回：如果保存成功，返回True，如果失败，返回False
'-------------------------------------------------------------
'　说明：把图象文件的数据保存到表里边
'-------------------------------------------------------------
'　修订历史：
'=============================================================
Dim recset　　 As ADODB.Recordset, FileData() As Byte, FileNo As Long, FileSize As Long, strSQL As String

　　strSQL = "Select " & strField & " From " & strTable & " Where " & strFilter & ";"
　　Set recset = New ADODB.Recordset
　　recset.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
　　GetFromFile = True
　　If recset(strField).Type <> DB_OLE Or Not IsFileName(objFileName) Then
　　　　GetFromFile = False　　　　 '如果字段不是OLE字段，或者文件不存在，返回错误
　　　　GoTo EndGetFromFile
　　End If
　　If recset.EOF Then　　　　　　　'如果记录不存在，返回错误
　　　　GetFromFile = False
　　　　GoTo EndGetFromFile
　　End If
　　FileSize = GetFileSize(objFileName) '如果被打开的文件大小为零，返回错误
　　If FileSize <= 0 Then
　　　　GetFromFile = False
　　　　GoTo EndGetFromFile
　　End If
　　ReDim FileData(FileSize)　　　　　　'重新初始化数组
　　FileNo = FreeFile　　　　　　　　　 '获取一个空闲的文件号
　　Open objFileName For Binary As #FileNo　'打开文件
　　Get #FileNo, , FileData()　　　　　 '读取文件内容到数组
　　Close #FileNo　　　　　　　　　　　 '关闭文件
　　recset(strField).value = FileData() '保存数据
　　recset.Update　　　　　　　　　　　 '更新数据
　　Erase FileData　　　　　　　　　　　'释放内存
EndGetFromfile:
　　recset.Close　　　　　　　　　　　　'关闭RecordSet
　　Set recset = Nothing　　　　　　　　'释放内存
End Function

Public Function SaveToFile(strTable As String, strField As String, strFilter As String, strFileName As String) As Boolean
'============================================================
'　过程函数名： CommModule.SaveToFile 类型：Function
'　参数：
'　　　　 strTable (String)　　：保存图形数据的表名称
'　　　　 strField (String)　　：保存图形数据的字段名称
'　　　　 strFilter (String)　 ：打开表的过滤字符串，用于定位并确保被打开的表的纪录的唯一性
'　　　　 strFileName (String) ：准备保存的图象的文件名称
'　返回：如果保存成功，返回True，如果失败，返回False
'-------------------------------------------------------------
'　说明：把由GetFromFile函数保存到表中OLE字段的数据还原到文件
'-------------------------------------------------------------
'　修订历史：
'=============================================================
Dim recset　　 As ADODB.Recordset, FileData() As Byte, FileNo As Long, FileSize As Long, strSQL As String

　　strSQL = "Select " & strField & " From " & strTable & " Where " & strFilter & ";"
　　Set recset = New ADODB.Recordset
　　recset.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
　　SaveToFile = True
　　If recset(strField).Type <> DB_OLE Then
　　　　SaveToFile = False　　　　 '如果字段不是OLE字段，返回错误
　　　　GoTo EndSaveToFile
　　End If
　　If recset.EOF Then　　　　　　　'如果记录不存在，返回错误
　　　　SaveToFile = False
　　　　GoTo EndSaveToFile
　　End If
　　FileNo = FreeFile
　　Open strFileName For Binary As #FileNo
　　ReDim FileData(recset(strField).ActualSize) '重新初始化数组
　　FileData() = recset(strField).GetChunk(recset(strField).ActualSize) '把OLE字段的内容保存到数组
　　Put #FileNo, , FileData()　 '把数组内容保存到文件
　　Close #FileNo
　　Erase FileData
EndSaveTofile:
　　recset.Close
　　Set recset = Nothing
End Function
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
修改了菜单栏/工具栏后如何恢复默认？
恢复默认菜单和工具栏的办法

引用 Microsoft Office 9.0 Object Library
执行如下过程：

Public Sub EnableDefaultMenu()
　　Dim oBar As CommandBar
　　　　　
　　Set oBar = CommandBars("Menu Bar")
　　oBar.Reset
End Sub

恢复默认菜单和工具栏，搞定！
注：Menu Bar是指ACCESS的主菜单
---------用这个把：

Public Sub EnableDefaultMenu()
On Error Resume Next
Dim obar As CommandBar
　　For Each obar In Application.CommandBars
　　　　obar.Reset
　　Next
End Sub
--------------
 Dim oBar As CommandBar
     
  Set oBar = Application.CommandBars("Menu Bar")
  oBar.Enabled = True
--------------------------
在调试窗口输入EnableDefaultMenu然后回车。
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

如何用access开一个ie窗口，然后再关闭？
Option Compare Database
'引用Microsoft Internet Control来实现对IE的调用
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MINIMIZE = &HF020&
Private Const WM_CLOSE = &H10
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim windowsH As Long

Private Sub open_mop()
Dim ie As New InternetExplorer
ie.Visible = True
ie.Navigate "http://www.mopsite.com"
SendMessage ie.hwnd, WM_SYSCOMMAND, SC_MINIMIZE, "&O"
windowsH = ie.hwnd
Debug.Print ie.hwnd

'PostMessage ie.hwnd, WM_CLOSE, 0, 0        '关闭窗口

End Sub

Private Sub close_mop()
a = FindWindow(vbNullString, "猫扑的大杂烩 - Microsoft Internet Explorer")
Debug.Print a
b = PostMessage(a, WM_CLOSE, 0, 0)
Debug.Print b
End Sub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
如何引用/打开外部数据库的窗体？
方法很多，请不要局限于下面的代码：
'引用外部数据库的窗体
'************ Code Start *************
Private Declare Function apiSetForegroundWindow Lib "user32" _
Alias "SetForegroundWindow" _
(ByVal hwnd As Long) _
As Long

Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) _
As Long

Private Const SW_MAXIMIZE = 3
Private Const SW_NORMAL = 1

Function fOpenRemoteForm(strMDB As String, _
strForm As String, _
Optional intView As Variant) _
As Boolean

Dim objAccess As Access.Application
Dim lngRet As Long

On Error GoTo fOpenRemoteForm_Err

    If IsMissing(intView) Then intView = acViewNormal

        If Len(Dir(strMDB)) > 0 Then
            Set objAccess = New Access.Application
            With objAccess
                lngRet = apiSetForegroundWindow(.hWndAccessApp)
                lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL)
                'the first call to ShowWindow doesn't seem to do anything
                lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL)
                .OpenCurrentDatabase strMDB
                .DoCmd.OpenForm strForm, intView
                Do While Len(.CurrentDb.name) > 0
                    DoEvents
                Loop
            End With
        End If

fOpenRemoteForm_Exit:
On Error Resume Next
    objAccess.Quit
    Set objAccess = Nothing
    Exit Function
fOpenRemoteForm_Err:
    fOpenRemoteForm = False
    Select Case Err.Number
        Case 7866:
            'mdb is already exclusively opened
            MsgBox "The database you specified " & vbCrLf & strMDB & _
                    vbCrLf & "is currently open in exclusive mode. " & vbCrLf _
                    & vbCrLf & "Please reopen in shared mode and try again", _
                    vbExclamation + vbOKOnly, "Could not open database."
        Case 2102:
            'form doesn't exist
            MsgBox "The Form '" & strForm & _
                    "' doesn't exist in the Database " _
                    & vbCrLf & strMDB, _
                    vbExclamation + vbOKOnly, "Form not found"
        Case 7952:
            'user closed mdb
            fOpenRemoteForm = True
        Case Else:
            'MsgBox "Error#: " & Err.Number & vbCrLf & Err.Description, _
                    vbCritical + vbOKOnly, "Runtime error"
    End Select
Resume fOpenRemoteForm_Exit
End Function

Private Sub 命令0_Click()
    fOpenRemoteForm CurrentProject.path & "/ftpdown.mdb", "窗体2"
End Sub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
如何得知一个月有多少天？

创建自定义函数如下：
Public Function my_daily(nowdate As Date) As Integer
Dim my_date_first_day As Date '定义当前月的第一天
Dim my_date_last_day As Date '定义下個月的第一天
Dim my_date_current_day As Integer '定义今天为当前月的第几天

my_date_current_day = Day(nowdate)
my_date_first_day = DateAdd("d", -(my_date_current_day - 1), nowdate)
my_date_last_day = DateAdd("m", 1, my_date_first_day)

my_daily = DateDiff("d", my_date_first_day, my_date_last_day)
End Function

如:my_daily("2002-2-1") 返回28
my_daily("2002-7-1") 返回31"
-------------------------------------------------------------
在第一个启动的窗体的 form_open 事件里面加入程序代码如下：
DoCmd.SelectObject acForm, "frmCC", True
DoCmd.RunCommand acCmdWindowHide
注: frmCC窗体必须存在，当然你打开表，报表都可以，主要是为了把焦点从数据库窗体出去

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
如何四舍五入？::
Public Function 四舍五入(源数据 As Currency, 小数位数 As Integer) As Currency       ''自定义四舍五入函数
    ''由于 源数据 的数据类型声明和 返回值 的数据类型声明，所以小数最多定义到4位
   
    四舍五入 = Fix((源数据 + Sgn(源数据) * 0.5 / 10 ^ 小数位数) * 10 ^ 小数位数) / 10 ^ 小数位数
End Function-----------------------
---
select Fix((字段名 + Sgn(字段名) * 0.5 / 10 ^ 2) * 10 ^ 2) / 10 ^ 2 as 四舍五入 from tablename

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

如何将表中的数据导出到电子表格中

有很多方法都可将数据库中某个表的数据导出到电子表格中，例如通过创建Access.Application，可以利用Access本身的导出功能实现将表中的数据导出到电子表格中。但是这种方法会占用较多的系统资源，并且缺乏通用性。如果一个数据库没有导出的功能怎么办？下面的这段程序代码利用记录集实现导出的功能，这种做法的好处是显而易见的：你可以控制要导出的数据，而不用将整个表的内容都导出到电子表格中。为简单起见下面的程序代码仍将整个表的数据导出到电子表格中。如果你有兴趣的话，对下面的代码稍加改动就可做成更为通用的一个类或是一个控件。

首先在窗体上添加一个标签控件和一个命令按钮，然后在工程中添加对DAO引用。利用下面的程序代码就可将表中的数据导出到电子表格中。

Option Explicit

Private Sub Command1_Click()
Dim tempDB As Database
Dim i As Integer 循环计数器
Dim j As Integer
Dim rCount As Long 记录的个数
Dim xl As Object OLE自动化对象
Dim Sn As Recordset
Screen.MousePointer = 11
Label1.Caption = "打开数据库..."
Label1.Refresh
Set tempDB = Workspaces(0).OpenDatabase("Nwind.mdb")
Label1.Caption = "创建Excel对象..."
Label1.Refresh
Set xl = CreateObject("Excel.Sheet.8")
Label1.Caption = "创建快照型记录集..."
Label1.Refresh
Set Sn = tempDB.OpenRecordset("Customers", dbOpenSnapshot)

If Sn.RecordCount > 0 Then
Label1.Caption = "将字段名添加到电子表格中"
Label1.Refresh
For i = 0 To Sn.Fields.Count - 1
xl.Worksheets(1).cells(1, i + 1).Value = Sn(i).Name
Next
Sn.MoveLast
Sn.MoveFirst
rCount = Sn.RecordCount
在记录中循环
i = 0
Do While Not Sn.EOF
Label1.Caption = "Record:" & Str(i + 1) & " of" & _
Str(rCount)
Label1.Refresh
For j = 0 To Sn.Fields.Count - 1
加每个字段的值加到工作表中
If Sn(j).Type < 11 Then
xl.Worksheets(1).cells(i + 2, j + 1).Value = Sn(j)
Else
处理Memo和LongBinary 类型的字段
xl.Worksheets(1).cells(i + 2, j + 1).Value = "Memo or Binary Data"
End If
Next j
Sn.MoveNext
i = i + 1
Loop
保存工作表
Label1.Caption = "保存文件..."
Label1.Refresh
xl.SaveAs "c:/Customers.XLS"
从内存中删除Excel对象
Label1.Caption = "退出Excel"
Label1.Refresh
xl.Application.Quit
Else
没有记录
End If
清除
Label1.Caption = "清除对象"
Label1.Refresh
Set xl = Nothing
Set Sn = Nothing
Set tempDB = Nothing
Screen.MousePointer = 0 恢复鼠标指针
Label1.Caption = "Ready"
Label1.Refresh

End Sub

Private Sub Form_Load()
Label1.AutoSize = True
Label1.Caption = "Ready"
Label1.Refresh
End Sub

````````````````````````````````````````````````````````````````````````````
如何更改Access主窗口左上角的图标(自定义图标)？

Sub cmdAddProp_Click()
　　Dim intX As Integer
　　Const DB_Text As Long = 10
　　intX = AddAppProperty(""AppTitle"", DB_Text, ""我的自定义标题"")　'设置应用程序标题
　　intX = AddAppProperty(""AppIcon"", DB_Text, ""C:/Windows/Cars.ico"")　　 '设置图标
　　CurrentDb.Properties(""UseAppIconForFrmRpt"") = 1
　　Application.RefreshTitleBar
End Sub

Function AddAppProperty(strName As String, _
　　　　varType As Variant, varvalue As Variant) As Integer
　　Dim dbs As Object, prp As Variant
　　Const conPropNotFoundError = 3270

　　Set dbs = CurrentDb
　　On Error GoTo AddProp_Err
　　dbs.Properties(strName) = varvalue
　　AddAppProperty = True

AddProp_Bye:
　　Exit Function

AddProp_Err:
　　If Err = conPropNotFoundError Then
　　　　Set prp = dbs.CreateProperty(strName, varType, varvalue)
　　　　dbs.Properties.Append prp
　　　　Resume
　　Else
　　　　AddAppProperty = False
　　　　Resume AddProp_Bye
　　End If
End Function