home *** CD-ROM | disk | FTP | other *** search
/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / vbpg32 / samples5 / ch13 / filedemo.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-02-16  |  9.9 KB  |  301 lines
  1. VERSION 5.00
  2. Begin VB.Form FileDemo 
  3.    Caption         =   "File Demo"
  4.    ClientHeight    =   2520
  5.    ClientLeft      =   1095
  6.    ClientTop       =   1770
  7.    ClientWidth     =   4980
  8.    BeginProperty Font 
  9.       Name            =   "MS Sans Serif"
  10.       Size            =   8.25
  11.       Charset         =   0
  12.       Weight          =   700
  13.       Underline       =   0   'False
  14.       Italic          =   0   'False
  15.       Strikethrough   =   0   'False
  16.    EndProperty
  17.    ForeColor       =   &H80000008&
  18.    LinkMode        =   1  'Source
  19.    LinkTopic       =   "Form1"
  20.    PaletteMode     =   1  'UseZOrder
  21.    ScaleHeight     =   2520
  22.    ScaleWidth      =   4980
  23.    Begin VB.DirListBox Dir1 
  24.       Height          =   1380
  25.       Left            =   240
  26.       TabIndex        =   1
  27.       Top             =   720
  28.       Width           =   2295
  29.    End
  30.    Begin VB.FileListBox File1 
  31.       Height          =   1785
  32.       Left            =   2760
  33.       Pattern         =   "*.exe;*.dll;*.vbx"
  34.       TabIndex        =   2
  35.       Top             =   240
  36.       Width           =   1935
  37.    End
  38.    Begin VB.DriveListBox Drive1 
  39.       Height          =   315
  40.       Left            =   240
  41.       TabIndex        =   0
  42.       Top             =   240
  43.       Width           =   2295
  44.    End
  45.    Begin VB.Menu MenuInformation 
  46.       Caption         =   "Information"
  47.       Begin VB.Menu MenuDevices 
  48.          Caption         =   "Devices"
  49.       End
  50.       Begin VB.Menu MenuPrinters 
  51.          Caption         =   "Printers"
  52.       End
  53.       Begin VB.Menu MenuVersionInfo 
  54.          Caption         =   "Version Info"
  55.       End
  56.       Begin VB.Menu MenuVersionDesc 
  57.          Caption         =   "Version Desc:"
  58.       End
  59.    End
  60. Attribute VB_Name = "FileDemo"
  61. Attribute VB_GlobalNameSpace = False
  62. Attribute VB_Creatable = False
  63. Attribute VB_PredeclaredId = True
  64. Attribute VB_Exposed = False
  65. Option Explicit
  66. ' Copyright 
  67.  1997 by Desaware Inc. All Rights Reserved
  68. '   Breaks a 32 bit version into major and minor revs, then
  69. '   then returns the string representation.
  70. Private Function CalcVersion$(vernum&)
  71.     Dim major%, minor%
  72.     major% = CInt(vernum& / &H10000)
  73.     minor% = CInt(vernum& And &HFFFF&)
  74.     CalcVersion$ = Str$(major%) + "." + LTrim$(Str$(minor%))
  75. End Function
  76. Private Sub Dir1_Change()
  77.     File1.Path = Dir1.Path
  78. End Sub
  79. Private Sub Drive1_Change()
  80.     Dir1.Path = Drive1.Drive
  81. End Sub
  82. Private Sub File1_Click()
  83.     Dim fressize&
  84.     Dim freshnd&
  85.     Dim di&
  86.     ' Build the file name
  87.     If Right$(Dir1.Path, 1) = "\" Then
  88.         FileName$ = Dir1.Path + File1.FileName
  89.     Else
  90.         FileName$ = Dir1.Path + "\" + File1.FileName
  91.     End If
  92.     ' Determine if version information is present, and
  93.     ' if so how large a buffer is needed to hold it.
  94.     fressize& = GetFileVersionInfoSize(FileName$, freshnd&)
  95.     ' The following code from the VB3 version is no longer needed
  96.     'If fressize& = 0 Then
  97.     '    verbuf$ = ""
  98.     '    Exit Sub
  99.     'End If
  100.     ' Version info is unlikely to ever be greater than 64k
  101.     ' but check anyway. If it was larger than 64k, we would
  102.     ' need to allocate a huge buffer instead.  Note, we
  103.     ' are only using an approximation to 64k here to take
  104.     ' into account the VB string overhead.
  105.     If fressize& > 64000 Then fressize& = 64000
  106.     'Was: verbuf$ = String$(CInt(fressize&) + 1, Chr$(0))
  107.     ReDim verbuf(fressize + 1)
  108.     ' Load the string with the version information
  109.     ' In Win16, we used the address of the string
  110.     ' Was: di% = GetFileVersionInfo(FileName$, freshnd&, fressize&, agGetAddressForVBString&(verbuf$))
  111.     di = GetFileVersionInfo(FileName$, freshnd&, fressize&, verbuf(0))
  112.     ' The menu commands will use the information global
  113.     ' in this global version buffer.
  114.     If di = 0 Then ReDim verbuf(1)   ' Error occured
  115. End Sub
  116. Private Function GetInfoString$(stringtoget$)
  117.     Dim tbuf$
  118.     Dim nullpos%
  119.     Dim xlatelang%
  120.     Dim xlatecode%
  121.     Dim numentries%
  122.     Dim fiiaddr&
  123.     Dim xlatestring$
  124.     Dim xlateval&
  125.     #If Win32 Then
  126.         Dim fiilen&
  127.         Dim di&
  128.     #Else
  129.         Dim fiilen%
  130.         Dim di%
  131.     #End If
  132.     Dim x%
  133.     di = VerQueryValue(verbuf(0), "\VarFileInfo\Translation", fiiaddr&, fiilen)
  134.     If (di <> 0) Then ' Translation table exists
  135.         numentries% = fiilen / 4
  136.         xlateval& = 0
  137.         For x% = 1 To numentries%
  138.             ' Copy the 4 byte tranlation entry for the first
  139.             agCopyData ByVal fiiaddr&, xlatelang%, 2
  140.             agCopyData ByVal (fiiaddr& + 2), xlatecode%, 2
  141.             ' Exit if U.S. English was found
  142.             If xlatelang% = &H409 Then Exit For
  143.             fiiaddr& = fiiaddr& + 4
  144.         Next x%
  145.     Else
  146.         ' No translation table - Assume standard ASCII
  147.         xlatelang% = &H409
  148.         xlatecode% = 0
  149.     End If
  150.     xlatestring$ = Hex$(xlatecode%)
  151.     ' Make sure hex string is 4 chars long
  152.     While Len(xlatestring$) < 4
  153.         xlatestring$ = "0" + xlatestring$
  154.     Wend
  155.     xlatestring$ = Hex$(xlatelang%) + xlatestring$
  156.     ' Make sure hex string is 8 chars long
  157.     While Len(xlatestring$) < 8
  158.         xlatestring$ = "0" + xlatestring$
  159.     Wend
  160.     di = VerQueryValue(verbuf(0), "\StringFileInfo\" + xlatestring$ + "\" + stringtoget$, fiiaddr&, fiilen)
  161.     If di = 0 Then
  162.         GetInfoString$ = "Unavailable"
  163.         Exit Function
  164.     End If
  165.     tbuf$ = String$(fiilen + 1, Chr$(0))
  166.     ' Copy the fixed file info into the structure
  167.     agCopyData ByVal fiiaddr&, ByVal tbuf$, fiilen
  168.     nullpos% = InStr(tbuf$, Chr$(0))
  169.     If (nullpos% > 1) Then
  170.         GetInfoString$ = Left$(tbuf$, nullpos% - 1)
  171.     Else
  172.         GetInfoString$ = "None"
  173.     End If
  174. End Function
  175. Private Sub MenuDevices_Click()
  176.     ShowDevices
  177. End Sub
  178. Private Sub MenuPrinters_Click()
  179.     ShowPrinters
  180. End Sub
  181. Private Sub MenuVersionDesc_Click()
  182.     ShowDescInfo
  183. End Sub
  184. Private Sub MenuVersionInfo_Click()
  185.     ShowVersionInfo
  186. End Sub
  187. ' This function shows how to obtain other information about
  188. ' a file.
  189. Private Sub ShowDescInfo()
  190.     Dim res$, crlf$
  191.     crlf$ = Chr$(13) + Chr$(10)
  192.     If UBound(verbuf) < 2 Then
  193.         MsgBox "No version information available for this file"
  194.         Exit Sub
  195.     End If
  196.     res$ = "Company: " + GetInfoString$("CompanyName") + crlf$
  197.     res$ = res$ + "File Desc: " + GetInfoString$("FileDescription") + crlf$
  198.     res$ = res$ + "Copyright: " + GetInfoString$("LegalCopyright") + crlf$
  199.     res$ = res$ + "FileVersion: " + GetInfoString$("FileVersion") + crlf$
  200.     MsgBox res$, 0, "Fixed Version Info"
  201. End Sub
  202. '   Lists all devices in the WIN.INI file
  203. Private Sub ShowDevices()
  204.     Dim devstring As String * 4096
  205.     Dim startpos%, endpos%
  206.     Dim crlf$
  207.     Dim res$
  208.     Dim di&
  209.     crlf$ = Chr$(13) + Chr$(10)
  210.     di = GetProfileString("devices", 0&, "", devstring, 4095)
  211.     If di = 0 Then
  212.         MsgBox "Win.ini does not contain devices field under this OS"
  213.         Exit Sub
  214.     End If
  215.     startpos% = 1
  216.     Do While (Asc(Mid$(devstring, startpos%, 1)) <> 0)
  217.         endpos% = InStr(startpos%, devstring, Chr$(0))
  218.         res$ = res$ + Mid$(devstring, startpos%, endpos% - startpos%) + crlf$
  219.         startpos% = endpos% + 1
  220.     Loop
  221.     MsgBox res$, 0, "Devices"
  222. End Sub
  223. ' Show information from the fixed version info for the
  224. '   current file.
  225. Private Sub ShowVersionInfo()
  226.     Dim ffi As VS_FIXEDFILEINFO
  227.     Dim fiiaddr&
  228.     #If Win32 Then
  229.         Dim fiilen&
  230.         Dim di&
  231.     #Else
  232.         Dim fiilen%
  233.         Dim di%
  234.     #End If
  235.     Dim res$, crlf$
  236.     crlf$ = Chr$(13) + Chr$(10)
  237.     If UBound(verbuf) <= 1 Then
  238.         MsgBox "No version information available for this file"
  239.         Exit Sub
  240.     End If
  241.     di = VerQueryValue(verbuf(0), "\", fiiaddr&, fiilen)
  242.     If di = 0 Then
  243.         MsgBox "No fixed version information in this file"
  244.         Exit Sub
  245.     End If
  246.     ' Copy the fixed file info into the structure
  247.     agCopyData ByVal fiiaddr&, ffi, 52
  248.     ' Now build the output report
  249.     res$ = "File Version " + CalcVersion$(ffi.dwFileVersionMS) + "." + CalcVersion$(ffi.dwFileVersionLS) + crlf$
  250.     res$ = res$ + "Product Version " + CalcVersion$(ffi.dwProductVersionMS) + crlf$
  251.     res$ = res$ + "File type is: "
  252.     Select Case ffi.dwFileType
  253.         Case VFT_UNKNOWN
  254.                     res$ = res$ + "unknown"
  255.         Case VFT_APP
  256.                     res$ = res$ + "application"
  257.         Case VFT_DLL
  258.                     res$ = res$ + "dynamic link library"
  259.         Case VFT_DRV
  260.                     res$ = res$ + "device driver"
  261.         Case VFT_FONT
  262.                     res$ = res$ + "Font resource"
  263.         Case VFT_VXD
  264.                     res$ = res$ + "virtual device"
  265.         Case VFT_STATIC_LIB
  266.                     res$ = res$ + "static link library"
  267.     End Select
  268.     res$ = res$ + crlf$
  269.     MsgBox res$, 0, "Fixed Version Info"
  270. End Sub
  271. Private Sub ShowPrinters()
  272. #If Win32 Then
  273.     Dim ft As FILETIME
  274.     Dim keyhandle&
  275.     Dim res&
  276.     Dim curidx&
  277.     Dim keyname$, classname$
  278.     Dim keylen&, classlen&
  279.     Dim msg$
  280.     Dim reserved&
  281.     res& = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Print\Printers", 0, KEY_READ, keyhandle)
  282.     If res <> ERROR_SUCCESS Then
  283.         MsgBox "Can't open key"
  284.         Exit Sub
  285.     End If
  286.     Do
  287.         keylen& = 2000
  288.         classlen& = 2000
  289.         keyname$ = String$(keylen, 0)
  290.         classname$ = String$(classlen, 0)
  291.         res = RegEnumKeyEx(keyhandle, curidx, keyname$, keylen, reserved, classname$, classlen, ft)
  292.         curidx = curidx + 1
  293.         If res = ERROR_SUCCESS Then msg$ = msg$ & Left$(keyname$, keylen) + vbCrLf
  294.     Loop While res = ERROR_SUCCESS
  295.     Call RegCloseKey(keyhandle)
  296.     MsgBox msg$, 0, "Printers"
  297. #Else
  298.     MsgBox "This function is not supported under Win16 in this example."
  299. #End If
  300. End Sub
  301.