搜檢資料庫物件

View Snippet 
                    Sub 搜檢資料庫物件()
Dim x As String, v As String, t, Obj
1
x = InputBox("請輸入「關鍵字,種類代號」： 資料表=t;查詢=q;表單=f")
If x = "" Then Exit Sub
If InStr(x, ",") = 0 Then MsgBox "請輸入類名代號： 資料表=t;查詢=q;表單=f": GoTo 1
v = Right(x, 1)
x = Mid(x, 1, Len(x) - 2)
Select Case v
    Case "t"
        t = acTable
        For Each Obj In CurrentData.AllTables
            If Obj.Name Like "*" & x & "*" Then GoSub slt
            'x = Obj.Name
        Next
    Case "q"
        t = acQuery
        For Each Obj In CurrentData.AllQueries
            If Obj.Name Like "*" & x & "*" Then GoSub slt
        Next
    Case "f"
        t = acForm
        For Each Obj In CurrentProject.AllForms
            If Obj.Name Like "*" & x & "*" Then GoSub slt
        Next
End Select
Exit Sub

slt:
    If MsgBox("「" & Obj.Name & "」？", vbQuestion + vbOKCancel) = vbOK Then
        DoCmd.SelectObject t, Obj.Name, True
        Exit Sub
    End If
Return
End Sub

判斷磁碟機是否存在 DriveExists Method

View Snippet 
                    Function ReportDriveStatus(drv)
   Dim fso, msg
   Set fso = CreateObject("Scripting.FileSystemObject")
   If fso.DriveExists(drv) Then
      msg = ("Drive " & UCase(drv) & " exists.")
   Else
      msg = ("Drive " & UCase(drv) & " doesn't exist.")
   End If
   ReportDriveStatus = msg
End Function

'https://msdn.microsoft.com/en-us/library/t565x0f1(v=vs.84).aspx
'	https://social.msdn.microsoft.com/Forums/vstudio/en-US/dc854317-1a72-4f35-9112-91567b5a08e0/how-to-check-if-a-drive-exists-using-vb2010?forum=vbgeneral

用ADO打開Excel工作表 ado connection open excel

View Snippet 
                    On Error Resume Next

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001

Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")

objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=C:\Scripts\Test.xls;" & _
        "Extended Properties=""Excel 8.0;HDR=Yes;"";" 

objRecordset.Open "Select * FROM [Sheet1$]", _
    objConnection, adOpenStatic, adLockOptimistic, adCmdText

Do Until objRecordset.EOF
    Wscript.Echo objRecordset.Fields.Item("Name"), _
        objRecordset.Fields.Item("Number")
    objRecordset.MoveNext
Loop

'https://technet.microsoft.com/zh-tw/library/ee692882.aspx
'http://frankiestudy.blogspot.tw/2011/11/microsoftjetoledb40.html
'來源是Microsoft.Jet.OLEDB.4.0或Microsoft.ACE.OLEDB.12.0

ADO打開EXCEL 聲符補形聲字插入

View Snippet 
                    Sub 聲符補形聲字插入()
Static objConnection As ADODB.Connection, objRecordset As ADODB.Recordset ' e As Excel.Workbook
Const f = "E:\黃老師工作_守真\聲符\!!!部件聲符最全20110220（黃訂唯一515部件）.xls"
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset
Dim x As String, i As Long, w As String, st As String

'Const adOpenStatic = 3
'Const adLockOptimistic = 3
'Const adCmdText = &H0001
'https://technet.microsoft.com/zh-tw/library/ee692882.aspx

'If e Is Nothing Then Set e = GetObject(f)
x = Selection.Paragraphs(1).Range.Characters(1)
Selection.MoveUntil Chr(13)
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.TypeText "部件聲符最全"
Selection.Paragraphs(1).Style = "標題 2"
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.Paragraphs(1).Style = "內文"
i = i + 1

If objConnection Is Nothing Then
    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")
    
    'objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & f & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"";"
    objConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & f & ";" & _
            "Extended Properties=""Excel 8.0;HDR=Yes;"";"
    
    objRecordset.Open "Select * FROM [Sheet1$]", _
        objConnection, adOpenStatic, adLockOptimistic, adCmdText
