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

NUMLOCK 設定物件類別模組的應用

                    'Type declaration'https://books.google.com.tw/books?id=dtSdrjjVXrwC&lpg=PA896&ots=yVl9armuTo&dq=vba%20numlock%20toggle&hl=zh-TW&pg=PA896#v=onepage&q&f=false
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
'API declarations
Private Declare PtrSafe Function GetVersionEx Lib "Kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare PtrSafe Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwflags As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function GetKeyboardState Lib "user32" _
(pbKeyState As Byte) As Long
Private Declare PtrSafe Function SetKeyboardState Lib "user32" _
(lppbKeyState As Byte) As Long
'Constant declarations
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2

Property Get Value() As Boolean
'Get the current state
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
Value = keys(VK_NUMLOCK)
End Property

Property Let Value(boolVal As Boolean)
Dim o As OSVERSIONINFO
Dim keys(0 To 255) As Byte
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
GetKeyboardState keys(0)
'Is it already in that state?

If boolVal = True And keys(VK_NUMLOCK) = 1 Then Exit Property
If boolVal = False And keys(VK_NUMLOCK) = 0 Then Exit Property

'Toggle it
'Simulate Key Press
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or _
KEYEVENTF_KEYUP, 0
End Property

Sub Toggle()
'Toggles the state
Dim o As OSVERSIONINFO
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
'Simulate Key Press
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or _
KEYEVENTF_KEYUP, 0
End Sub




'=============
'https://books.google.com.tw/books?id=dtSdrjjVXrwC&lpg=PA896&ots=yVl9armuTo&dq=vba%20numlock%20toggle&hl=zh-TW&pg=PA896#v=onepage&q&f=false
Sub NumLockOn()
Dim NumLock As New NumLockClass
NumLock.Value = True
End Sub

Sub GetNumLockState()
Dim NumLock As New NumLockClass
MsgBox NumLock.Value
End Sub

Sub ToggleNumLock()
Dim NumLock As New NumLockClass
NumLock.Toggle
End Sub

Sub ToggleNumLock2()
Dim NumLock As New NumLockClass
NumLock.Value = Not NumLock.Value
End Sub

檔案重新命名（ \'原檔名有缺號，不連號者,且限定原檔名補0位數）

View Snippet

                    Option Explicit
Sub 檔案重新命名w() '原檔名有缺號，不連號者
On Error GoTo EHH
Dim fs, fc, fl, f, ef, i As Long, j As Long, frMat As String, 原檔起始號 As Long  ', OldName As String, NewName As String
'p = ""InputBox("請輸入路徑", , p)
Const p = "w:\!!scan\reName" '"請輸入路徑"
'Const p = "D:\千慮一得齋\資料庫\掃描資料庫\reName" '"請輸入路徑"
'If Dir(p) = "" Then MsgBox "請檢查路徑": Exit Sub
Const o = "" '被取代字串
Const n = "@@@" '取代字串

Const 卷 = ""
Const 新檔起始號 = 1

'Const 原檔起始號 = 1 '均先批次重新命名為１開始
Const 副檔名 = ".jpg"
If p = "" Then Exit Sub


Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(p)
Set fc = f.Files
'原檔起始號 = CLng(Mid(fc.Item(1), 2))
For Each fl In fc
    原檔起始號 = CLng(Mid(Replace(fl.Name, 副檔名, ""), 2))
    
    frMat = VBA.Replace(Replace(fl.Name, 副檔名, ""), 原檔起始號, "")
    frMat = frMat & VBA.String(Len(CStr(原檔起始號)), "0")
    Exit For
Next
For i = 0 To fc.Count - 1
    j = i
    If (i + 1) Mod 2 = 0 Then
