Oscar Sun on SnipSave | Web-based code snippet manager for developers

檢查兩兩值有不同者_下二筆不同於前者

                    Sub 檢查兩兩值有不同者_下二筆不同於前者() '只要隔一筆記錄後有不同值即選取
For Each c In ActiveSheet.Columns(1).Cells
    If w = "" Then
        w = c
    Else
        If StrComp(c, w) = 0 Then
            i = i + 1
        End If
        If i = 1 Then
            i = 0
        Else
            c.Select
            Stop
        End If
        w = ""
    End If
Next

End Sub

Word表格篩選,有垂直合併儲存格時（未完善，要整列隱藏才行！）

View Snippet

                    Sub Wordªí®æ¿z¿ï_¦X¨ÖÀx¦s®æ() '558.6016 '
Dim r As Row, i As Long, rng As Range, tb As Table, c As Cell, s, e, cnx As Cell

s = Timer
Application.ScreenUpdating = False
ThisDocument.ActiveWindow.Visible = False
x = "ªü"
Set tb = ThisDocument.Tables(1)
tb.Range.Font.Hidden = False
For Each c In tb.Columns(7).Cells
    i = i + 1
    If i > 1 Then '¤ÓºC:¡@r.Index > 1 Then'
        If InStr(c.Range, x) = 0 Then
'            'r.Range.Select''
'            c.Row.Range.Font.Hidden = True 'ÁôÂÃªº¤å¦rrange=""'
            'c.Range.Font.Hidden = True
            c.Range.Font.Hidden = True
            Set cnx = c.Next
            If cnx Is Nothing = False Then
                Do Until cnx.ColumnIndex = 1
                    cnx.Range.Font.Hidden = True
                    Set cnx = cnx.Next
                    If cnx Is Nothing Then Exit For
                Loop
            End If
            Set cnx = c.Previous
            If cnx Is Nothing = False Then
                Do
                    cnx.Range.Font.Hidden = True
                    Set cnx = cnx.Previous
                    If cnx Is Nothing Then Exit For
                Loop Until cnx.ColumnIndex = 1
                cnx.Range.Font.Hidden = True
            End If
'            tb.Rows(c.RowIndex).Range.Font.Hidden = True
        End If
'        r.Range.Font.Hidden = False'
    End If
Next
Application.ScreenUpdating = True
ThisDocument.ActiveWindow.Visible = True

e = Timer
Debug.Print e - s
MsgBox "done" & vbCr & e - s, vbInformation
End Sub

Word表格篩選

View Snippet

                    Sub Word表格篩選_較慢() '811.8203 '
Dim r As Row, i As Long, rng As Range, tb As Table, s, e

s = Timer
Application.ScreenUpdating = False
ThisDocument.ActiveWindow.Visible = False
x = "口"
Set tb = ThisDocument.Tables(1)
tb.Range.Font.Hidden = False
For Each r In tb.Rows
    i = i + 1
    If i > 1 Then '太慢:　r.Index > 1 Then'
        If InStr(r.Cells(2).Range, x) = 0 Then
'            'r.Range.Select''
            r.Range.Font.Hidden = True
        End If
'        r.Range.Font.Hidden = False'
    End If
Next
Application.ScreenUpdating = True
ThisDocument.ActiveWindow.Visible = True

e = Timer
Debug.Print e - s
MsgBox "done" & vbCr & e - s, vbInformation
End Sub

Sub Word表格篩選() '558.6016 '
Dim r As Row, i As Long, rng As Range, tb As Table, c As Cell, s, e

s = Timer
Application.ScreenUpdating = False
ThisDocument.ActiveWindow.Visible = False
x = "口"
Set tb = ThisDocument.Tables(1)
tb.Range.Font.Hidden = False
For Each c In tb.Columns(2).Cells
    i = i + 1
    If i > 1 Then '太慢:　r.Index > 1 Then'
        If InStr(c.Range, x) = 0 Then
'            'r.Range.Select''
            c.Row.Range.Font.Hidden = True '隱藏的文字range=""'
        End If
'        r.Range.Font.Hidden = False'
    End If
Next
Application.ScreenUpdating = True
ThisDocument.ActiveWindow.Visible = True

e = Timer
Debug.Print e - s
MsgBox "done" & vbCr & e - s, vbInformation
End Sub

分析漢字聲符

View Snippet

                    Sub 分析漢字聲符() '漢字聲符列表()20161110'
