[SIZE=4]นี่คือข้อตกลงหากจะนำโค้ดนี้ไปใช้ : ผมเข้าใจว่าเป็นข้อมูลเกี่ยวกับผู้ป่วยในสถานพยาบาล คุณต้องทดสอบการทำงานของโค้ดนี้จนแน่ใจเสียก่อนด้วยตัวคุณเอง ถ้าโปรแกรมทำงานผิดพลาดและผลลัพธ์ที่ผิดพลาดนี้มีผลต่อชีวิตคนไข้ไม่ว่าด้านใดก็ตาม ผมไม่รับผิดชอบใดๆทั้งนั้นนะครับ ทั้งหมดต้องเป็นความรับผิดชอบของคุณเองทั้งสิ้น[/FONT]

- ในโค้ดนี้ ฟิลดที่ชื่อ Level ผมขอเปลี่ยนเป็น nLevel เพราะชื่อนี้เป็นคำสงวนอะไีรสักอย่าง มันจะทำงานไม่ได้ครับ

- เวลาเรียกใช้ คุณก็เอาโค้ดในส่วนของ GenTable2 ไปแปะลงส่วนใดของโปรแกรม หรือในส่วนนั้นอาจเรียกใช้ GenTable2 ก็ได้ครับ

Public Sub GenTable2()
    Dim SQL As String
    
    SQL = "insert into table2(HN, nLevel, CountNoLab, Ctrl) " _
        & "select HN, CombineLevel(HN) as nLevel, Count(*) as CountNoLab, DupLevel(HN) as Ctrl " _
        & "from Table1 where เงื่อนไข(ถ้ามี) group by HN order by HN"
    CurrentDb.Execute SQL, dbFailOnError
End Sub

Public Function CombineLevel(HN As String) As String
    Dim SQL As String
    Dim RS As DAO.Recordset
    Dim DB As DAO.Database
    
    Set DB = CurrentDb
    SQL = "select nLevel from table1 where HN = '" & HN & "' order by NoLab"
    Set RS = DB.OpenRecordset(SQL)
    Do Until RS.EOF
        CombineLevel = CombineLevel & RS!nlevel
        RS.MoveNext
    Loop
    RS.Close: Set RS = Nothing
End Function

Public Function DupLevel(HN As String) As String
    Dim SQL As String
    Dim RS As DAO.Recordset
    Dim DB As DAO.Database
    Dim C(9) As Integer
    Dim I   As Integer
    
    Set DB = CurrentDb
    SQL = "select nLevel from table1 where HN = '" & HN & "' order by NoLab"
    Set RS = DB.OpenRecordset(SQL)
    Do Until RS.EOF
        C(RS!nlevel) = C(RS!nlevel) + 1
        RS.MoveNext
    Loop
    RS.Close: Set RS = Nothing
    
    For I = 0 To 9
        If C(I) >= 2 Then
            DupLevel = DupLevel & CStr(I)
        End If
    Next
    If DupLevel = "" Then DupLevel = "0"
End Function

เรียน อาจารย์สันติสุข กราบขอบพระคุณมากครับที่ให้ความอนุเคราะห์และให้ข้อเสนอแนะ...ข้อมูลนี้เป็นการ รวบรวมรายงาน ผู้ป่วยที่มารับบริการ ในสถานพยาบาล ในผู้ป่วยเบาหวาน ในรอบ สามเดือน ต้องมีการตรวจ ระดับน้ำตาลในเลือด อย่างน้อย สามครั้ง หากมีระดับน้ำตาล ในเกณฑ์ที่กำหนด มากกว่า สองครั้งขึ้นไป ถือว่าควบคุมน้ำตาลในเลือดได้ จากตัวอย่าง ทำให้เราทราบว่า
1. ในรอบสามเดือน มีผู้ป่วยมารับริการ กี่ครั้ง
2. ในการตรวจเลือดแต่ละครั้งอยู่ในเกณฑ์ ที่กำหนดหรือไม่ ( สองครั้งขึ้นไป ถือว่าควบคุมน้ำตาลในเลือดได้)
3. ในรอบสามเดือนทำให้ทราบว่ามีผู้ป่วยที่ควบคุมน้ำตาลได้ กี่คน คุมไม่ได้กี่คน และไม่ได้ตรวจ ตามเกณฑ์ (อย่างน้อย สามครั้ง ตรวจตาลในเลือด ในรอบสามเดือน) อีกกี่คน......

จากข้อมูลตัวอย่าง (Table1) เป็นข้อมูลที่ได้จากโปรแกรมในสถานพยาบาล ในรูปแบบ excel ซึ่งในอดีต เจ้าหน้าที่ผู้รับผิดชอบงาน จะมานั่ง tally (แจงนับ) เพื่อให้ได้ข้อมูล ดังกล่าวข้างตนมาวิเคราะห์ เพื่อติดตามการรักษาพยาบาลและให้การดูแลผู้ป่วย ให้มีสุขภาพที่ดี มีการรักษาที่เหมาะสม...ซึ่งเป็นการลดระยะเวลาในการทำงานของเจ้าหน้าที่ เพื่อเอาเวลาที่เสียไปกับการนั่ง แจงนับ มาให้บริการผู้ป่วย...ซึ่งก่อให้เกิดประโยชน์มากกว่าผลลบ...กราบขอบพระคุณอีกครั้งครับ หากผมได้นำ Code นี้ไปทดลองใช้แล้วได้ผลประการใดจะมาแจ้งให้ทราบครับ....ขอบพระคุณมากครับ..

