Stuart McCall's Microsoft Access Pages - Misc API
Home
Determine a drive's Volume name and Serial number
Declare Function GetVolumeInformation _
Lib "KERNEL32" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
|
Public Sub GetVolumeInfo(Path As String, Volume As String, Serial As String)
'Extracts Volume name and Serial number
'from info returned by API
Dim n As Long
Volume = Space$(14)
If GetVolumeInformation( _
Path, Volume, 14, n, _
0&, 0&, vbNullString, 0& _
) = 0 Then Exit Sub
Volume = Left$(Volume, InStr(Volume, vbNullChar) - 1)
Serial = Format$(Hex(HiWord(n)), "0000") & _
"-" & Format$(Hex(LoWord(n)), "0000")
End Sub
Private Function HiWord(Dword As Long) As Integer
'Returns the high word of a doubleword value
If Dword And &H80000000 Then
HiWord = (Dword \ &HFFFF&) - 1
Else
HiWord = Dword \ &HFFFF&
End If
End Function
Private Function LoWord(Dword As Long) As Integer
'Returns the low word of a doubleword value
If Dword And &H8000& Then
LoWord = &H8000 Or (Dword And &H7FFF)
Else
LoWord = Dword And &H7FFF
End If
End Function
|
Usage:
Dim v As String, s As String
GetVolumeInfo "c:\", v, s
MsgBox "Volume: " & v & vbcrlf & "Serial: " & s
File Open Dialog
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
NFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'
Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000
|
Public Function sjmFileOpen( _
Optional ByVal OpenDialog, _
Optional ByRef Flags, _
Optional ByVal InitDir, _
Optional ByVal FileName, _
Optional ByVal BoxTitle, _
Optional ByVal Filters, _
Optional ByVal DefaultFilter, _
Optional ByVal DefaultExt _
) As String
' Parameters:
' OpenDialog: False = Open, True = Save
' Flags: Standard api flag constants. (modified by reference)
' InitDir: Initial dir to show
' FileName: Default file name
' BoxTitle: Dialog's Caption
' Filters: Standard file filters ('|' delimited string)
' DefaultFilter: Default Filter to use
' DefaultExt: Default extension to use for save dialog
'
'Return Value:
' Selected file's full path. "" if Cancelled
Dim dlg As OPENFILENAME
Dim ret As Boolean
Dim n As Integer
Const BufferLen As Integer = 512
If IsMissing(OpenDialog) Then OpenDialog = False
If IsMissing(Flags) Then Flags = OFN_HIDEREADONLY
If IsMissing(InitDir) Then InitDir = CurDir
If IsMissing(FileName) Then FileName = ""
If IsMissing(BoxTitle) Then BoxTitle = ""
If IsMissing(Filters) Then Filters = "All Files (*.*)|*.*|"
If IsMissing(DefaultFilter) Then DefaultFilter = 1
If IsMissing(DefaultExt) Then DefaultExt = ""
FileName = Left$(FileName & String$(BufferLen, vbNullChar), BufferLen)
Filters = Replace(Filters, "|", vbNullChar)
With dlg
.lStructSize = Len(dlg)
.hWndOwner = Application.hWndAccessApp
.strFilter = Filters
.NFilterIndex = DefaultFilter
.strFile = FileName
.nMaxFile = BufferLen
.strTitle = BoxTitle
.Flags = Flags
.strDefExt = DefaultExt
.strInitialDir = InitDir
.nMaxCustFilter = BufferLen
.strCustomFilter = String$(BufferLen, vbNullChar)
End With
If OpenDialog Then
ret = GetSaveFileName(dlg)
Else
ret = GetOpenFileName(dlg)
End If
If ret Then
sjmFileOpen = Left(dlg.strFile, InStr(dlg.strFile, vbNullChar) - 1)
Flags = dlg.Flags
End If
End Function
|
Browse for folder
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'
Private Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long
|
Public Function SelectFolder(ByVal strPrompt As String) As String
Dim bi As BROWSEINFO
bi.ulFlags = 1
bi.lpszTitle = strPrompt
strPrompt = Space$(512)
If SHGetPathFromIDListA(SHBrowseForFolderA(bi), strPrompt) Then
SelectFolder = Left(strPrompt, InStr(strPrompt, vbNullChar) - 1)
End If
End Function
|
Screen-scrape a web page
Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
|
Function DownloadURL(sSourceUrl As String, sLocalFile As String) As Boolean
DownloadURL = (URLDownloadToFile(0&, sSourceUrl, sLocalFile, 0&, 0&) = 0)
End Function
|
Usage:
Dim success As Boolean
success = DownloadURL("http://www.microsoft.com", "c:\temp\myfile.txt")
Determine UNC path of mapped drive
Private Const ERROR_BAD_DEVICE = 1200&
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NOT_SUPPORTED = 50&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const NO_ERROR = 0
Private Declare Function WNetGetConnectionA Lib "mpr.dll" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
|
Public Function UNCPath(ByVal pstrDriveLetter As String) As String
' Returns UNC path associated with
' mapped drive pstrDriveLetter
Dim strName As String
Dim lngReturn As Long
'
Const BUFLEN As Long = 255
'
strName = Space$(BUFLEN)
lngReturn = WNetGetConnectionA(pstrDriveLetter, strName, BUFLEN)
Select Case lngReturn
Case ERROR_BAD_DEVICE
UNCPath = "Error: Bad Device"
Case ERROR_CONNECTION_UNAVAIL
UNCPath = "Error: Connection Un-Available"
Case ERROR_EXTENDED_ERROR
UNCPath = "Error: Extended Error"
Case ERROR_MORE_DATA
UNCPath = "Error: More Data"
Case ERROR_NOT_SUPPORTED
UNCPath = "Error: Feature not Supported"
Case ERROR_NO_NET_OR_BAD_PATH
UNCPath = "Error: No Network Available or Bad Path"
Case ERROR_NO_NETWORK
UNCPath = "Error: No Network Available"
Case ERROR_NOT_CONNECTED
UNCPath = "Error: Not Connected"
Case NO_ERROR
UNCPath = Left$(strName, InStr(1, strName, vbNullChar) - 1)
End Select
End Function
|
Usage:
Debug.Print UNCPath("Z:")
Text to/from Clipboard
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd&) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat&) As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat&, ByVal hMem&) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes&) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem&) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem&) As Long
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Const CF_TEXT = 1
|
Function clipGetText() As String
' Retrieve text from the clipboard
' If clipboard is empty, or contents
' are not textual, returns ""
Dim hMem As Long
Dim lpMem As Long
Dim strResult As String
Const BUF_SIZE = 4096
If OpenClipboard(0&) = 0 Then Exit Function
hMem = GetClipboardData(CF_TEXT)
If hMem = 0 Then GoTo clipGetText_Exit
lpMem = GlobalLock(hMem)
If lpMem Then
strResult = Space$(BUF_SIZE)
lstrcpy strResult, lpMem
GlobalUnlock hMem
strResult = Left$(strResult, InStr(1, strResult, vbNullChar, 0) - 1)
End If
clipGetText_Exit:
CloseClipboard
clipGetText = strResult
End Function
Sub clipPutText(theText As String)
' Stores text on the clipboard
Dim hMem As Long
Const GHND = &H42
hMem = GlobalAlloc(GHND, Len(theText) + 1)
lstrcpy GlobalLock(hMem), theText
If GlobalUnlock(hMem) <> 0 Then Exit Sub
If OpenClipboard(0&) = 0 Then Exit Sub
EmptyClipboard
SetClipboardData CF_TEXT, hMem
CloseClipboard
End Sub
|
Determine if current database is open exclusive
Public Function dbOpenExcl() As Boolean
' Determine if current database is open exclusive.
' True = open exclusive
Dim fh As Integer
fh = FreeFile
On Error Resume Next
Open CurrentDb.Name For Binary Access Read Write Shared As fh
dbOpenExcl = (Err.Number > 0)
Close fh
End Function
|
Auto-Dial a phone number using a modem
Declare Function WriteFile& Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite&, lpNumberOfBytesWritten&, ByVal lpOverlapped&)
Declare Function CreateFile& Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName$, ByVal dwDesiredAccess&, ByVal dwShareMode&, ByVal lpSecurityAttributes&, ByVal dwCreationDisposition&, ByVal dwFlagsAndAttributes&, ByVal hTemplateFile&)
Declare Function CloseHandle& Lib "kernel32" (ByVal hObject&)
Declare Function FlushFileBuffers& Lib "kernel32" (ByVal hFile&)
|
Function DialNumber(PhoneNumber, Optional CommPort As String = "COM2", Optional WaitSeconds As Long = 4)
' PhoneNumber: The phone number to dial
' CommPort: The comm port the modem is connected
' to. Typically, modems are found on COM2, however,
' they can be configured for any COM port.
' WaitSeconds: The number of seconds to wait for the modem to
' finish dialling before resetting the modem. If the phone
' hangs up prematurely, try increasing this value by small increments.
Dim openPort&, retVal&
Dim startTime
' Ask the user to pick up the phone.
If MsgBox("Please pickup the phone and choose OK to dial " & PhoneNumber & ".", _
vbInformation + vbOKCancel, "Dial Number") = vbCancel Then Exit Function
' Open the Com port for read/write (&HC0000000).
' Must specify existing file (3).
openPort = CreateFile(CommPort, &HC0000000, 0, 0, 3, 0, 0)
If openPort = -1 Then
MsgBox "Unable to open communication port " & CommPort, vbCritical, "Dial Number Error"
Exit Function
End If
' Write modem command to the Com port.
retVal = WriteBytes(openPort, "ATDT" & PhoneNumber & vbCrLf)
If retVal = 0 Then
MsgBox "Unable to dial number " & PhoneNumber, vbCritical, "Dial Number Error"
Exit Function
End If
' Wait WaitSeconds for the phone to finish dialling.
startTime = Timer
Do While Timer < startTime + WaitSeconds
DoEvents
Loop
' Reset the modem and take it off line.
WriteBytes openPort, "ATH0" & vbCrLf
' Close the Com port.
CloseHandle openPort
End Function
Private Function WriteBytes(openPort, cmd$) As Long
Dim a(256) As Byte, retBytes&, i&
For i = 0 To Len(cmd) - 1
a(i) = Asc(Mid(cmd, i + 1, 1))
Next
WriteBytes = WriteFile(openPort, a(0), Len(cmd), retBytes, 0)
FlushFileBuffers openPort
End Function
|
Create and delete a user or system DSN
Private Const ODBC_ADD_DSN = 1
Private Const ODBC_CONFIG_DSN = 2
Private Const ODBC_REMOVE_DSN = 3
Private Const ODBC_ADD_SYS_DSN = 4
Private Const ODBC_CONFIG_SYS_DSN = 5
Private Const ODBC_REMOVE_SYS_DSN = 6
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
|
Public Function DSNCreate(ByVal Description$, ByVal DSN$, ByVal Driver$, ByVal Database$, ByVal UserID$, ByVal Password$, ByVal Path$, SystemDSN As Boolean) As Boolean
'Creates a user or system DSN via parameters
'which it uses to build a connect string
'It then calls function CreateDSN (below)
'Requires nReplace
Const con = "DBQ=%1;DSN=%2;UID=%3;PWD=%4;DESCRIPTION=%5;DIR=%6"
Dim Connect$, req&
Connect = nReplace(con, Database, DSN, UserID, Password, Description, Path)
DSNCreate = CreateDSN(Driver, Connect, SystemDSN)
End Function
Public Function CreateDSN(ByVal Driver$, ByVal Connect$, SystemDSN As Boolean) As Boolean
'Creates a user or system DSN via a connect string
'Returns True for success
Connect = Replace(Connect, ";", vbNullChar)
CreateDSN = SQLConfigDataSource(0&, IIf(SystemDSN, ODBC_ADD_SYS_DSN, ODBC_ADD_DSN), Driver, Connect)
End Function
Public Function DSNDelete(ByVal DSN$, ByVal Driver$, Optional SystemDSN As Boolean = False) As Boolean
'Deletes a user or system DSN by name
'Returns True for success
Dim Connect$
Connect = "DSN=" & DSN & vbNullChar
DeleteDSN = SQLConfigDataSource(0&, IIf(SystemDSN, ODBC_REMOVE_SYS_DSN, ODBC_REMOVE_DSN), Driver, Connect)
End Function
|
DSN listing functions
Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv As Long, ByVal fDirection As Integer, ByVal szDSN As String, ByVal cbDSNMax As Integer, pcbDSN As Integer, ByVal szDescription As String, ByVal cbDescriptionMax As Integer, pcbDescription As Integer) As Integer
Private Declare Function SQLAllocEnv Lib "ODBC32.DLL" (env As Long) As Integer
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_FETCH_NEXT As Long = 1
|
Public Function DSNList(col As Collection, Optional ByVal DriverName$ = "All") As Boolean
'Fills the collection col with a list of DSNs
'Returns True for success
Dim DSNItem As String * 1024, DRVItem As String * 1024
Dim EnvHwnd&, ret&, DSNLen%, DRVLen%
On Error GoTo ExitPoint
If SQLAllocEnv(EnvHwnd) <> -1 Then
Set col = New Collection
Do Until ret& <> SQL_SUCCESS
ret& = SQLDataSources(EnvHwnd, SQL_FETCH_NEXT, DSNItem, 1024, DSNLen, DRVItem, 1024, DRVLen)
If DriverName = Left$(DRVItem, DRVLen) Or DriverName = "All" Then
col.Add Left$(DSNItem, DSNLen)
End If
Loop
End If
DSNList = True
ExitPoint:
End Function
Public Function DRVList(col As Collection) As Boolean
'Fills the collection col with a list of Drivers
'Returns True for success
Dim DRVItem As String * 1024, DSNItem As String * 1024
Dim EnvHwnd&, ret&, DRV$, DSNLen%, DRVLen%
'
On Error GoTo ExitPoint
If SQLAllocEnv(EnvHwnd) <> -1 Then
Set col = New Collection
Do Until ret& <> SQL_SUCCESS
ret = SQLDataSources(EnvHwnd, SQL_FETCH_NEXT, DSNItem, 1024, DSNLen, DRVItem, 1024, DRVLen)
col.Add Left$(DRVItem, DRVLen)
Loop
End If
DRVList = True
ExitPoint:
End Function
Public Function DSNRowSource() As String
'Returns a semicolon-delimited list of DSNs
'for use as a combo or listbox 'Value List'
'Demonstrates use of DSNList
Dim c As Collection, itm As Variant, rtn$
If DSNList(c) Then
If c.Count = 0 Then Exit Function
For Each itm In c
rtn = rtn & ";" & itm
Next
End If
DSNRowSource = Mid$(rtn, 2)
End Function
Public Function DRVRowSource() As String
'Returns a semicolon-delimited list of drivers
'for use as a combo or listbox 'Value List'
'Demonstrates use of DRVList
Dim c As Collection, itm As Variant, rtn$
If DRVList(c) Then
If c.Count = 0 Then Exit Function
For Each itm In c
rtn = rtn & ";" & itm
Next
End If
DRVRowSource = Mid$(rtn, 2)
End Function
Public Function IsDSN(ByVal DSN$, Optional ByVal DriverName$ = "All") As Boolean
'Determines whether DSN already exists
'Demonstrates use of DSNList
Dim col As Collection, itm As Variant
If DSNList(col, DriverName) Then
For Each itm In col
If itm = DSN Then
IsDSN = True
Exit For
End If
Next
End If
End Function
|
Fill a Value-List Listbox with Data Source Names
Requires: DSNRowSource
Public Function DSNListbox(lst As Access.ListBox, Optional ByVal DriverName$ = "All")
lst.RowSource = DSNRowSource()
End Function
|
Usage:
DSNListbox Me.List0
- Create a form and put a listbox on it. Call it List0.
- Set the listbox's Row Source Type property to Value List.
- Paste the usage example into the Form_Load event.
- Open the form to test.
Send a message to another workstation
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hHandle As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" _
(ByVal hFile As Long, ByVal lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_SHARE_READ = &H1
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = &H3
|
Public Function NetSendMsg(FromName As String, MachineName As String, Message As String) As Boolean
Const NUL = vbNullChar
Dim buf As String
Dim bytesWritten As Long
Dim hFile As Long
Dim SlotName As String
'
buf = FromName & NUL & MachineName & NUL & Message & NUL & NUL
SlotName = "\\" & MachineName & "\mailslot\messngr"
'
hFile = CreateFile(SlotName, GENERIC_WRITE, FILE_SHARE_READ, 0&, _
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
If hFile Then
NetSendMsg = CBool(WriteFile(hFile, buf, Len(buf), bytesWritten, 0&))
CloseHandle hFile
End If
End Function
|
Usage:
success = NetSendMsg("Stuart", "WS03", "Please call me ASAP")
This sends a message from me to the workstation named WS03.
Get/set File date and time stamps
Private Type FILE_TIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEM_TIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILE_TIME, lpLastAccessTime As FILE_TIME, lpLastWriteTime As FILE_TIME) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILE_TIME, lpLastAccessTime As FILE_TIME, lpLastWriteTime As FILE_TIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILE_TIME, lpSystemTime As SYSTEM_TIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEM_TIME, lpFileTime As FILE_TIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILE_TIME, lpLocalFileTime As FILE_TIME) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILE_TIME, lpFileTime As FILE_TIME) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const GENERIC_WRITE As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const OPEN_EXISTING As Long = &H3
Public Enum ft_FileTime
ftCreationTime = 1
ftAccessedTime = 2
ftModifiedTime = 3
End Enum
|
Public Function ReadFileTime(FileName As String, WhichTime As ft_FileTime) As Date
Dim ft1 As FILE_TIME, ft2 As FILE_TIME, ft3 As FILE_TIME, ft4 As FILE_TIME, sysTime As SYSTEM_TIME
Dim hFile As Long
On Error GoTo Handler
hFile = CreateFile(FileName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
GetFileTime hFile, ft1, ft2, ft3
CloseHandle hFile
Select Case WhichTime
Case ftCreationtime
FileTimeToLocalFileTime ft1, ft4
FileTimeToSystemTime ft4, sysTime
Case ftAccessedtime
FileTimeToLocalFileTime ft2, ft4
FileTimeToSystemTime ft4, sysTime
Case ftModifiedtime
FileTimeToLocalFileTime ft3, ft4
FileTimeToSystemTime ft4, sysTime
End Select
With sysTime
ReadFileTime = CDate(.wDay & "/" & .wMonth & "/" & .wYear & " " & .wHour & ":" & .wMinute & ":" & .wSecond)
End With
ExitPoint:
Exit Function
Handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical
Resume ExitPoint
End Function
Public Function WriteFileTime(FileName As String, WhichTime As ft_FileTime, NewTime As Date) As Boolean
Dim ft1 As FILE_TIME, ft2 As FILE_TIME, ft3 As FILE_TIME, ft4 As FILE_TIME, sysTime As SYSTEM_TIME
Dim hFile As Long
On Error GoTo Handler
With sysTime
.wDay = Day(NewTime)
.wDayOfWeek = Weekday(NewTime) - 1
.wMonth = Month(NewTime)
.wYear = Year(NewTime)
.wHour = Hour(NewTime)
.wMinute = Minute(NewTime)
.wSecond = Second(NewTime)
End With
hFile = CreateFile(FileName, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
GetFileTime hFile, ft1, ft2, ft3
Select Case WhichTime
Case ftCreationtime
SystemTimeToFileTime sysTime, ft1
LocalFileTimeToFileTime ft1, ft4
SetFileTime hFile, ft4, ft2, ft3
Case ftAccessedtime
SystemTimeToFileTime sysTime, ft2
LocalFileTimeToFileTime ft2, ft4
SetFileTime hFile, ft1, ft4, ft3
Case ftModifiedtime
SystemTimeToFileTime sysTime, ft3
LocalFileTimeToFileTime ft3, ft4
SetFileTime hFile, ft1, ft2, ft4
End Select
WriteFileTime = True
ExitPoint:
CloseHandle hFile
Exit Function
Handler:
MsgBox Err.Description & " (" & Err.Number & ")", vbCritical
Resume ExitPoint
End Function
|
Usage:
Debug.Print ReadFileTime("c:\temp\test.txt", ftModifiedtime)
'This outputs the given file's last modified time to the immediate window.
WriteFileTime "c:\temp\test.txt", ftCreationtime, Now())
'This overwrites the given file's creation time with the current date/time.
Determine exe file version
Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Long, ByVal Length As Long)
'
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionl As Integer ' e.g. = &h0000 = 0
dwStrucVersionh As Integer ' e.g. = &h0042 = .42
dwFileVersionMSl As Integer ' e.g. = &h0003 = 3
dwFileVersionMSh As Integer ' e.g. = &h0075 = .75
dwFileVersionLSl As Integer ' e.g. = &h0000 = 0
dwFileVersionLSh As Integer ' e.g. = &h0031 = .31
dwProductVersionMSl As Integer ' e.g. = &h0003 = 3
dwProductVersionMSh As Integer ' e.g. = &h0010 = .1
dwProductVersionLSl As Integer ' e.g. = &h0000 = 0
dwProductVersionLSh As Integer ' e.g. = &h0031 = .31
dwFileFlagsMask As Long ' = &h3F For version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG Or VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS32
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type
|
Public Function ExeFileVersion(FullPath As Variant) As String
'Returns version of exe file
'or zero length string on error.
On Error GoTo Out
'
Dim lDummy As Long, lSize As Long
Dim lVerbufferLen As Long, lVerPointer As Long
Dim sBuffer() As Byte
Dim udtVerBuffer As VS_FIXEDFILEINFO
Dim ProdVer As String
'
lSize = GetFileVersionInfoSize(FullPath, lDummy)
If lSize < 1 Then Exit Function
ReDim sBuffer(lSize)
GetFileVersionInfo FullPath, 0&, lSize, sBuffer(0)
VerQueryValue sBuffer(0), "\", lVerPointer, lVerbufferLen
MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)
ExeFileVersion = Format$(udtVerBuffer.dwProductVersionMSh) & _
"." & Format$(udtVerBuffer.dwProductVersionMSl)
Out:
End Function
|
Usage:
Debug.Print ExeFileVersion("C:\Program Files\Microsoft Office11\OFFICE11\MSACCESS.EXE")
'This outputs the given file's version number to the immediate window.
Result: 11:0