Dim d As Document, a As Object, x As String, v(3) As String, i As Integer, rng As Range, myrng As Range, a_myrng As Object, c As Cell, rngd As New Document, od As New Document
Dim cnt As New ADODB.Connection, rst As New ADODB.Recordset, objparam As New ADODB.Parameter, cmd As New ADODB.Command
Dim cp As String
Application.ScreenUpdating = False

'cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\!!!@漢字教學集中@!!!\!!@@數位工具@@!!\9諧聲系統\@@諧聲字檢索系統（唯一）20160512.mdb;Mode=Share Deny None;Extended Properties="";Jet OLEDB:System database=C:\Users\123\AppData\Roaming\Microsoft\Access\System.mdw;Jet OLEDB:Registry Path=Software\Microsoft\Office\14.0\Access\Access Connectivity Engine;Jet OLEDB:Database Password="";Jet OLEDB:Engine Type=5;Jet OLEDB:Database Locking Mode=1;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=True;Jet OLEDB:Bypass UserInfo Validation=False"'
cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\!!!@漢字教學集中@!!!\!!@@數位工具@@!!\9諧聲系統\@@諧聲字檢索系統（唯一）20160512.mdb"
Set cmd.ActiveConnection = cnt
cmd.CommandText = "漢字聲符查詢"
cmd.CommandType = adCmdStoredProc
rst.CursorType = adOpenStatic
rst.LockType = adLockReadOnly
Set d = ActiveDocument
cp = d.ActiveWindow.Caption

rngd.ActiveWindow.Visible = False
od.ActiveWindow.Visible = False
od.Range.Text = d.Range.Text
Set rng = od.Range
For Each a In rng.Characters
    If StrComp(a, Chr(13)) <> 0 Then
        Set objparam = cmd.CreateParameter("q", adBSTR, adParamInput, 2, a)
        cmd.Parameters.Append objparam
        rst.Open cmd
        If rst.RecordCount > 0 Then
            For i = 0 To 3 '取得各屬性值：0.形聲字拼音、1.形聲字形符、2.形聲字聲符、3.形聲字聲符拼音
                x = Nz(rst.Fields(i).Value, "")
                If i = 1 Then '從【形聲字解釋】取形符
                    Set myrng = rngd.Range
                    myrng.Text = x
                    For Each a_myrng In myrng.Characters
                        If StrComp(a_myrng, ChrW(20174)) = 0 Or StrComp(a_myrng, "從") = 0 Then
                            If Not a_myrng.Next.Next.Next.Next Is Nothing Then
                                If StrComp(a_myrng.Next.Next.Next.Next, "聲") = 0 Then '有逗號
                                    v(i) = a_myrng.Next
                                    Exit For
                                ElseIf StrComp(a_myrng.Next.Next.Next, "聲") = 0 Then '沒逗號
                                    v(i) = a_myrng.Next
'                                Else
''                                    MsgBox "check!", vbExclamation
''                                    Stop
'                                    v(i) = ""
                                    Exit For
                                End If
                            Else
                                v(i) = ""
                                Exit For
                            End If
                        End If
                    Next a_myrng
                    If a_myrng Is Nothing Then
                        v(i) = ""
                    End If
                Else
                    v(i) = x
                End If
            Next i
            GoSub tbl
        Else
            x = ""
'            v = Empty
            GoSub tbl
        End If
        cmd.Parameters.Delete (0)
        rst.Close

    End If
    d.ActiveWindow.Caption = a.End & "/" & rng.Characters.Count
Next a
rngd.Close wdDoNotSaveChanges
od.Close wdDoNotSaveChanges
Set rngd = Nothing
Set od = Nothing
Dim clm
clm = Array(29.75, 99.75, 27.85, 29.75, 99.75)
For i = 1 To 5
    d.Tables(1).Columns(i).Width = clm(i - 1)
Next i
d.ActiveWindow.Caption = cp
Application.ScreenUpdating = True
Exit Sub

tbl:
If d.Tables.Count = 0 Then
    'd.Tables.Add d.Paragraphs(1).Range, 1, 5
    d.Tables.Add d.Range, 1, 5
Else
    d.Tables(1).Rows.Add
End If
d.Tables(1).Rows(d.Tables(1).Rows.Count).Cells(1).Range.Text = a
If rst.RecordCount > 0 Then
    i = 0
    For Each c In d.Tables(1).Rows(d.Tables(1).Rows.Count).Cells
        If c.ColumnIndex > 1 Then
            c.Range.Text = v(i)
            i = i + 1
        End If
    Next c
End If

Return
End Sub

VBA BEEP 音效

View Snippet

                    'http://www.cc.chu.edu.tw/~u8802154/Multimedia/Page2.htm