ในโค้ดนี้ ถ้าเลขของฟิลด์ Level ใน Table2 มีค่าเป็น 13344   ค่าของฟิลด์ Ctrl จะเก็บ 34 นะครับ ... ว่าแล้วค่าน้ำตาลที่ไปตรวจมาหลังสุดก็ 111 ซะแล้ว

ถ้าค่าน้ำตาล อยู่ ในระดับ 111 แสดงว่า ควบคุมน้ำตาลได้ดีมาก + กับควบคุมการรับประทานอาหารได้อย่างมีประสิทะิภาพ....ถ้าค่าน้ำตาลอยู่ที่ตัวเลขไม่ซ้ำกันเลย แสดงว่า วินัยในการรับประทานอาหารไม่ค่อยดีในผู้ป่วยเบาหวาน (ตามใจปาก) ค่าน้ำตาลในกระแสเลือดจะขึ้นๆลงๆ ครับ

ผมได้ทดลองใช้แล้วครับ....ก็บรรลุวัตถุประสงค์ทุกประการครับ....(Code ไม่มี Error เลยครับ) ก็มี Error บ้างแต่เป้นความผิดที่ผมเอง เรื่องการกำหนดคุณสมบัติของ Field    ซึ่ง Code นี้ คงนำไปประยุกต์ใช้ กับงานอื่นๆได้อีกหลายงานเลยครับ อาทิ งาน ผู้ป่วยความดันโลหิตสูง (ซึ่งมีความถี่ในการรับบริการมากกว่า ผู้ป่วยเบาหวาน) การให้วัคซีนในเด็ก ซึ่งมีหลาหหลายชนิด , การควบคุมกำกับการกินยาของผู้ป่วยวัณโรค ก้คงเป็นประโยชน์กับ เจ้าหน้าที่สาธารณสุข และ ผู้ป่วย ที่มารับบริการได้รับบริการอย่างครบถ้วนสมบูรณ์ เนื่องจากมีการใช้ โปรแกรมในการประมวลผล (ไม่แน่ใจเขาเรียกโปรแกรมหรือเปล่า) มาช่วยให้มีประสิทธิภาพมากขึ้น....โปรแกรมที่ใช้ในโรงพยาบาลส่วนมากเป้นการเก็บบันทึกข้อมูลมากกว่าการนำข้อมูลไปใช้ (ก็มีบ้าง ที่ทาง Vender เขียนระบบรายงานให้ แต่ก็ไม่ทุกอย่างตามที่เราต้องการ) ผมพยายามอ่านที่ละกระทู้ อ่านไปเรื่อย กระทู้ไหนน่าสนใจก็ศึกษาเอาครับ (เป้นการศึกษาด้วยตนเองครับ) กราบขอบพระคุณอาจารย์สันติสุข อีกครั้งครับ......

ผมไปเจอ Code การเรียกใช้ Zip File ของ Windows น่าจะเป็นการเรียกใช้ แบบ API แต่ก็ไม่รู้ว่าใช้อย่่างไรครับ....ลองศึกษาดุแล้วน่าจะเกินความสามารถ.....ถ้าอาจารย์พอมีเวลา หรืออาจารย์อาจจะทราบแล้ว ก็จะเป็นประโยชน์กับบุคคลอื่นๆอีกหลายคนที่ มีปัญหาการใช้ Zip File....(เคย ลองใช้ Command line ของ 7Zip แต่เหมือนกับว่า มันยังทำงาน Action ของ 7Zip ยังไม่เสร็จ Access ก็ไปทำงานอื่นต่อไป แล้วเกิด Error ขึ้น หรืออาจเป็นเพราะผมเขียน Code ไม่ถูกต้องก็เป็นได้)

๊ืUnZip....ครับ


Option Compare Database

Option Explicit
'
' UnZip Class
'
' Chris Eastwood July 1999
'
Public Enum ZMessageLevel
    All = 0
    Less = 1
    NoMessages = 2
End Enum
Public Enum ZExtractType
    Extract = 0
    ListContents = 1
End Enum
Public Enum ZPrivilege
    Ignore = 0
    ACL = 1
    Privileges = 2
End Enum

Private miExtractNewer     As Integer ' 1 = Extract Only Newer, Else 0
Private miSpaceUnderScore As Integer ' 1 = Convert Space To Underscore, Else 0
Private miPromptOverwrite As Integer ' 1 = Prompt To Overwrite Required, Else 0
Private miQuiet            As ZMessageLevel ' 2 = No Messages, 1 = Less, 0 = All
Private miWriteStdOut      As Integer ' 1 = Write To Stdout, Else 0
Private miTestZip          As Integer ' 1 = Test Zip File, Else 0
Private miExtractList      As ZExtractType ' 0 = Extract, 1 = List Contents
Private miExtractOnlyNewer As Integer ' 1 = Extract Only Newer, Else 0
Private miDisplayComment   As Integer ' 1 = Display Zip File Comment, Else 0
Private miHonorDirectories As Integer ' 1 = Honor Directories, Else 0
Private miOverWriteFiles   As Integer ' 1 = Overwrite Files, Else 0
Private miConvertCR_CRLF   As Integer ' 1 = Convert CR To CRLF, Else 0
Private miVerbose          As Integer ' 1 = Zip Info Verbose
Private miCaseSensitivity As Integer ' 1 = Case Insensitivity, 0 = Case Sensitivity
Private miPrivilege        As ZPrivilege ' 1 = ACL, 2 = Privileges, Else 0
Private msZipFileName      As String   ' The Zip File Name
Private msExtractDir       As String   ' Extraction Directory, Null If Current Directory

Public Property Get ExtractNewer() As Boolean
    ExtractNewer = miExtractNewer = 1