'        fc(Format(i + 原檔起始號, "a00000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "b" & 副檔名)
        fc(Format(i + 原檔起始號, frMat & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "b" & 副檔名)
    Else
'        fc(Format(i + 原檔起始號, "a00000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "a" & 副檔名)
        fc(Format(i + 原檔起始號, frMat & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "a" & 副檔名)
    End If
    i = j
Next i
'For Each fl In fc
'    fl.Name = Replace(fl.Name, o, n)
'
'Next fl
AppActivate "acdsee 5.0 - rename"
SendKeys "{f5}"
Exit Sub
EHH:
Select Case Err.Number
    Case 53 '找不到檔案
        Do
            i = i + 1
            For Each ef In fc
                If Format(i + 原檔起始號, "a00000" & 副檔名) = ef.Name Then Exit Do
            Next
        Loop
        Resume
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub

NUMLOCK Status 數字鍵鍵盤狀態

View Snippet

                    Public Const VK_NUMLOCK = &H90

Public Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Long


Function NUMLOCKstatus() As Boolean 'https://www.mrexcel.com/forum/excel-questions/677200-visual-basic-applications-remember-numlock-state.html
'MsgBox "Numlock is " & IIf(GetKeyState(VK_NUMLOCK) = 1, "On", "Off")
If GetKeyState(VK_NUMLOCK) = 1 Then
    NUMLOCKstatus = True
End If
End Function

VBA 音效

View Snippet

                    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

Sub 播放讀音(file1 As String) ''http://forum.twbts.com/viewthread.php?tid=3563
'在程式區家上呼叫音樂檔
'       file1 = "D:\pocketPC\Audio-1.wav" '填要播放的音樂檔
'       file1 = "C:\Users\ssz3\Documents\ai3.wav" '填要播放的音樂檔
        'mciSendString "seek " & file1 & " to start", vbNullString, 0, 0'用此式會當掉
        mciSendString "close " & file1, vbNullString, 0, 0 'http://www.cc.chu.edu.tw/~u8802154/Multimedia/Page2.htm
        mciSendString "open " & file1, vbNullString, 0, 0 '在使用 MCI 指令之前，切記須先將 MCI 關閉，下次再執行播放時才能 _
                                            正確播放 , 或者是將播放的位置改變到最前面……:
        mciSendString "play " & file1, vbNullString, 0, 0


'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

End Sub

VB取得系統路徑的方法

View Snippet

                    日期：2009 年 07 月 27 日 ｜作者：幻嵐
程式設計者在設計程式時，常常會需要用到一些常用的系統路徑。例如：「桌面」路徑、「我的文件」路徑、「Program Files」路徑、「WINDOWS」路徑。而要如何才能取得這些路徑的位址呢？這正是本篇教學所要講的。


為了方便訪客尋找資料，我就來弄個教學書籤好了^^

快速書籤：
1.取得VB程式的自身路徑

2.取得Windows的路徑

3.取得WindowsSystem的路徑

4.取得桌面路徑

5.取得Program Files路徑

6.取得我的文件路徑

7.取得Windows所在的磁碟機代號

取得VB程式的自身路徑
這是一個很簡單的動作，App(應用程式本身)裡面原本就有這個屬性方法了。程式碼如下：

1
2
3
Sub GetMeDir() '取得自身路徑
    Print "本程式的路徑為："; App.Path
End Sub
補充資料：
App.Path：取得程式自身路徑

App.EXEName：取得程式檔名

App.EXEName：取得程式檔名

App.PrevInstance：取得程式是否已開啟(傳回布林值，True為開啟，False反之)

App.Major：傳回程式版本x.x.x

App.Minor：傳回程式版本x.x.x

App.Revision：傳回程式版本x.x.x

取得程式版本寫法：

1
2
3
Sub GetRevision() '取得自身版本
    Print "本程式的版本為："; App.Major & "." & App.Minor & "." & App.Revision '版本格式：x.x.x
End Sub
取得Windows的路徑
利用「GetWindowsDirectory」API函數可以輕易做出這個功能，其宣告方法如下：

Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
參數說明：
lpBuffer：傳入足夠長度的字串，然後再傳回Windows的所在目錄。建議配置的字串長度是(MAX_PATH=)260。

nSize：傳入的字串長度。

GetWindowsDirectory傳回值若等於0則表示取得Windows路徑失敗，若不等於零則表示路徑取得成功。此外，GetWindowsDirectory的傳回值就是路徑的長度。

程式碼如下：
1
2
3
4
5
6
7
8
9
10
11
12
13
Sub GetWDir() '取得WINDOWS路徑
    Dim Buffer As String '作為lpBuffer
    Dim rtn As Long '儲存GetWindowsDirectory的return值
    Const MAX_PATH = 260 '設定最大字串長度

    Buffer = Space(MAX_PATH) '讓Buffer儲存MAX_PATH(260)個空白字元
    rtn = GetWindowsDirectory(Buffer, Len(Buffer)) 'GetWindowsDirectory(lpBuffer,nSize)
    If rtn = 0 Then '判斷GetWindowsDirectory是否有取得路徑
        Print "WINDOWS路徑取得失敗！" '取得失敗提示
    Else '如果rtn不為0
        Print "WINDOWS路徑為："; Buffer 'Buffer經過GetWindowsDirectory函數處理後，儲存的字串已為WINDOWS路徑
    End If
End Sub
取得WindowsSystem的路徑
利用「GetSystemDirectory」API函數可以輕易做出這個功能，其宣告方法如下：

Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
參數說明：
lpBuffer：傳入足夠長度的字串，然後再傳回Windows的所在目錄。建議配置的字串長度是(MAX_PATH=)260。

nSize：傳入的字串長度。

GetSystemDirectory傳回值若等於0則表示取得System路徑失敗，若不等於零則表示路徑取得成功。此外，GetSystemDirectory的傳回值就是路徑的長度。

程式碼如下：
1
2
3
4
5
6
7
8
9
10
11
12
13
Sub GetSDir() '取得SYSTEM路徑
    Dim Buffer As String '作為lpBuffer
    Dim rtn As Long '儲存GetSystemDirectory的return值
    Const MAX_PATH = 260 '設定最大字串長度

    Buffer = Space(MAX_PATH) '讓Buffer儲存MAX_PATH(260)個空白字元
    rtn = GetSystemDirectory(Buffer, Len(Buffer)) 'GetSystemDirectory(lpBuffer,nSize)
    If rtn = 0 Then '判斷GetSystemDirectory是否有取得路徑
        Print "SYSTEM路徑取得失敗！" '取得失敗提示
    Else '如果rtn不為0
        Print "SYSTEM路徑為："; Buffer 'Buffer經過GetSystemDirectory函數處理後，儲存的字串已為SYSTEM路徑
    End If
End Sub
取得桌面路徑
要做到這個功能，可能以讀取登錄檔的方法比較簡單。我們要建立一個「wscript.shell」Object，利用「.regread」來讀取登錄擋。桌面路徑應該位於登錄擋「HKEY_CURRENT_USERSoftwareMicrosoftWindows

CurrentVersionExplorerShell Folders」的Desktop字串值裡。

sshot-1

程式碼如下：

1
2
3
4
5
6
7
Sub GetDeskDir() '取得桌面
    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
End Sub
補充：
Startup字串值存放的是「啟動」路徑，若要讓某檔案開機時自動執行，就可以使用這個路徑。

取得我的文件路徑
要做到這個功能，可能以讀取登錄檔的方法比較簡單。我們要建立一個「wscript.shell」Object，利用「.regread」來讀取登錄擋。桌面路徑應該位於登錄擋「HKEY_CURRENT_USERSoftwareMicrosoftWindows

CurrentVersionExplorerShell Folders」的Personal字串值裡。

程式碼如下：

1
2
3
4
5
6
7
Sub GetPersonalDir() '取得我的文件路徑
    Dim wshshell As Object '宣告wshshell為一個Object
    Dim strPersonal As String 'strPersonal變數儲存wshshell.regread的傳回值
    Set wshshell = CreateObject("wscript.shell") '將"wscript.shell"載入到wshshell內
    strPersonal = wshshell.regread("HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurrentVersionExplorerShell FoldersPersonal") '取得我的文件路徑
    Print "我的文件路徑為："; strPersonal
End Sub
取得Program Files路徑
要做到這個功能，可能以讀取登錄檔的方法比較簡單。我們要建立一個「wscript.shell」Object，利用「.regread」來讀取登錄擋。桌面路徑應該位於登錄擋「HKEY_LOCAL_MACHINESoftwareMicrosoftWindows

CurrentVersion」的ProgramFilesDir字串值裡。

程式碼如下：

1
2
3
4
5
6
7
Sub GetProDir() '取得Program Files路徑
    Dim wshshell As Object '宣告wshshell為一個Object
    Dim strPro As String 'strPro變數儲存wshshell.regread的傳回值
    Set wshshell = CreateObject("wscript.shell") '將"wscript.shell"載入到wshshell內
    strPro = wshshell.regread("HKEY_LOCAL_MACHINESoftwareMicrosoftWindowsCurrentVersionProgramFilesDir") '取得Program Files路徑
    Print "Program Files路徑為："; strPro
End Sub
取得Windows所在的磁碟機代號
有兩種方法可以做到此功能：第一種是用「GetWindowsDirectory」API函數先取得WINDOWS路徑，接著再把路徑中的磁碟機代號取出。第二種是直接取得登錄檔的字串值。兩種方法均寫成程式碼，程式如下：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub GetSysDrive1() '取得Windows所在的磁碟機代號方法一
    Dim Buffer As String '作為lpBuffer
    Dim rtn As Long '儲存GetWindowsDirectory的return值
    Const MAX_PATH = 260 '設定最大字串長度

    Buffer = Space(MAX_PATH) '讓Buffer儲存MAX_PATH(260)個空白字元
    rtn = GetWindowsDirectory(Buffer, Len(Buffer)) 'GetWindowsDirectory(lpBuffer,nSize)
    If rtn = 0 Then '判斷GetWindowsDirectory是否有取得路徑
        Print "磁碟機代號取得失敗！" '取得失敗提示
    Else '如果rtn不為0
        Print "Windows所在的磁碟機代號為："; Left(Buffer, 2) 'Buffer經過GetWindowsDirectory函數處理後，儲存的字串已為WINDOWS路徑。路徑最左邊的兩個字元就是磁碟機代號
    End If
End Sub
Sub GetSysDrive2() '取得Windows所在的磁碟機代號方法二
    Dim wshshell As Object '宣告wshshell為一個Object
    Dim strSDr As String 'strSDr變數儲存wshshell.regread的傳回值
    Set wshshell = CreateObject("wscript.shell") '將"wscript.shell"載入到wshshell內
    strSDr = wshshell.regread("HKEY_LOCAL_MACHINESoftwareMicrosoftWindowsCurrentVersionSetupBootDir") '取得磁碟機代號
    Print "Windows所在的磁碟機代號為："; strSDr
End Sub
 

教學到此結束，剩下的部分就由各位程式設計者去發揮了！

文章分類：VB6.0｜標籤：App.Path, VB6.0, 取得我的文件路徑, 取得桌面路徑, 取得系統路徑

http://it-easy.tw/vb-get-path/

← Prev Page Next Page →

Oscar Sun

NUMLOCK 設定 物件類別模組的應用

檔案重新命名（ \'原檔名有缺號，不連號者,且限定原檔名補0位數）

NUMLOCK Status 數字鍵鍵盤狀態

VBA 音效

VB取得系統路徑的方法

NUMLOCK 設定物件類別模組的應用