End If
Do Until objRecordset.EOF
'    Wscript.Echo objRecordset.Fields.Item("Name"), _
'        objRecordset.Fields.Item("Number")
    w = objRecordset.Fields.Item(3)
    If StrComp(w, x) = 0 Then
        Selection.TypeText objRecordset.Fields.Item(0)
    End If
    objRecordset.MoveNext
Loop
objRecordset.MoveFirst


'Do Until e.Sheets(1).Cells(i, 1) = ""
'    w = e.Sheets(1).Cells(i, 4)
'    If StrComp(w, x) = 0 Then
'        Selection.TypeText e.Sheets(1).Cells(i, 1)
'    End If
'    i = i + 1
'Loop
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.TypeText "諧聲字檢索系統"
Selection.Paragraphs(1).Style = "標題 2"
Selection.InsertParagraphAfter
Selection.MoveDown
Selection.Paragraphs(1).Style = "內文"

'If cnt Is Nothing Then

    cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=E:\黃老師工作_守真\聲符\@@諧聲字檢索系統（唯一）20160512.mdb" ', , , adAsyncConnect
'End If
st = "SELECT 形聲字.序號, 形聲字.形聲字, 聲符.聲符 FROM 聲符 INNER JOIN 形聲字 ON 聲符.聲符ID = 形聲字.聲符ID WHERE (((StrComp(聲符.聲符,""" & x & """))=0)) ORDER BY 形聲字.序號 ;"
rst.Open st, cnt

If Not rst.EOF Then
    rst.MoveFirst
    rst.Move 1
    Do Until rst.EOF
        Word.ActiveDocument.ActiveWindow.Selection.TypeText rst.Fields("形聲字").Value
    rst.Move 1
    Loop
    Selection.MoveUp wdParagraph, 3, wdExtend
    比較漢文博士和國學大師部件檢字的異同
End If
'MsgBox "done!", vbInformation
End Sub

書名號篇名號檢查 校對用 配合資料庫

View Snippet 
                    Option Explicit
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset


Sub 書名號篇名號檢查() '2017/3/2
Dim s As Long, rng As Range, e, trm As String, ans
Static x() As String, i As Integer
Const strFD As String = "篇名號檢查" '校對用資料表
Const strPath As String = "E:\黃老師工作_守真\tools" '校對用資料庫所在路徑
On Error GoTo eH
Do
    If Selection.Find.Execute("〈", , , , , , True, wdFindStop) = False Then MsgBox "done!", vbInformation: GoTo 3
    Set rng = Selection.Range
    rng.MoveEndUntil "〉"
    trm = Mid(rng, 2)
    
    For Each e In x()
        If StrComp(e, trm) = 0 Then GoTo 1
    Next e
2   ans = MsgBox("是否略過「" & trm & "」？" & vbCr & vbCr & vbCr & "結束請按 NO[否]", vbExclamation + vbYesNoCancel)
    Select Case ans
        Case vbYes
            ReDim Preserve x(i) As String
            x(i) = trm
            i = i + 1
        Case vbNo
3
            For Each e In x()
                If rst.State = adStateOpen Then rst.Close
                rst.Open "select * from " & strFD & " where strcomp(可略去關鍵字,""" & e & """)=0 ", cnt, adOpenKeyset, adLockOptimistic
                If rst.RecordCount = 0 Then
                    rst.AddNew
                    rst.Fields(1).Value = e
                    rst.Update
                End If
            Next e
            Exit Sub
    End Select
1
Loop
Exit Sub
eH:
Select Case Err.Number
    Case 92 '沒有設定 For 迴圈的初始值 陣列尚未有值
        cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & strPath & "校對用資料庫.accdb"
        rst.Open "SELECT Len([可略去關鍵字]) AS Expr1, * FROM " & strFD & " ORDER BY Len([可略去關鍵字]) DESC", cnt, adOpenKeyset, adLockOptimistic
        With rst
            Do Until .EOF
                ReDim Preserve x(CLng(rst.AbsolutePosition) - 1) As String
                x(CLng(rst.AbsolutePosition) - 1) = rst.Fields(2).Value
                .MoveNext
                i = i + 1
            Loop
        End With
        GoTo 2
End Select
End Sub
← Prev Page Next Page →