End Property

Public Property Let ExtractNewer(ByVal bExtractNewer As Boolean)
    miExtractNewer = IIf(bExtractNewer, 1, 0)
End Property

Public Property Get SpaceToUnderScore() As Boolean
    SpaceToUnderScore = miSpaceUnderScore = 1
End Property

Public Property Let SpaceToUnderScore(ByVal bConvert As Boolean)
    miSpaceUnderScore = IIf(bConvert, 1, 0)
End Property

Public Property Get PromptOverwrite() As Boolean
    PromptOverwrite = miPromptOverwrite = 1
End Property

Public Property Let PromptOverwrite(ByVal bPrompt As Boolean)
    miPromptOverwrite = IIf(bPrompt, 1, 0)
End Property

Public Property Get MessageLevel() As ZMessageLevel
    MessageLevel = miQuiet
End Property

Public Property Let MessageLevel(ByVal iLevel As ZMessageLevel)
    miQuiet = iLevel
End Property

Public Property Get WriteToStdOut() As Boolean
    WriteToStdOut = miWriteStdOut = 1
End Property

Public Property Let WriteToStdOut(ByVal bWrite As Boolean)
    miWriteStdOut = IIf(bWrite, 1, 0)
End Property

Public Property Get TestZip() As Boolean
    TestZip = miTestZip = 1
End Property

Public Property Let TestZip(ByVal bTest As Boolean)
    miTestZip = IIf(bTest, 1, 0)
End Property

Public Property Get ExtractList() As ZExtractType
    ExtractList = miExtractList
End Property

Public Property Let ExtractList(ByVal zExType As ZExtractType)
    miExtractList = zExType
End Property

Public Property Get ExtractOnlyNewer() As Boolean
    ExtractOnlyNewer = miExtractOnlyNewer = 1
End Property

Public Property Let ExtractOnlyNewer(ByVal bOnlyNewer As Boolean)
    miExtractOnlyNewer = IIf(bOnlyNewer, 1, 0)
End Property

Public Property Get DisplayComment() As Boolean
    DisplayComment = miDisplayComment = 1
End Property

Public Property Let DisplayComment(ByVal bDisplay As Boolean)
    miDisplayComment = IIf(bDisplay, 1, 0)
End Property

Public Property Get HonorDirectories() As Boolean
    HonorDirectories = miHonorDirectories = 1
End Property

Public Property Let HonorDirectories(ByVal bHonor As Boolean)
    miHonorDirectories = IIf(bHonor, 1, 0)
End Property

Public Property Get OverWriteFiles() As Boolean
    OverWriteFiles = miOverWriteFiles = 1
End Property

Public Property Let OverWriteFiles(ByVal bOverWrite As Boolean)
    miOverWriteFiles = IIf(bOverWrite, 1, 0)
End Property

Public Property Get ConvertCRtoCRLF() As Boolean
    ConvertCRtoCRLF = miConvertCR_CRLF = 1
End Property

Public Property Let ConvertCRtoCRLF(ByVal bConvert As Boolean)
    miConvertCR_CRLF = IIf(bConvert, 1, 0)
End Property

Public Property Get Verbose() As Boolean
    Verbose = miVerbose = 1
End Property

Public Property Let Verbose(ByVal bVerbose As Boolean)
    miVerbose = IIf(bVerbose, 1, 0)
End Property

Public Property Get CaseSensitive() As Boolean
    CaseSensitive = miCaseSensitivity = 1
End Property

Public Property Let CaseSensitive(ByVal bCaseSensitive As Boolean)
    miCaseSensitivity = IIf(bCaseSensitive, 1, 0)
End Property

Public Property Get Privilege() As ZPrivilege
    Privilege = miPrivilege
End Property

Public Property Let Privilege(ByVal zPriv As ZPrivilege)
    miPrivilege = zPriv
End Property

Public Property Get ZipFileName() As String
    ZipFileName = msZipFileName
End Property

Public Property Let ZipFileName(ByVal sZipFileName As String)
    msZipFileName = sZipFileName
End Property

Public Property Get ExtractDir() As String
    ExtractDir = msExtractDir
End Property

Public Property Let ExtractDir(ByVal sExtractDir As String)
    msExtractDir = sExtractDir
End Property

Public Function UnZip(Optional sZipFileName As String, _
    Optional sExtractDir As String) As Long
    
On Error GoTo vbErrorHandler

    Dim lRet As Long
    
    If Len(sZipFileName) > 0 Then
        msZipFileName = sZipFileName
    End If
    
    If Len(sExtractDir) > 0 Then
        msExtractDir = sExtractDir
    End If
    
    
    lRet = VBUnzip(msZipFileName, msExtractDir, miExtractNewer, _
        miSpaceUnderScore, miPromptOverwrite, CInt(miQuiet), _
        miWriteStdOut, miTestZip, CInt(miExtractList), _
        miExtractOnlyNewer, miDisplayComment, miHonorDirectories, _
        miOverWriteFiles, miConvertCR_CRLF, miVerbose, _
        miCaseSensitivity, CInt(miPrivilege))
    
    UnZip = lRet
    
    Exit Function

vbErrorHandler:
    Err.Raise Err.Number, "CGUnZipFiles::Unzip", Err.Description

End Function

Private Sub Class_Initialize()
    miExtractNewer = 0
    miSpaceUnderScore = 0
    miPromptOverwrite = 0
    miQuiet = NoMessages
    miWriteStdOut = 0
    miTestZip = 0
    miExtractList = Extract
    miExtractOnlyNewer = 0
    miDisplayComment = 0
    miHonorDirectories = 1
    miOverWriteFiles = 1
    miConvertCR_CRLF = 0
    miVerbose = 0
    miCaseSensitivity = 1
    miPrivilege = Ignore
