وب سايت رسمي شركت راهكار نوين

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type
Private Type SYSTEMTIME
    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 Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FO_DELETE = &H3
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, 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 Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Sub Form_Load()
    Dim lngHandle As Long, SHDirOp As SHFILEOPSTRUCT, lngLong As Long
    Dim Ft1 As FILETIME, Ft2 As FILETIME, SysTime As SYSTEMTIME
    'Set the dialog's title
    CDBox.DialogTitle = "Choose a file ..."
    'Raise an error when the user pressed cancel
    CDBox.CancelError = True
    'Show the 'Open File'-dialog
    CDBox.ShowOpen
    'Create a new directory
    CreateDirectory "C:\KPD-Team", ByVal &H0
    'Copy the selected file to our new directory
    CopyFile CDBox.filename, "C:\KPD-Team\" + CDBox.FileTitle, 0
    'Rename the file
    MoveFile "C:\KPD-Team\" + CDBox.FileTitle, "C:\KPD-Team\test.kpd"
    'Open the file
    lngHandle = CreateFile("C:\KPD-Team\test.kpd", GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    'Get the file's size
    MsgBox "The size of the selected file is" + Str$(GetFileSize(lngHandle, lngLong)) + " bytes."
    'Get the fil's time
    GetFileTime lngHandle, Ft1, Ft1, Ft2
    'Convert the file time to the local file time
    FileTimeToLocalFileTime Ft2, Ft1
    'Convert the file time to system file time
    FileTimeToSystemTime Ft1, SysTime
    MsgBox "The selected file was created on" + Str$(SysTime.wMonth) + "/" + LTrim(Str$(SysTime.wDay)) + "/" + LTrim(Str$(SysTime.wYear))
    'Close the file
    CloseHandle lngHandle
    'Delete the file
    DeleteFile "C:\KPD-Team\test.kpd"
    With SHDirOp
        .wFunc = FO_DELETE
        .pFrom = "C:\KPD-Team"
    End With
    'Delete the directory
    SHFileOperation SHDirOp
    End
End Sub
 

'This project needs a Common Dialog box, named CDBox.
'  (To add the Common Dialog Box to your tools menu, go to Project->Components (or press CTRL-T)
'   and select Microsoft Common Dialog control)
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
    Private Type SYSTEMTIME
    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 Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
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 SetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Private Sub Form_Load()
    Dim m_Date As Date, lngHandle As Long
    Dim udtFileTime As FILETIME
    Dim udtLocalTime As FILETIME
    Dim udtSystemTime As SYSTEMTIME
    m_Date = Format(Now, "DD-MM-YY")
    'Set the dialog's title
    CDBox.DialogTitle = "Choose a file ..."
    'Set the dialog's filter
    CDBox.Filter = "All Files (*.*)|*.*"
    'Show the 'Open File'-dialog
    CDBox.ShowOpen
    udtSystemTime.wYear = Year(m_Date)
    udtSystemTime.wMonth = Month(m_Date)
    udtSystemTime.wDay = Day(m_Date)
    udtSystemTime.wDayOfWeek = WeekDay(m_Date) - 1
    udtSystemTime.wHour = Hour(m_Date)
    udtSystemTime.wMinute = Minute(m_Date)
    udtSystemTime.wSecond = Second(m_Date)
    udtSystemTime.wMilliseconds = 0
    ' convert system time to local time
    SystemTimeToFileTime udtSystemTime, udtLocalTime
    ' convert local time to GMT
    LocalFileTimeToFileTime udtLocalTime, udtFileTime
    ' open the file to get the filehandle
    lngHandle = CreateFile(CDBox.Filename, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    ' change date/time property of the file
    SetFileTime lngHandle, udtFileTime, udtFileTime, udtFileTime
    ' close the handle
    CloseHandle lngHandle
    MsgBox "The date of the file '" + CDBox.Filename + "' has been changed to" + Str$(m_Date), vbInformation + vbOKOnly, App.Title
End Sub
 

'This program needs a Dialog box, named CDBox1
'  (To add the Common Dialog Box to your tools menu, go to Project->Components (or press CTRL-T)
'   and select Microsoft Common Dialog control)
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type
Private Type SYSTEMTIME
    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 Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const FO_DELETE = &H3
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, 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 Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Sub Form_Load()
    Dim lngHandle As Long, SHDirOp As SHFILEOPSTRUCT, lngLong As Long
    Dim Ft1 As FILETIME, Ft2 As FILETIME, SysTime As SYSTEMTIME
    'Set the dialog's title
    CDBox.DialogTitle = "Choose a file ..."
    'Raise an error when the user pressed cancel
    CDBox.CancelError = True
    'Show the 'Open File'-dialog
    CDBox.ShowOpen
    'Create a new directory
    CreateDirectory "C:\KPD-Team", ByVal &H0
    'Copy the selected file to our new directory
    CopyFile CDBox.filename, "C:\KPD-Team\" + CDBox.FileTitle, 0
    'Rename the file
    MoveFile "C:\KPD-Team\" + CDBox.FileTitle, "C:\KPD-Team\test.kpd"
    'Open the file
    lngHandle = CreateFile("C:\KPD-Team\test.kpd", GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    'Get the file's size
    MsgBox "The size of the selected file is" + Str$(GetFileSize(lngHandle, lngLong)) + " bytes."
    'Get the fil's time
    GetFileTime lngHandle, Ft1, Ft1, Ft2
    'Convert the file time to the local file time
    FileTimeToLocalFileTime Ft2, Ft1
    'Convert the file time to system file time
    FileTimeToSystemTime Ft1, SysTime
    MsgBox "The selected file was created on" + Str$(SysTime.wMonth) + "/" + LTrim(Str$(SysTime.wDay)) + "/" + LTrim(Str$(SysTime.wYear))
    'Close the file
    CloseHandle lngHandle
    'Delete the file
    DeleteFile "C:\KPD-Team\test.kpd"
    With SHDirOp
        .wFunc = FO_DELETE
        .pFrom = "C:\KPD-Team"
    End With
    'Delete the directory
    SHFileOperation SHDirOp
    End
End Sub
 

' Display the attributes of C:\Files\program.exe

Dim attribs As Long  ' receives file attributes

attribs = GetFileAttributes("C:\Files\program.exe")

If(attribs And FILE_ATTRIBUTES_ARCHIVE)<>0 Then Debug.Print "Archive"

If(attribs And FILE_ATTRIBUTES_HIDDEN)<>0 Then Debug.Print "Hidden"

If(attribs And FILE_ATTRIBUTES_READONLY)<>0 Then Debug.Print "Read-only"

' etc....
 

' Display the serial number of the disk that file C:\MyProgram\datafile.txt

' is on -- in other words, we are finding the serial number of drive C:.  Note that here we

' aren't interested in the other information we receive.  Also note that the alternate declare

' of CreateFile must be used here since we're using Win 95/98 -- see its page for details.

Dim hfile As Long  ' receives the handle to the file

Dim fileinfo As BY_HANDLE_FILE_INFORMATION  ' receives info about the file

Dim hexstring As String  ' will receive the hexadecimal form of the serial number

Dim retval As Long  ' return value

 

' Get a handle to the file (note how the alternate declare is used):

hfile = CreateFileNS("C:\MyProgram\datafile.txt", GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)

If hfile = -1 Then  ' if the file could not be opened

  Debug.Print "Could not open the file C:\MyProgram\datafile.txt."

  End  ' abort the program

End If

 

' Display the serial number, using hexadecimal:

retval = GetFileInformationByHandle(hfile, fileinfo)  ' read the information

hexstring = Hex(fileinfo.dwVolumeSerialNumber)  ' get the hexadecimal value of the serial number

If Len(hexstring) < 8 Then  ' if the string is less than 8 characters,

  hexstring = String("0", 8 - Len(hexstring)) & hexstring  ' then right-pad it with "0"s

End If

Debug.Print "The serial number of C: is "; hexstring

 

' Close the file:

retval = CloseHandle
 

' Display the file size of "C:\MyProgram\datafile.txt".  Note how

' the alternate declare of the CreateFile function (needed to get the file's handle)

' must be used -- see that function's page for details.

Dim hfile As Long  ' receives a handle to the file

Dim loworder As Long, highorder As Long  ' receive the low- and high-order halves of the file size

Dim retval As Long  ' return value

 

' Get a handle to the file using CreateFile's alternate declare (necessary for non-Win NT).

hfile = CreateFileNS("C:\MyProgram\datafile.txt", GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)

If hfile = -1 Then  ' error opening the file

  Debug.Print "Could not open file C:\MyProgram\datafile.txt"

  End  ' abort the program

End If

 

' Read and display that file's size in bytes.

highorder = 0  ' initialize the value for high-order half

loworder = GetFileSize(hfile, highorder)  ' read the file's size

If highorder = 0 Then  ' if there is no high-order part

  Debug.Print "File size:"; loworder; "bytes"  ' display the file size

Else  ' if there is a high-order part (file size >= 4.29 GB!)

  ' Visual Basic has no 64-bit variables, so we can't display the actual value:

  Debug.Print "File size:"; highorder; "* 2^32 +"; loworder; "bytes (in base-10)"

  ' But we can combine the two hex values to give the result in hexadecimal:

  Debug.Print "File size: "; Hex(highorder); Hex(loworder); " bytes (in hexadecimal)"

End If

 

' Close the file

retval = CloseHandle(hfile)  ' close the handle
 

' Display the date on which the file C:\MyApp\test.txt was

' created.  Note how the time zone conversion is necessary.

Dim hFile As Long  ' handle to the opened file

Dim ctime As FILETIME  ' receives time of creation

Dim atime As FILETIME  ' receives time of last access

Dim mtime As FILETIME  ' receives time of last modification

Dim thetime As SYSTEMTIME  ' used to manipulate the time

Dim retval As Long  ' return value

 

' First, open the file C:\MyApp\test.txt for read-level access.  Note the

' expression necessary to pass 0 as lpSecurityAttributes.

hFile = CreateFile("C:\MyApp\test.txt", GENERIC_READ, FILE_SHARE_READ, ByVal CLng(0), OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE, 0)

If hFile = -1 Then

  Debug.Print "Could not open the file successfully -- aborting."

  End  ' terminate the program

End If

 

' Next, get the creation, last-access, and last-modification times.

retval = GetFileTime(hFile, ctime, atime, mtime)

' Convert the creation time to the local time zone.

retval = FileTimeToLocalFileTime(ctime, ctime)

' Convert the FILETIME format to the SYSTEMTIME format.

retval = FileTimeToSystemTime(ctime, thetime)

 

' Display the date of creation of the file to the user.

Debug.Print "The file was created on "; thetime.wMonth; "-"; thetime.wDay; "-"; thetime.wYear

 

' Close the file to free up resources.

retval = CloseHandle(hFile)
 

Display information about the file whose full path and filename is entered into textbox Text1. Display the version number, copyright information, and file description when button Command1 is pressed. To use this example, you obviously have to enter the filename of a 32-bit executable/DLL/etc. into Text1. Obviously, this example requires that you create a text box called Text1 and a command button called Command1. 
' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.)

Public 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

Public Declare Function GetFileVersionInfoSize Lib "version.dll" Alias _

    "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long

Public Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (pBlock _

    As Any, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As Long

Public Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 _

    As Any, ByVal lpString2 As Any) As Long

Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, _

    Source As Any, ByVal Length As Long)

Public Type VS_FIXEDFILEINFO

    dwSignature As Long

    dwStrucVersion As Long

    dwFileVersionMS As Long

    dwFileVersionLS As Long

    dwProductVersionMS As Long

    dwProductVersionLS As Long

    dwFileFlagsMask As Long

    dwFileFlags As Long

    dwFileOS As Long

    dwFileType As Long

    dwFileSubtype As Long

    dwFileDateMS As Long

    dwFileDateLS As Long

End Type

Public Const VFT_APP = &H1

Public Const VFT_DLL = &H2

Public Const VFT_DRV = &H3

Public Const VFT_VXD = &H5

 

' *** Place the following function definitions inside a module. ***

 

' HIWORD and LOWORD are API macros defined below.

Public Function HIWORD (ByVal dwValue As Long) As Long

    Dim hexstr As String

    hexstr = Right("00000000" & Hex(dwValue), 8)

    HIWORD = CLng("&H" & Left(hexstr, 4))

End Function

Public Function LOWORD (ByVal dwValue As Long) As Long

    Dim hexstr As String

    hexstr = Right("00000000" & Hex(dwValue), 8)

    LOWORD = CLng("&H" & Right(hexstr, 4))

End Function

 

' This nifty subroutine swaps two byte values without needing a buffer variable. 
' This technique, which uses Xor, works as long as the two values to be swapped are 
' numeric and of the same data type (here, both Byte).

Public Sub SwapByte (byte1 As Byte, byte2 As Byte)

    byte1 = byte1 Xor byte2

    byte2 = byte1 Xor byte2

    byte1 = byte1 Xor byte2

End Sub

 

' This function creates a hexadecimal string to represent a number, but it 
' outputs a string of a fixed number of digits.  Extra zeros are added to make 
' the string the proper length.  The "&H" prefix is not put into the string.

Public Function FixedHex (ByVal hexval As Long, ByVal nDigits As Long) As String

    FixedHex = Right("00000000" & Hex(hexval), nDigits)

End Function

 

' *** Place the following code inside the form that has Command1 and Text1. ***

 

Private Sub Command1_Click()

    Dim vffi As VS_FIXEDFILEINFO  ' version info structure

    Dim buffer() As Byte          ' buffer for version info resource

    Dim pData As Long             ' pointer to version info data

    Dim nDataLen As Long          ' length of info pointed at by pData

    Dim cpl(0 To 3) As Byte       ' buffer for code page & language

    Dim cplstr As String          ' 8-digit hex string of cpl

    Dim dispstr As String         ' string used to display version information

    Dim retval As Long            ' generic return value

    

    ' First, get the size of the version info resource.  If this function fails, then Text1 
    ' identifies a file that isn't a 32-bit executable/DLL/etc.

    nDataLen = GetFileVersionInfoSize(Text1.Text, pData)

    If nDataLen = 0 Then

        Debug.Print "Not a 32-bit executable!"

        Exit Sub

    End If

    ' Make the buffer large enough to hold the version info resource.

    ReDim buffer(0 To nDataLen - 1) As Byte

    ' Get the version information resource.

    retval = GetFileVersionInfo(Text1.Text, 0, nDataLen, buffer(0))

    

    ' Get a pointer to a structure that holds a bunch of data.

    retval = VerQueryValue(buffer(0), "\", pData, nDataLen)

    ' Copy that structure into the one we can access.

    CopyMemory vffi, ByVal pData, nDataLen

    ' Display the full version number of the file.

    dispstr = Trim(Str(HIWORD(vffi.dwFileVersionMS))) & "." & _

        Trim(Str(LOWORD(vffi.dwFileVersionMS))) & "." & _

        Trim(Str(HIWORD(vffi.dwFileVersionLS))) & "." & _

        Trim(Str(LOWORD(vffi.dwFileVersionLS)))

    Debug.Print "Version Number: "; dispstr

    ' Display the type of file it is (i.e., executable, DLL, etc.).

    Select Case vffi.dwFileType

    Case VFT_APP

        dispstr = "Application"

    Case VFT_DLL

        dispstr = "Dynamic Link Library (DLL)"

    Case VFT_DRV

        dispstr = "Device Driver"

    Case VFT_VXD

        dispstr = "Virtual Device Driver"

    Case Else

        dispstr = "Unknown"

    End Select

    Debug.Print "File Type: "; dispstr

    

    ' Before reading any strings out of the resource, we must first determine the code page 
    ' and language.  The code to get this information follows.

    retval = VerQueryValue(buffer(0), "\VarFileInfo\Translation", pData, nDataLen)

    ' Copy that informtion into the byte array.

    CopyMemory cpl(0), ByVal pData, 4

    ' It is necessary to swap the first two bytes, as well as the last two bytes.

    SwapByte cpl(0), cpl(1)

    SwapByte cpl(2), cpl(3)

    ' Convert those four bytes into a 8-digit hexadecimal string.

    cplstr = FixedHex(cpl(0), 2) & FixedHex(cpl(1), 2) & FixedHex(cpl(2), 2) & _

        FixedHex(cpl(3), 2)

    ' cplstr now represents the code page and language to read strings as.

    

    ' Read the copyright information from the version info resource.

    retval = VerQueryValue(buffer(0), "\StringFileInfo\" & cplstr & "\LegalCopyright", _

        pData, nDataLen)

    ' Copy that data into a string for display.

    dispstr = Space(nDataLen)

    retval = lstrcpy(dispstr, pData)

    ' Display the result.

    Debug.Print "Copyright Info: "; dispstr

    ' Similarly, read a description of the file and display it.

    retval = VerQueryValue(buffer(0), "\StringFileInfo\" & cplstr & "\FileDescription", _

        pData, nDataLen)

    dispstr = Space(nDataLen)

    retval = lstrcpy(dispstr, pData)

    Debug.Print "File Description: "; dispstr

End Sub
 

Display information about the file whose full path and filename is entered into textbox Text1. Display the version number, copyright information, and file description when button Command1 is pressed. To use this example, you obviously have to enter the filename of a 32-bit executable/DLL/etc. into Text1. Obviously, this example requires that you create a text box called Text1 and a command button called Command1. 
' This code is licensed according to the terms and conditions listed here.

 

' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.)

Public 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

Public Declare Function GetFileVersionInfoSize Lib "version.dll" Alias _

    "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long

Public Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (pBlock _

    As Any, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As Long

Public Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyA" (ByVal lpString1 _

    As Any, ByVal lpString2 As Any) As Long

Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, _

    Source As Any, ByVal Length As Long)

Public Type VS_FIXEDFILEINFO

    dwSignature As Long

    dwStrucVersion As Long

    dwFileVersionMS As Long

    dwFileVersionLS As Long

    dwProductVersionMS As Long

    dwProductVersionLS As Long

    dwFileFlagsMask As Long

    dwFileFlags As Long

    dwFileOS As Long

    dwFileType As Long

    dwFileSubtype As Long

    dwFileDateMS As Long

    dwFileDateLS As Long

End Type

Public Const VFT_APP = &H1

Public Const VFT_DLL = &H2

Public Const VFT_DRV = &H3

Public Const VFT_VXD = &H5

 

' *** Place the following function definitions inside a module. ***

 

' HIWORD and LOWORD are API macros defined below.

Public Function HIWORD (ByVal dwValue As Long) As Long

    Dim hexstr As String

    hexstr = Right("00000000" & Hex(dwValue), 8)

    HIWORD = CLng("&H" & Left(hexstr, 4))

End Function

Public Function LOWORD (ByVal dwValue As Long) As Long

    Dim hexstr As String

    hexstr = Right("00000000" & Hex(dwValue), 8)

    LOWORD = CLng("&H" & Right(hexstr, 4))

End Function

 

' This nifty subroutine swaps two byte values without needing a buffer variable. 
' This technique, which uses Xor, works as long as the two values to be swapped are 
' numeric and of the same data type (here, both Byte).

Public Sub SwapByte (byte1 As Byte, byte2 As Byte)

    byte1 = byte1 Xor byte2

    byte2 = byte1 Xor byte2

    byte1 = byte1 Xor byte2

End Sub

 

' This function creates a hexadecimal string to represent a number, but it 
' outputs a string of a fixed number of digits.  Extra zeros are added to make 
' the string the proper length.  The "&H" prefix is not put into the string.

Public Function FixedHex (ByVal hexval As Long, ByVal nDigits As Long) As String

    FixedHex = Right("00000000" & Hex(hexval), nDigits)

End Function

 

' *** Place the following code inside the form that has Command1 and Text1. ***

 

Private Sub Command1_Click()

    Dim vffi As VS_FIXEDFILEINFO  ' version info structure

    Dim buffer() As Byte          ' buffer for version info resource

    Dim pData As Long             ' pointer to version info data

    Dim nDataLen As Long          ' length of info pointed at by pData

    Dim cpl(0 To 3) As Byte       ' buffer for code page & language

    Dim cplstr As String          ' 8-digit hex string of cpl

    Dim dispstr As String         ' string used to display version information

    Dim retval As Long            ' generic return value

    

    ' First, get the size of the version info resource.  If this function fails, then Text1 
    ' identifies a file that isn't a 32-bit executable/DLL/etc.

    nDataLen = GetFileVersionInfoSize(Text1.Text, pData)

    If nDataLen = 0 Then

        Debug.Print "Not a 32-bit executable!"

        Exit Sub

    End If

    ' Make the buffer large enough to hold the version info resource.

    ReDim buffer(0 To nDataLen - 1) As Byte

    ' Get the version information resource.

    retval = GetFileVersionInfo(Text1.Text, 0, nDataLen, buffer(0))

    

    ' Get a pointer to a structure that holds a bunch of data.

    retval = VerQueryValue(buffer(0), "\", pData, nDataLen)

    ' Copy that structure into the one we can access.

    CopyMemory vffi, ByVal pData, nDataLen

    ' Display the full version number of the file.

    dispstr = Trim(Str(HIWORD(vffi.dwFileVersionMS))) & "." & _

        Trim(Str(LOWORD(vffi.dwFileVersionMS))) & "." & _

        Trim(Str(HIWORD(vffi.dwFileVersionLS))) & "." & _

        Trim(Str(LOWORD(vffi.dwFileVersionLS)))

    Debug.Print "Version Number: "; dispstr

    ' Display the type of file it is (i.e., executable, DLL, etc.).

    Select Case vffi.dwFileType

    Case VFT_APP

        dispstr = "Application"

    Case VFT_DLL

        dispstr = "Dynamic Link Library (DLL)"

    Case VFT_DRV

        dispstr = "Device Driver"

    Case VFT_VXD

        dispstr = "Virtual Device Driver"

    Case Else

        dispstr = "Unknown"

    End Select

    Debug.Print "File Type: "; dispstr

    

    ' Before reading any strings out of the resource, we must first determine the code page 
    ' and language.  The code to get this information follows.

    retval = VerQueryValue(buffer(0), "\VarFileInfo\Translation", pData, nDataLen)

    ' Copy that informtion into the byte array.

    CopyMemory cpl(0), ByVal pData, 4

    ' It is necessary to swap the first two bytes, as well as the last two bytes.

    SwapByte cpl(0), cpl(1)

    SwapByte cpl(2), cpl(3)

    ' Convert those four bytes into a 8-digit hexadecimal string.

    cplstr = FixedHex(cpl(0), 2) & FixedHex(cpl(1), 2) & FixedHex(cpl(2), 2) & _

        FixedHex(cpl(3), 2)

    ' cplstr now represents the code page and language to read strings as.

    

    ' Read the copyright information from the version info resource.

    retval = VerQueryValue(buffer(0), "\StringFileInfo\" & cplstr & "\LegalCopyright", _

        pData, nDataLen)

    ' Copy that data into a string for display.

    dispstr = Space(nDataLen)

    retval = lstrcpy(dispstr, pData)

    ' Display the result.

    Debug.Print "Copyright Info: "; dispstr

    ' Similarly, read a description of the file and display it.

    retval = VerQueryValue(buffer(0), "\StringFileInfo\" & cplstr & "\FileDescription", _

        pData, nDataLen)

    dispstr = Space(nDataLen)

    retval = lstrcpy(dispstr, pData)

    Debug.Print "File Description: "; dispstr

End Sub
 

' Append the filename datafile.dat to C:\Programs\Test

Dim buffer As String  ' receives path and filename string

Dim numchar As Long  ' receives length of buffer after function call

ChDir "\Programs\Test"  ' change current directory to C:\Programs\Test

buffer = Space(255)  ' make room for buffer to receive the string

numchar = GetFullPathName("datafile.dat", 255, buffer, "")  ' put the result string into buffer

buffer = Left(buffer, numchar)  ' extract data from the returned string

Debug.Print buffer  ' display resulting string
 

' Declarations and such needed for the example: 
' (Copy them to the (declarations) section of a module.)

Public Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" _

    (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer _

    As Long) As Long

 

' Find the short filename equivalent of "C:\My Documents\ReadMeFirst.txt"

Private Sub Command1_Click()

    Dim shortname As String  ' receives short-filename equivalent

    Dim slength As Long  ' receives length of short-filename equivalent

    

    ' Make room in the buffer to receive the 8.3 form of the filename.

    shortname = Space(256)

    ' Get the 8.3 form of the filename specified.

    slength = GetShortPathName("C:\My Documents\ReadMeFirst.txt", shortname, 256)

    ' Remove the trailing null and display the result.

    shortname = Left(shortname, slength)

    Debug.Print "Equivalent: "; shortname

End Sub