Info-ZIP Unzip DLL (Renamed vbuzip10.dll) (63K)
VBPZip Source Code (152K)
VBPZip VB5 Executable (69K)
VBPZip VB6 Executable (62K)
Bugs: 1 / 1
Issues: 0 / 0
Questions: 0 / 0
3 Mar 2003
Previous version failed on Windows 2000 because the version check in the NoStatusBar component was incorrect. Now fixed.
Zipping files using the free Info-Zip Zip DLL (now with encryption support)
Subclassing Without The Crashes
Introduction to the freeware Info-ZIP libraries
vbAccelerator - Contents of code file: fAbout.frm
VERSION 5.00
Begin VB.Form frmAbout
BackColor = &H00FFFFFF&
BorderStyle = 3 'Fixed Dialog
Caption = "vbAccelerator VBPzip"
ClientHeight = 4800
ClientLeft = 5895
ClientTop = 3450
ClientWidth = 5535
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form2"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3313.045
ScaleMode = 0 'User
ScaleWidth = 5197.65
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.TextBox Text1
BackColor = &H00FFFFFF&
Height = 1515
Left = 1080
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 13
Text = "fAbout.frx":0000
Top = 2220
Width = 3855
End
Begin VB.CommandButton cmdOK
Cancel = -1 'True
Caption = "OK"
Default = -1 'True
Height = 345
Left = 4140
TabIndex = 1
Top = 4320
Width = 1260
End
Begin VB.TextBox txtSpecialCopyright
Height = 675
Left = 1140
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 0
Text = "fAbout.frx":0114
Top = 5640
Width = 4455
End
Begin VB.Label lblDotLine
BackStyle = 0 'Transparent
Caption = "................."
BeginProperty Font
Name = "Times New Roman"
Size = 24
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 0
Left = 60
TabIndex = 4
Top = 720
Width = 2115
End
Begin VB.Shape shpRect
BorderColor = &H00C0C000&
BorderWidth = 16
Height = 855
Index = 1
Left = 180
Top = 240
Width = 855
End
Begin VB.Label lblInfoZIP
BackStyle = 0 'Transparent
Caption = "Info-Zip"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 1680
MouseIcon = "fAbout.frx":01DC
MousePointer = 99 'Custom
TabIndex = 14
Tag = "http://www.cdrom.com/pub/infozip/"
ToolTipText = "http://www.cdrom.com/pub/infozip/"
Top = 4080
Width = 975
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "vbAccelerator"
BeginProperty Font
Name = "Tahoma"
Size = 18
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00404000&
Height = 480
Left = 1140
TabIndex = 8
Top = 120
Width = 2865
End
Begin VB.Label lblVersion
BackStyle = 0 'Transparent
Caption = "Version: 1.00"
ForeColor = &H00000000&
Height = 225
Left = 1080
TabIndex = 12
Top = 3900
Width = 1410
End
Begin VB.Line Line1
BorderColor = &H00C0C0C0&
BorderStyle = 6 'Inside Solid
Index = 1
X1 = 1014.176
X2 = 5310.336
Y1 = 2650.436
Y2 = 2650.436
End
Begin VB.Image imgIcon
Height = 480
Left = 360
Picture = "fAbout.frx":04E6
Top = 420
Width = 480
End
Begin VB.Shape shpRect
BorderColor = &H000080FF&
BorderWidth = 8
Height = 720
Index = 0
Left = 4500
Top = 360
Width = 675
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "VBPzip"
BeginProperty Font
Name = "Tahoma"
Size = 27.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Index = 1
Left = 1500
TabIndex = 9
Top = 480
Width = 2835
End
Begin VB.Label lblInfo
BackStyle = 0 'Transparent
Caption = "Zip VB projects and groups in one easy step"
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00404040&
Height = 495
Index = 2
Left = 2100
TabIndex = 7
Top = 1080
Width = 2835
End
Begin VB.Label lblCopyright
BackStyle = 0 'Transparent
Caption = "Copyright 2000 Steve McMahon "
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 1080
MouseIcon = "fAbout.frx":1758
MousePointer = 99 'Custom
TabIndex = 6
Tag = "/j_index_url_cright.htm.html"
Top = 4320
Width = 3990
End
Begin VB.Label lblURL
BackStyle = 0 'Transparent
Caption = "/index.html"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 1080
MouseIcon = "fAbout.frx":1A62
MousePointer = 99 'Custom
TabIndex = 5
Tag = "/index.html"
ToolTipText = "/index.html"
Top = 4500
Width = 3870
End
Begin VB.Label lblDotLine
BackStyle = 0 'Transparent
Caption = "................."
BeginProperty Font
Name = "Times New Roman"
Size = 24
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Index = 1
Left = 3600
TabIndex = 3
Top = 60
Width = 2235
End
Begin VB.Label lblProduct
BackStyle = 0 'Transparent
Caption = "VBPZip"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 195
Left = 1080
MouseIcon = "fAbout.frx":1D6C
MousePointer = 99 'Custom
TabIndex = 2
Tag =
"/j_index_url_codelibzipvbpzip.htm.html"
Top = 4080
Width = 975
End
Begin VB.Label lblInfo
BackColor = &H0080C0FF&
Height = 225
Index = 4
Left = 1080
TabIndex = 11
Top = 540
Width = 3885
End
Begin VB.Label lblDescription
BackColor = &H00C0E0FF&
ForeColor = &H00000000&
Height = 870
Index = 3
Left = 1080
TabIndex = 10
Top = 780
Width = 3885
End
Begin VB.Shape shpRect
BorderStyle = 0 'Transparent
FillColor = &H00C0E0FF&
FillStyle = 0 'Solid
Height = 615
Index = 2
Left = 4860
Top = 180
Width = 555
End
End
Attribute VB_Name = "frmAbout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Reg Key Security Options...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Reg Key ROOT Types...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_DWORD = 4 ' 32-bit number
Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA"
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal
samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal
lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef
lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Sub cmdSysInfo_Click()
Call StartSysInfo
End Sub
Private Sub cmdOK_Click()
Unload Me
End Sub
Private Sub Form_Load()
Me.Caption = "About " & App.Title
Me.Icon = frmVBPzip.Icon
lblVersion.Caption = "Version: " & App.major & "." & Format$(App.minor,
"00") & "." & Format$(App.Revision, "0000")
End Sub
Public Sub StartSysInfo()
On Error GoTo SysInfoErr
Dim rc As Long
Dim SysInfoPath As String
' Try To Get System Info Program Path\Name From Registry...
If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO,
SysInfoPath) Then
' Try To Get System Info Program Path Only From Registry...
ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC,
gREGVALSYSINFOLOC, SysInfoPath) Then
' Validate Existance Of Known 32 Bit File Version
If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
' Error - File Can Not Be Found...
Else
GoTo SysInfoErr
End If
' Error - Registry Entry Can Not Be Found...
Else
GoTo SysInfoErr
End If
Call Shell(SysInfoPath, vbNormalFocus)
Exit Sub
SysInfoErr:
MsgBox "System Information Is Unavailable At This Time", vbOKOnly
End Sub
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As
String, ByRef KeyVal As String) As Boolean
Dim i As Long ' Loop Counter
Dim rc As Long ' Return Code
Dim hKey As Long ' Handle To An Open
Registry Key
Dim hDepth As Long '
Dim KeyValType As Long ' Data Type Of A
Registry Key
Dim tmpVal As String ' Tempory Storage
For A Registry Key Value
Dim KeyValSize As Long ' Size Of Registry
Key Variable
'------------------------------------------------------------
' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open
Registry Key
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
tmpVal = String$(1024, 0) ' Allocate Variable
Space
KeyValSize = 1024 ' Mark Variable Size
'------------------------------------------------------------
' Retrieve Registry Key Value...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
KeyValType, tmpVal, KeyValSize) ' Get/Create Key
Value
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null
Terminated String...
tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found,
Extract From String
Else ' WinNT Does NOT
Null Terminate String...
tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found,
Extract String Only
End If
'------------------------------------------------------------
' Determine Key Value Type For Conversion...
'------------------------------------------------------------
Select Case KeyValType ' Search Data
Types...
Case REG_SZ ' String Registry
Key Data Type
KeyVal = tmpVal ' Copy String Value
Case REG_DWORD ' Double Word
Registry Key Data Type
For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit
KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char.
By Char.
Next
KeyVal = Format$("&h" + KeyVal) ' Convert Double
Word To String
End Select
GetKeyValue = True ' Return Success
rc = RegCloseKey(hKey) ' Close Registry Key
Exit Function ' Exit
GetKeyError: ' Cleanup After An Error Has Occured...
KeyVal = "" ' Set Return Val To
Empty String
GetKeyValue = False ' Return Failure
rc = RegCloseKey(hKey) ' Close Registry Key
End Function
Private Sub imgVBAccelerator_Click()
pShell "/index.html"
End Sub
Private Sub pShell(ByVal sWhat As String)
On Error Resume Next
ShellEx sWhat, , , , , Me.hwnd
If (Err.Number <> 0) Then
MsgBox "Sorry, I failed to open '" & sWhat & "' due to an error." &
vbCrLf & vbCrLf & "[" & Err.Description & "]", vbExclamation
End If
End Sub
Private Sub lblCopyright_Click()
pShell lblCopyright.Tag
End Sub
Private Sub lblInfoZIP_Click()
pShell lblInfoZIP.Tag
End Sub
Private Sub lblProduct_Click()
pShell lblProduct.Tag
End Sub
Private Sub lblURL_Click()
pShell lblURL.Tag
End Sub