End Sub

Public Function GetLastMessage() As String
    GetLastMessage = msOutput
End Function


-------------------------------


Zip File.....

Option Compare Database

Option Explicit
'
'
' Chris Eastwood July 1999 - adapted from code at the
' InfoZip homepage.
'
Public Enum ZTranslate
    CRLFtoLF = 1
    LFtoCRLF = 2
End Enum
'
' Collection of Files to Zip
'
Private mCollection As Collection
'
' Recurse Folders ?
'
Private miRecurseFolders As Integer
'
' Zip File Name
'
Private msZipFileName As String
'
' Encryption ?
'
Private miEncrypt As Integer
'
' System Files
'
Private miSystem As Integer
'
' Root Directory
'
Private msRootDirectory As String
'
' Verbose Zip
'
Private miVerbose As Integer
'
' Quiet Zip
'
Private miQuiet As Integer
'
' Translate CRLF / LF Chars
'
Private miTranslateCRLF As ZTranslate
'
' Updating Existing Zip ?
'
Private miUpdateZip As Integer

Public m_bolNoPathNames As Boolean
' if above set = true then path names are not included a part of the zip




Private Sub Class_Initialize()
'
' Initialise the collection
'
    Set mCollection = New Collection
'
' We have to add in a dummy file into the collection because
' the Zip routines fall over otherwise.
'
' I think this is a bug, but it's not documented anywhere
' on the InfoZip website.
'
' The Zip process *always* fails on the first file,
' regardless of whether it's a valid file or not!
'
    mCollection.Add "querty", "querty"
    miEncrypt = 0
    miSystem = 0
    msRootDirectory = "\"
    miQuiet = 0
    miUpdateZip = 0
    m_bolNoPathNames = True
    
End Sub

Private Sub Class_Terminate()
'
' Terminate the collection
'
    Set mCollection = Nothing
End Sub

Public Property Get RecurseFolders() As Boolean
    RecurseFolders = miRecurseFolders = 1
End Property

Public Property Let RecurseFolders(ByVal bRecurse As Boolean)
    miRecurseFolders = IIf(bRecurse, 1, 0)
End Property

Public Property Get ZipFileName() As String
    ZipFileName = msZipFileName
End Property

Public Property Let ZipFileName(ByVal sZipFileName As String)
    msZipFileName = sZipFileName '& vbNullChar
End Property

Public Property Get Encrypted() As Boolean
    Encrypted = miEncrypt = 1
End Property

Public Property Let Encrypted(ByVal bEncrypt As Boolean)
    miEncrypt = IIf(bEncrypt, 1, 0)
End Property

Public Property Get IncludeSystemFiles() As Boolean
    IncludeSystemFiles = miSystem = 1
End Property

Public Property Let IncludeSystemFiles(ByVal bInclude As Boolean)
    miSystem = IIf(bInclude, 1, 0)
End Property

Public Property Get ZipFileCount() As Long
    If mCollection Is Nothing Then
        ZipFileCount = 0
    Else
        ZipFileCount = mCollection.Count - 1
    End If
End Property


Public Property Get RootDirectory() As String
    RootDirectory = msRootDirectory
End Property

Public Property Let RootDirectory(ByVal sRootDir As String)
    msRootDirectory = sRootDir ' & vbNullChar
End Property

Public Property Get UpdatingZip() As Boolean
    UpdatingZip = miUpdateZip = 1
End Property

Public Property Let UpdatingZip(ByVal bUpdating As Boolean)
    miUpdateZip = IIf(bUpdating, 1, 0)
End Property

Public Function AddFile(ByVal sFileName As String)
    Dim lCount As Long
    Dim sFile As String
    
    On Error Resume Next
    
    sFile = mCollection.Item(sFileName)
    
    If Len(sFile) = 0 Then
        Err.Clear
        On Error GoTo 0
        mCollection.Add sFileName, sFileName
    Else
        On Error GoTo 0
        Err.Raise vbObjectError + 2001, "CGZip::AddFile", "File is already in Zip List"
    End If
    
End Function

Public Function RemoveFile(ByVal sFileName As String)
    Dim lCount As Long
    Dim sFile As String
    
    On Error Resume Next
    
    sFile = mCollection.Item(sFileName)
    
    If Len(sFile) = 0 Then
        Err.Raise vbObjectError + 2002, "CGZip::RemoveFile", "File is not in Zip List"
    Else
        mCollection.Remove sFileName
    End If
    
End Function

Public Function MakeZipFile() As Long
    Dim zFileArray As ZIPnames
    Dim sFileName As Variant
    Dim lFileCount As Long
    Dim iIgnorePath As Integer
    Dim iRecurse As Integer

On Error GoTo vbErrorHandler
    
    lFileCount = 0
    
    For Each sFileName In mCollection
        zFileArray.s(lFileCount) = sFileName
        lFileCount = lFileCount + 1
    Next

       
    MakeZipFile = VBZip(CInt(lFileCount), msZipFileName, _
        zFileArray, CLng(m_bolNoPathNames), _
        miRecurseFolders, miUpdateZip, _
        0, msRootDirectory)
    

    Exit Function

vbErrorHandler:
    MakeZipFile = -99
    Err.Raise Err.Number, "CGZipFiles::MakeZipFile", Err.Description

End Function

Public Function GetLastMessage() As String
    GetLastMessage = msOutput
End Function


-------------------------------------
อันนี้ไม่รู้อะไร ครับ คงเป็น เกี่ยวกับ Zip File