如何播放聲音檔或視訊檔

以下是透過 mciSendString 函數執行 MCI 指令進而播放聲音檔的方法：

mciSendString  "close c:\windows\media\Ding.wav", vbNullString, 0, 0

mciSendString  "open c:\windows\media\Ding.wav", vbNullString, 0, 0

mciSendString  "play c:\windows\media\Ding.wav", vbNullString, 0, 0

綠色部分注意要小寫

　

在使用 MCI 指令之前，切記須先將 MCI 關閉，下次再執行播放時才能

正確播放，或者是將播放的位置改變到最前面，描述如下：

mciSendString  "seek c:\windows\media\Ding.wav to start", vbNullString, 0, 0

mciSendString  "play c:\windows\media\Ding.wav", vbNullString, 0, 0　

　

另外，seek 的其他用法如下：

seek 媒體名稱 to start   將位置移到最前面

seek 媒體名稱 to end   將位置移到最後面

seek 媒體名稱 to position   將位置移到 position 

　

　

除了聲音檔之外，如何播放視訊檔呢?

其實以上所介紹的 MCI 指令，除了可以用來播放聲音檔之外，也可以用

來播放 MIDI  檔及 AVI 檔，不必經過任何修改，Windows  會自動產生一

個視窗播放此視訊檔，但是可不可以在指定的位置上播放呢?答案是可以

的，方法如下：

open AVI 檔名 parent hWnd style child

其中，hWnd 需填入某個物件的 hWnd 

執行上述命令之後，影片會被放置在物件的左上角，且影片的大小不受

物件大小的影響，如果想要改變影片播放的位置及大小時，可以在執行

 play  指令前先執行 put 指令，格式如下：

put AVI 檔名 window at X Y [Width Height]

 其中 X  及 Y 參數須填入位置，而 Width 及 Height參數則填入影片顯示出來的寬度及高度

其他常用的 MCI 指令：

        pause 設備名稱   暫停播放

        stop 設備名稱   停止播放

        step 設備名稱   前進到下一個位置

        step 設備名稱 reverse   後退到上一個位置

        step 設備名稱 by N   前進或後退 N 個位置

      (其中 N<0 即表示後退)

        status 設備名稱 position   讀取目前的播放位置

        status 設備名稱 length   讀取媒體的總長度

　

小秘訣：

其實我們可以在 open 指令加上：

  「API 類型」alias 自訂的媒體設備名稱」

open c:\windows\media\Ding.wav alias MyWav

以上敘述的用途是為 c:\windows\media\Ding.wav 聲音檔取一個比較容易

記憶與書寫的名稱，接著在其他 MCI 的指令當中，便可以將繁雜的

c:\windows\media\Ding.wav 置換成 MyWav，例如：

mciSendString  "close MyWav", vbNullString, 0, 0

mciSendString  "open MyWav", vbNullString, 0, 0

mciSendString  "play MyWav", vbNullString, 0, 0　


'=============================


'http://www.cc.chu.edu.tw/~u8802154/Multimedia/Page2.htm
Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

在程式區家上呼叫音樂檔
       file1 = "D:\pocketPC\Audio-1.wav" '填要播放的音樂檔
     mciSendString "seek " & file1 & " to start", vbNullString, 0, 0
        mciSendString "open " & file1, vbNullString, 0, 0
        mciSendString "play " & file1, vbNullString, 0, 0

'http://forum.twbts.com/viewthread.php?tid=3563
'http://edisonx.pixnet.net/blog/post/60684029-%5B%E9%9F%B3%E6%95%88%5D-%E4%BD%BF%E7%94%A8%E6%8F%9A%E8%81%B2%E5%99%A8-(beep)
'http://www.blueshop.com.tw/board/FUM20050124191756KKC/BRD20071223011829C2R.html
'https://tw.answers.yahoo.com/question/index?qid=20110826000010KK06174
'https://tw.answers.yahoo.com/question/index?qid=20080427000010KK06462
'https://tw.answers.yahoo.com/question/index?qid=20131211000015KK00610
'https://www.google.com.tw/webhp?sourceid=chrome-instant&rlz=1C1JRYI_enTW714TW714&ion=1&espv=2&ie=UTF-8#q=vba%20beep%20%E9%9F%B3%E6%95%88

'http://raz-soft.com/cpp/mcisendstring-playing-with-sounds/
'https://sites.google.com/site/syanjiushi/cheng-shi-yu-yan-pai-ming/mci-xiang-xi-zi-liao-vb-ban

← Prev Page Next Page →