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