先在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