Oscar Sun

                    
Function 作者值搜尋() '檢查強迫參照完整性2015/12/16
Dim t As TableDef, fds As Field, rst As Recordset, flg As Boolean
x = Screen.ActiveControl.SelText
If x = "" Then x = Screen.ActiveControl.Value
For Each t In CurrentDb.TableDefs
    For Each fds In t.Fields
        If InStr(fds.Name, "作者") Then
            Set rst = t.OpenRecordset
                With rst
                    Do Until .EOF
                        If VBA.StrComp(.Fields(fds.Name).Value, x) = 0 Then
                            With DoCmd
                                .OpenTable t.Name
                                .GoToControl fds.Name
                                .FindRecord x, acEntire
                                '.GoToRecord rst.Bookmark
                                'Exit Function
                                flg = True
                            End With
                        End If
                        .MoveNext
                    Loop
                End With
        End If
    Next fds
Next t
If Not flg Then MsgBox "沒找到,可以刪了!", vbExclamation
End Function
                  

                    Function 資料表物件尋找() '2015/12/15
				Dim strObjectName As String, t
				strObjectName = InputBox("請輸入物件名")
				For Each t In CurrentData.AllTables
				    If InStr(t.Name, strObjectName) Then
				        DoCmd.SelectObject acTable, t.Name, True: Exit Function
				    End If
				Next
				MsgBox "沒找到", vbExclamation
End Function

                  

                    Function GetDefaultBrowserEXE() '2010/10/18由http://chijanzen.net/wp/?p=156#comment-1303(取得預設瀏覽器(default web browser)的名稱? chijanzen 雜貨舖)而來.
        Dim objShell
        objShell = CreateObject("WScript.Shell")
        'HKEY_CLASSES_ROOT\HTTP\shell\open\ddeexec\Application
        '取得註冊表中的值
        GetDefaultBrowserEXE = objShell.RegRead _
                ("HKCR\http\shell\open\command")

'https://msdn.microsoft.com/zh-tw/library/xz88758e.aspx
End Function

Function GetDefaultBrowser() '2010/10/18¥Ñhttp://chijanzen.net/wp/?p=156#comment-1303(¨ú±o¹w³]ÂsÄý¾¹(default web browser)ªº¦WºÙ? chijanzen Âø³fçE)¦Ó¨Ó.
Dim objShell
    Set objShell = CreateObject("WScript.Shell")
    'HKEY_CLASSES_ROOT\HTTP\shell\open\ddeexec\Application
    '¨ú±oµù¥Uªí¤¤ªº­È
    'GetDefaultBrowser = objShell.RegRead _
        ("HKCR\http\shell\open\ddeexec\Application")
    GetDefaultBrowser = objShell.RegRead _
         ("HKEY_CLASSES_ROOT\http\shell\open\ddeexec\Application")
End Function
                  

                    Sub 更新連結資料表根目錄() '2015/12/7
On Error GoTo eH
Dim tb As DAO.TableDef, dbPath As String, Drv As String, tbcnt As String
dbPath = CurrentProject.Path
Drv = VBA.Left(dbPath, 2)
For Each tb In CurrentDb.TableDefs
    If tb.Name <> "書照_藏" Then
        tbcnt = tb.Connect
        If VBA.InStr(tbcnt, ":\千慮一得齋") Then
            If VBA.InStr(tbcnt, Drv) = 0 Then
                tb.Connect = VBA.Replace(tbcnt, VBA.Mid(tbcnt, InStr(tbcnt, "=") + 1, 2), Drv, , 1)
                tb.RefreshLink
            End If
        End If
    End If
Next
Exit Sub
eH:
Select Case Err.Number
    Case 3170 '找不到可安裝的 ISAM。
        Debug.Print tb.Name & vbCr & tbcnt
        MsgBox "未安裝/複製資料庫" & vbCr & "資料表: " & tb.Name & vbCr & tbcnt
    Case Else
        Debug.Print Err.Number & Err.Description & vbCr & "資料表: " & tb.Name
        MsgBox Err.Number & Err.Description, vbCritical
End Select
End Sub
                  

                    Function 取得桌面路徑() 'GetDeskDir() '取得桌面 http://it-easy.tw/vb-get-path/
    Dim wshshell As Object '宣告wshshell為一個Object
'    Dim strDesktop As String 'strDesktop變數儲存wshshell.regread的傳回值
    Set wshshell = CreateObject("wscript.shell") '將"wscript.shell"載入到wshshell內
'    strDesktop = wshshell.regread("HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurrentVersionExplorerShell FoldersDesktop") '取得桌面路徑
'    Print "桌面路徑為："; strDesktop
    取得桌面路徑 = wshshell.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop") '取得桌面路徑
' -------   
'http://club.excelhome.net/thread-260793-1-1.html
'aa = CreateObject("WScript.Shell").SpecialFolders("Desktop")
'MsgBox aa
'-------
'VBA.Environ("USERPROFILE") & "\桌面"
End Function