Option Compare Database
Option Explicit

'-- C Style argv
Public Type UNZIPnames
uzFiles(0 To 99) As String
End Type

'-- Callback Large "String"
Public Type UNZIPCBChar
ch(32800) As Byte
End Type

'-- Callback Small "String"
Public Type UNZIPCBCh
ch(256) As Byte
End Type

'-- UNZIP32.DLL DCL Structure
Public Type DCLIST
ExtractOnlyNewer As Long    ' 1 = Extract Only Newer, Else 0
SpaceToUnderScore As Long    ' 1 = Convert Space To Underscore, Else 0
PromptToOverwrite As Long    ' 1 = Prompt To Overwrite Required, Else 0
fQuiet            As Long    ' 2 = No Messages, 1 = Less, 0 = All
ncflag            As Long    ' 1 = Write To Stdout, Else 0
ntflag            As Long    ' 1 = Test Zip File, Else 0
nvflag            As Long    ' 0 = Extract, 1 = List Zip Contents
nUflag            As Long    ' 1 = Extract Only Newer, Else 0
nzflag            As Long    ' 1 = Display Zip File Comment, Else 0
ndflag            As Long    ' 1 = Honor Directories, Else 0
noflag            As Long    ' 1 = Overwrite Files, Else 0
naflag            As Long    ' 1 = Convert CR To CRLF, Else 0
nZIflag           As Long    ' 1 = Zip Info Verbose, Else 0
C_flag            As Long    ' 1 = Case Insensitivity, 0 = Case Sensitivity
fPrivilege        As Long    ' 1 = ACL, 2 = Privileges
Zip               As String ' The Zip Filename To Extract Files
ExtractDir        As String ' The Extraction Directory, NULL If Extracting To Current Dir
End Type

'-- UNZIP32.DLL Userfunctions Structure
Public Type USERFUNCTION
UZDLLPrnt     As Long     ' Pointer To Apps Print Function
UZDLLSND      As Long     ' Pointer To Apps Sound Function
UZDLLREPLACE As Long     ' Pointer To Apps Replace Function
UZDLLPASSWORD As Long     ' Pointer To Apps Password Function
UZDLLMESSAGE As Long     ' Pointer To Apps Message Function
UZDLLSERVICE As Long     ' Pointer To Apps Service Function (Not Coded!)
TotalSizeComp As Long     ' Total Size Of Zip Archive
TotalSize     As Long     ' Total Size Of All Files In Archive
CompFactor    As Long     ' Compression Factor
NumMembers    As Long     ' Total Number Of All Files In The Archive
cchComment    As Integer ' Flag If Archive Has A Comment!
End Type

'-- UNZIP32.DLL Version Structure
Public Type UZPVER
structlen       As Long        ' Length Of The Structure Being Passed
flag            As Long        ' Bit 0: is_beta bit 1: uses_zlib
beta            As String * 10 ' e.g., "g BETA" or ""
Date            As String * 20 ' e.g., "4 Sep 95" (beta) or "4 September 1995"
zlib            As String * 10 ' e.g., "1.0.5" or NULL
UnZip(1 To 4)   As Byte        ' Version Type Unzip
zipinfo(1 To 4) As Byte        ' Version Type Zip Info
os2dll          As Long        ' Version Type OS2 DLL
windll(1 To 4) As Byte        ' Version Type Windows DLL
End Type

'-- This Assumes UNZIP32.DLL Is In Your \Windows\System Directory!
Private Declare Function Wiz_SingleEntryUnzip Lib "unzip32.dll" _
(ByVal ifnc As Long, ByRef ifnv As UNZIPnames, _
   ByVal xfnc As Long, ByRef xfnv As UNZIPnames, _
   dcll As DCLIST, Userf As USERFUNCTION) As Long

Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)

'argv
Public Type ZIPnames
    s(0 To 99) As String
End Type

'ZPOPT is used to set options in the zip32.dll
Private Type ZPOPT
    fSuffix As Long
    fEncrypt As Long
    fSystem As Long
    fVolume As Long
    fExtra As Long
    fNoDirEntries As Long
    fExcludeDate As Long
    fIncludeDate As Long
    fVerbose As Long
    fQuiet As Long
    fCRLF_LF As Long
    fLF_CRLF As Long
    fJunkDir As Long
    fRecurse As Long
    fGrow As Long
    fForce As Long
    fMove As Long
    fDeleteEntries As Long
    fUpdate As Long
    fFreshen As Long
    fJunkSFX As Long
    fLatestTime As Long
    fComment As Long
    fOffsets As Long
    fPrivilege As Long
    fEncryption As Long
    fRepair As Long
    flevel As Byte
    Date As String ' 8 bytes long
    szRootDir As String ' up to 256 bytes long
End Type

Private Type ZIPUSERFUNCTIONS
    DLLPrnt As Long
    DLLPASSWORD As Long
    DLLCOMMENT As Long
    DLLSERVICE As Long
End Type

'Structure ZCL - not used by VB
'Private Type ZCL
'    argc As Long            'number of files
'    filename As String      'Name of the Zip file
'    fileArray As ZIPnames   'The array of filenames
'End Type

' Call back "string" (sic)
Private Type CBChar
    ch(4096) As Byte
End Type

'Local declares

' Dim MYZCL As ZCL


'This assumes zip32.dll is in your \windows\system directory!
Private Declare Function ZpInit Lib "zip32.dll" _
(ByRef Zipfun As ZIPUSERFUNCTIONS) As Long ' Set Zip Callbacks

