' ******************************************************' UNLHA32' ******************************************************
Type INDIVIDUALINFO
dwOriginalSize As Long
dwCompressedSize As Long
dwCRC As Long
uFlag As Integer
uOSType As Integer
wDate0 As Integer
wTime0 As Integer
wRatio As Integer
wDate As Integer
wTime As Integer
szFileName As String * 513
dummy1 As String * 3
szAttribute As String * 8
szMode As String * 8
dummy2 As String * 512
End Type
Declare Function UnlhaGetVersion Lib "unlha32.dll" () As Integer
Declare Function UnlhaOpenArchive Lib "unlha32.dll" ( _
ByVal hWnd As Long, _
ByVal szFileName As String, _
ByVal dwMode As Long _
) As Long
Declare Function UnlhaCloseArchive Lib "unlha32.dll" ( _
ByVal harc As Long _
) As Integer
Declare Function UnlhaFindFirst Lib "unlha32.dll" ( _
ByVal harc As Long, _
ByVal szWildName As String, _
lpSubInfo As INDIVIDUALINFO _
) As Integer
Declare Function UnlhaFindNext Lib "unlha32.dll" ( _
ByVal harc As Long, _
lpSubInfo As INDIVIDUALINFO _
) As Integer
Declare Function Unlha Lib "unlha32.dll" ( _
ByVal hWnd As Long, _
ByVal szCmdLine As String, _
ByVal szOutput As String, _
ByVal dwSize As Long _
) As Integer
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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
Declare Function FileTimeToSystemTime Lib "kernel32" ( _
lpFileTime As FILETIME, _
lpSystemTime As SYSTEMTIME _
) As Long
Declare Function DosDateTimeToFileTime Lib "kernel32" ( _
ByVal wFatDate As Long, _
ByVal wFatTime As Long, _
lpFileTime As FILETIME _
) As Long
Global harc As Variant
' ******************************************************' アーカイブを開く' ******************************************************
Public Function OpenUnlha(hWnd As Long, strPath As String)
Dim ret As Long
If TypeName(harc) <> "Empty" Then
Call UnlhaCloseArchive(harc)
harc = Empty
End If
ret = UnlhaOpenArchive(hWnd, strPath, 2)
harc = ret
End Function
' ******************************************************' アーカイブを閉じる' ******************************************************
Public Function CloseUnlha()
If TypeName(harc) <> "Empty" Then
Call UnlhaCloseArchive(harc)
harc = Empty
End If
End Function
' ******************************************************' アーカイブを読む' ******************************************************
Public Function FindUnlha(strTarget, ByRef UnlhaData As INDIVIDUALINFO) As Long
If strTarget <> "" Then
FindUnlha = UnlhaFindFirst(harc, strTarget, UnlhaData)
Else
FindUnlha = UnlhaFindNext(harc, UnlhaData)
End If
End Function
' ******************************************************' バイナリの日付を文字列に変換' ******************************************************
Public Function GetDosDateTime(wDate As Integer, wTime As Integer) As String
Dim lpFileTime As FILETIME
Dim lpSystemTime As SYSTEMTIME
Call DosDateTimeToFileTime(wDate, wTime, lpFileTime)
Call FileTimeToSystemTime(lpFileTime, lpSystemTime)
GetDosDateTime = _
Format(lpSystemTime.wYear, "0000") & "/" & _
Format(lpSystemTime.wMonth, "00") & "/" & _
Format(lpSystemTime.wDay, "00") & " " & _
Format(lpSystemTime.wHour, "00") & ":" & _
Format(lpSystemTime.wMinute, "00") & ":" & _
Format(lpSystemTime.wSecond, "00")
End Function
サンプル
Private Sub Command1_Click()
Dim sts As Long
Dim uData As INDIVIDUALINFO
Dim bFirst As Boolean
Call OpenUnlha(Me.hWnd, App.Path & "\" & "WinOfReg.lzh")
bFirst = True
Do
If bFirst Then
bFirst = False
sts = FindUnlha("*.*", uData)
If sts <> 0 Then
Exit Do
End If
Else
sts = FindUnlha("", uData)
If sts <> 0 Then
Exit Do
End If
Grid.Rows = Grid.Rows + 1
End If
With Grid
.TextMatrix(.Rows - 1, 0) = .Rows - 1
.TextMatrix(.Rows - 1, 1) = uData.szFileName
.TextMatrix(.Rows - 1, 2) = GetDosDateTime(uData.wDate, uData.wTime)
.TextMatrix(.Rows - 1, 3) = Format(uData.dwOriginalSize, "#,##0")
.TextMatrix(.Rows - 1, 4) = Format(uData.dwCompressedSize, "#,##0")
If uData.dwOriginalSize = 0 Then
.TextMatrix(.Rows - 1, 5) = 0
Else
.TextMatrix(.Rows - 1, 5) = _
Format((uData.dwCompressedSize / uData.dwOriginalSize) * 100, "#0")
End If
.TextMatrix(.Rows - 1, 6) = uData.szAttribute
.TextMatrix(.Rows - 1, 7) = uData.szMode
End With
Loop
Call CloseUnlha
End Sub
Private Sub Form_Load()
With Grid
.ColWidth(0) = 400
.ColWidth(1) = 3000
.ColWidth(2) = 1700
.ColWidth(5) = 500
.ColWidth(6) = 600
.ColWidth(7) = 600
End With
End Sub