Private Declare Function ZpSetOptions Lib "zip32.dll" _
(ByRef Opts As ZPOPT) As Long ' Set Zip options

Private Declare Function ZpGetOptions Lib "zip32.dll" _
() As ZPOPT ' used to check encryption flag only

Private Declare Function ZpArchive Lib "zip32.dll" _
(ByVal argc As Long, ByVal funame As String, ByRef argv As ZIPnames) As Long ' Real zipping action
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private uZipNumber As Integer
Private uZipMessage As String
Private uZipInfo As String
Private uVBSkip As Integer
Public msOutput As String


' Puts a function pointer in a structure
Function FnPtr(ByVal lp As Long) As Long
    FnPtr = lp
End Function

' Callback for zip32.dll
Function DLLPrnt(ByRef Fname As CBChar, ByVal X As Long) As Long
    Dim s0$, xx As Long
    Dim sVbZipInf As String
    
    ' always put this in callback routines!
    On Error Resume Next
    s0 = ""
    For xx = 0 To X
        If Fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 + Chr(Fname.ch(xx))
    Next xx
    
    Debug.Print sVbZipInf & s0
    msOutput = msOutput & s0
    
    sVbZipInf = ""
    
    DoEvents
    DLLPrnt = 0
    
End Function

' Callback for Zip32.dll ?
Function DllServ(ByRef Fname As CBChar, ByVal X As Long) As Long
    
    Dim s0 As String
    Dim xx As Long
    
    On Error Resume Next
    
    s0 = ""
    
    For xx = 0 To X - 1
        If Fname.ch(xx) = 0 Then Exit For
        s0 = s0 & Chr$(Fname.ch(xx))
    Next
    
    DllServ = 0
End Function

' Callback for zip32.dll
Function DllPass(ByRef s1 As Byte, X As Long, _
    ByRef s2 As Byte, _
    ByRef s3 As Byte) As Long

    ' always put this in callback routines!
    On Error Resume Next
    ' not supported - always return 1
    DllPass = 1
End Function

' Callback for zip32.dll
Function DllComm(ByRef s1 As CBChar) As CBChar
    
    ' always put this in callback routines!
    On Error Resume Next
    ' not supported always return \0
    s1.ch(0) = vbNullString
    DllComm = s1
End Function

'Main Subroutine
Public Function VBZip(argc As Integer, zipname As String, _
        mynames As ZIPnames, junk As Integer, _
        recurse As Integer, updat As Integer, _
        freshen As Integer, basename As String, _
        Optional Encrypt As Integer = 0, _
        Optional IncludeSystem As Integer = 0, _
        Optional IgnoreDirectoryEntries As Integer = 0, _
        Optional Verbose As Integer = 0, _
        Optional Quiet As Integer = 0, _
        Optional CRLFtoLF As Integer = 0, _
        Optional LFtoCRLF As Integer = 0, _
        Optional Grow As Integer = 0, _
        Optional Force As Integer = 0, _
        Optional iMove As Integer = 0, _
        Optional DeleteEntries As Integer = 0) As Long
    
    Dim hmem As Long, xx As Integer
    Dim retcode As Long
    Dim MYUSER As ZIPUSERFUNCTIONS
    Dim MYOPT As ZPOPT
    
    On Error Resume Next ' nothing will go wrong :-)
    
    msOutput = ""
    
    ' Set address of callback functions
    MYUSER.DLLPrnt = FnPtr(AddressOf DLLPrnt)
    MYUSER.DLLPASSWORD = FnPtr(AddressOf DllPass)
    MYUSER.DLLCOMMENT = FnPtr(AddressOf DllComm)
    MYUSER.DLLSERVICE = 0& ' not coded yet :-)
'    retcode = ZpInit(MYUSER)
    
    ' Set zip options
    MYOPT.fSuffix = 0        ' include suffixes (not yet implemented)
    MYOPT.fEncrypt = Encrypt     ' 1 if encryption wanted
    MYOPT.fSystem = IncludeSystem        ' 1 to include system/hidden files
    MYOPT.fVolume = 0        ' 1 if storing volume label
    MYOPT.fExtra = 0        ' 1 if including extra attributes
    MYOPT.fNoDirEntries = IgnoreDirectoryEntries ' 1 if ignoring directory entries
    MYOPT.fExcludeDate = 0   ' 1 if excluding files earlier than a specified date
    MYOPT.fIncludeDate = 0   ' 1 if including files earlier than a specified date
    MYOPT.fVerbose = Verbose       ' 1 if full messages wanted
    MYOPT.fQuiet = Quiet        ' 1 if minimum messages wanted
    MYOPT.fCRLF_LF = CRLFtoLF        ' 1 if translate CR/LF to LF
    MYOPT.fLF_CRLF = LFtoCRLF ' 1 if translate LF to CR/LF
    MYOPT.fJunkDir = junk    ' 1 if junking directory names
    MYOPT.fRecurse = recurse ' 1 if recursing into subdirectories
    MYOPT.fGrow = Grow          ' 1 if allow appending to zip file
    MYOPT.fForce = Force        ' 1 if making entries using DOS names
    MYOPT.fMove = iMove          ' 1 if deleting files added or updated
    MYOPT.fDeleteEntries = DeleteEntries ' 1 if files passed have to be deleted
    MYOPT.fUpdate = updat    ' 1 if updating zip file--overwrite only if newer
    MYOPT.fFreshen = freshen ' 1 if freshening zip file--overwrite only
    MYOPT.fJunkSFX = 0       ' 1 if junking sfx prefix
    MYOPT.fLatestTime = 0    ' 1 if setting zip file time to time of latest file in archive
    MYOPT.fComment = 0       ' 1 if putting comment in zip file
    MYOPT.fOffsets = 0       ' 1 if updating archive offsets for sfx Files
    MYOPT.fPrivilege = 0     ' 1 if not saving privelages
    MYOPT.fEncryption = 0    'Read only property!
    MYOPT.fRepair = 0        ' 1=> fix archive, 2=> try harder to fix
    MYOPT.flevel = 0        ' compression level - should be 0!!!
    MYOPT.Date = vbNullString ' "12/31/79"? US Date?
    MYOPT.szRootDir = UCase$(basename)
    
    retcode = ZpInit(MYUSER)
    ' Set options
    retcode = ZpSetOptions(MYOPT)
    
    ' ZCL not needed in VB
    ' MYZCL.argc = 2
    ' MYZCL.filename = "c:\wiz\new.zip"
    ' MYZCL.fileArray = MYNAMES
    
    ' Go for it!
    
    retcode = ZpArchive(argc, zipname, mynames)
    
    VBZip = retcode
End Function



'-- Callback For UNZIP32.DLL - Receive Message Function
Public Sub UZReceiveDLLMessage(ByVal ucsize As Long, _
    ByVal csiz As Long, _
    ByVal cfactor As Integer, _
    ByVal mo As Integer, _
    ByVal dy As Integer, _
    ByVal yr As Integer, _
    ByVal hh As Integer, _
    ByVal mm As Integer, _
    ByVal c As Byte, ByRef Fname As UNZIPCBCh, _
    ByRef meth As UNZIPCBCh, ByVal crc As Long, _
    ByVal fCrypt As Byte)

Dim s0     As String
Dim xx     As Long
Dim strout As String * 80

'-- Always Put This In Callback Routines!
On Error Resume Next

'------------------------------------------------
'-- This Is Where The Received Messages Are
'-- Printed Out And Displayed.
'-- You Can Modify Below!
'------------------------------------------------

strout = Space(80)

'-- For Zip Message Printing
If uZipNumber = 0 Then
    Mid(strout, 1, 50) = "Filename:"
    Mid(strout, 53, 4) = "Size"
    Mid(strout, 62, 4) = "Date"
    Mid(strout, 71, 4) = "Time"
    uZipMessage = strout & vbNewLine
    strout = Space(80)
End If

s0 = ""

'-- Do Not Change This For Next!!!
For xx = 0 To 255
    If Fname.ch(xx) = 0 Then Exit For
    s0 = s0 & Chr(Fname.ch(xx))
Next

'-- Assign Zip Information For Printing
Mid(strout, 1, 50) = Mid(s0, 1, 50)
Mid(strout, 51, 7) = right("        " & Str(ucsize), 7)
Mid(strout, 60, 3) = right("0" & Trim(Str(mo)), 2) & "/"
Mid(strout, 63, 3) = right("0" & Trim(Str(dy)), 2) & "/"
Mid(strout, 66, 2) = right("0" & Trim(Str(yr)), 2)
Mid(strout, 70, 3) = right(Str(hh), 2) & ":"
Mid(strout, 73, 2) = right("0" & Trim(Str(mm)), 2)

' Mid(strout, 75, 2) = Right(" " & Str(cfactor), 2)
' Mid(strout, 78, 8) = Right("        " & Str(csiz), 8)
' s0 = ""
' For xx = 0 To 255
'     If meth.ch(xx) = 0 Then exit for
'     s0 = s0 & Chr(meth.ch(xx))
' Next xx

'-- Do Not Modify Below!!!
uZipMessage = uZipMessage & strout & vbNewLine
uZipNumber = uZipNumber + 1

End Sub

'-- Callback For UNZIP32.DLL - Print Message Function
Public Function UZDLLPrnt(ByRef Fname As UNZIPCBChar, ByVal X As Long) As Long

Dim s0 As String
Dim xx As Long

'-- Always Put This In Callback Routines!
On Error Resume Next

s0 = ""

'-- Gets The UNZIP32.DLL Message For Displaying.
For xx = 0 To X - 1
    If Fname.ch(xx) = 0 Then Exit For
    s0 = s0 & Chr(Fname.ch(xx))
Next

'-- Assign Zip Information
If Mid$(s0, 1, 1) = vbLf Then s0 = vbNewLine ' Damn UNIX :-)
uZipInfo = uZipInfo & s0

msOutput = uZipInfo
    
UZDLLPrnt = 0

End Function

'-- Callback For UNZIP32.DLL - DLL Service Function
Public Function UZDLLServ(ByRef mname As UNZIPCBChar, ByVal X As Long) As Long

    Dim s0 As String
    Dim xx As Long
    
    '-- Always Put This In Callback Routines!
    On Error Resume Next
    
    s0 = ""
    '-- Get Zip32.DLL Message For processing
    For xx = 0 To X - 1
        If mname.ch(xx) = 0 Then Exit For
        s0 = s0 + Chr(mname.ch(xx))
    Next
    ' At this point, s0 contains the message passed from the DLL
    ' It is up to the developer to code something useful here :)
    UZDLLServ = 0 ' Setting this to 1 will abort the zip!

End Function

'-- Callback For UNZIP32.DLL - Password Function
Public Function UZDLLPass(ByRef p As UNZIPCBCh, _
ByVal n As Long, ByRef m As UNZIPCBCh, _
ByRef Name As UNZIPCBCh) As Integer

Dim prompt     As String
Dim xx        As Integer
Dim szpassword As String

'-- Always Put This In Callback Routines!
On Error Resume Next

UZDLLPass = 1

If uVBSkip = 1 Then Exit Function

'-- Get The Zip File Password
szpassword = InputBox("Please Enter The Password!")

'-- No Password So Exit The Function
If szpassword = "" Then
    uVBSkip = 1
    Exit Function
End If

'-- Zip File Password So Process It
For xx = 0 To 255
    If m.ch(xx) = 0 Then
      Exit For
    Else
      prompt = prompt & Chr(m.ch(xx))
    End If
Next

For xx = 0 To n - 1
    p.ch(xx) = 0
Next

For xx = 0 To Len(szpassword) - 1
    p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
Next

p.ch(xx) = Chr(0) ' Put Null Terminator For C

UZDLLPass = 0

End Function

'-- Callback For UNZIP32.DLL - Report Function To Overwrite Files.
'-- This Function Will Display A MsgBox Asking The User
'-- If They Would Like To Overwrite The Files.
Public Function UZDLLRep(ByRef Fname As UNZIPCBChar) As Long

Dim s0 As String
Dim xx As Long

'-- Always Put This In Callback Routines!
On Error Resume Next

UZDLLRep = 100 ' 100 = Do Not Overwrite - Keep Asking User
s0 = ""

For xx = 0 To 255
    If Fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr(Fname.ch(xx))
Next

'-- This Is The MsgBox Code
xx = MsgBox("Overwrite " & s0 & "?", vbExclamation & vbYesNoCancel, _
              "VBUnZip32 - File Already Exists!")

If xx = vbNo Then Exit Function

If xx = vbCancel Then
    UZDLLRep = 104       ' 104 = Overwrite None
    Exit Function
End If

UZDLLRep = 102        ' 102 = Overwrite 103 = Overwrite All

End Function

'-- ASCIIZ To String Function
Public Function szTrim(szString As String) As String
    
    Dim pos As Integer
    Dim ln As Integer
    
    pos = InStr(szString, Chr(0))
    ln = Len(szString)
    
    Select Case pos
        Case Is > 1
            szTrim = Trim(Left(szString, pos - 1))
        Case 1
            szTrim = ""
        Case Else
            szTrim = Trim(szString)
    End Select

End Function


Public Function VBUnzip(ByRef sZipFileName, ByRef sUnzipDirectory As String, _
    ByRef iExtractNewer As Integer, _
    ByRef iSpaceUnderScore As Integer, _
    ByRef iPromptOverwrite As Integer, _
    ByRef iQuiet As Integer, _
    ByRef iWriteStdOut As Integer, _
    ByRef iTestZip As Integer, _
    ByRef iExtractList As Integer, _
    ByRef iExtractOnlyNewer As Integer, _
    ByRef iDisplayComment As Integer, _
    ByRef iHonorDirectories As Integer, _
    ByRef iOverwriteFiles As Integer, _
    ByRef iConvertCR_CRLF As Integer, _
    ByRef iVerbose As Integer, _
    ByRef iCaseSensitivty As Integer, _
    ByRef iPrivilege As Integer) As Long


On Error GoTo vbErrorHandler

    
    Dim lRet As Long
    
    Dim UZDCL As DCLIST
    Dim UZUSER As USERFUNCTION
    Dim UZVER As UZPVER
    Dim uExcludeNames As UNZIPnames
    Dim uZipNames     As UNZIPnames
    
    msOutput = ""
    
    uExcludeNames.uzFiles(0) = vbNullString
    uZipNames.uzFiles(0) = vbNullString
    
    uZipNumber = 0
    uZipMessage = vbNullString
    uZipInfo = vbNullString
    uVBSkip = 0
    
    With UZDCL
        .ExtractOnlyNewer = iExtractOnlyNewer
        .SpaceToUnderScore = iSpaceUnderScore
        .PromptToOverwrite = iPromptOverwrite
        .fQuiet = iQuiet
        .ncflag = iWriteStdOut
        .ntflag = iTestZip
        .nvflag = iExtractList
        .nUflag = iExtractNewer
        .nzflag = iDisplayComment
        .ndflag = iHonorDirectories
        .noflag = iOverwriteFiles
        .naflag = iConvertCR_CRLF
        .nZIflag = iVerbose
        .C_flag = iCaseSensitivty
        .fPrivilege = iPrivilege
        .Zip = sZipFileName
        .ExtractDir = sUnzipDirectory
    End With
    
    With UZUSER
        .UZDLLPrnt = FnPtr(AddressOf UZDLLPrnt)
        .UZDLLSND = 0&
        .UZDLLREPLACE = FnPtr(AddressOf UZDLLRep)
        .UZDLLPASSWORD = FnPtr(AddressOf UZDLLPass)
        .UZDLLMESSAGE = FnPtr(AddressOf UZReceiveDLLMessage)
        .UZDLLSERVICE = FnPtr(AddressOf UZDLLServ)
    End With
    
    With UZVER
        .structlen = Len(UZVER)
        .beta = Space$(9) & vbNullChar
        .Date = Space$(19) & vbNullChar
        .zlib = Space$(9) & vbNullChar
    End With
    
    UzpVersion2 UZVER
    
    lRet = Wiz_SingleEntryUnzip(0, uZipNames, 0, uExcludeNames, UZDCL, UZUSER)
    VBUnzip = lRet
    

    Exit Function

vbErrorHandler:
    Err.Raise Err.Number, "CodeModule::VBUnzip", Err.Description

End Function

ก็อย่างที่เคยตอบไปใน http://www.thai-access.com/yeadram_view.php?topic_id=690 หล่ะครับ ผมใช้วิธีนั้นครับ ใช้เป็นประจำมาหลายปีแล้ว ยังไม่เกิดปัญหาอะไรเลย