分享
 
 
 

用VB6.0自制压缩与解压缩程序(三)

王朝vb·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

用记事本打开modMain.bas文件,copy以下内容到其中:

Attribute VB_Name = "modMain"

' ==============================================

' 信息打包与展开 (启动模块)

'

' 功能 :利用系统所存在的资源自作压缩与解压缩程序

'

' 作 者 :谢家峰

' 整理日期 :2004-08-08

' Email :douhapy@sina.com

'

' ==============================================

'

Option Explicit

Public WindowsPath As String

Public WindowsSysPath As String

Sub Main()

Dim BootTrapPath As String

Dim SetupFilePath As String

Dim regExeFilePath As String

Dim regInfo() As String

Dim regStr() As String

Dim regFileName As String

Dim str As String

Dim resultat As Long

Dim resultat2 As Long

Dim res As Double

Dim startinfo As STARTUPINFO

Dim procinfo As PROCESS_INFORMATION

Dim secu As SECURITY_ATTRIBUTES

Dim i As Integer

If App.PrevInstance Then MsgBox "系统已启动!", , App.EXEName: End

'获得系统安装目录

WindowsPath = GetWindowsDir

WindowsSysPath = GetWindowsSysDir

Load frmMain

frmMain.Show

End Sub

用记事本打开modAPI.bas文件,copy以下内容到其中:

Attribute VB_Name = "modAPI"

' ==============================================

' 信息打包与展开 (所调用的API及通用函数模块)

'

' 功能 :利用系统所存在的资源自作压缩与解压缩程序

'

' 作 者 :谢家峰

' 整理日期 :2004-08-08

' Email :douhapy@sina.com

'

' ==============================================

'

Option Explicit

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long

Public Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpbuffer As String, ByVal nSize As Long) As Long

Public Const gstrSEP_DIR$ = "\"

Public Const gstrSEP_URLDIR$ = "/"

Public Const gintMAX_SIZE% = 255

Public Const INFINITE = &HFFFF

Public Type STARTUPINFO

cb As Long

lpReserved As String

lpDesktop As String

lpTitle As String

dwX As Long

dwY As Long

dwXSize As Long

dwYSize As Long

dwXCountChars As Long

dwYCountChars As Long

dwFillAttribute As Long

dwFlags As Long

wShowWindow As Integer

cbReserved2 As Integer

lpReserved2 As Long

hStdInput As Long

hStdOutput As Long

hStdError As Long

End Type

Public Type PROCESS_INFORMATION

hProcess As Long

hThread As Long

dwProcessId As Long

dwThreadId As Long

End Type

Public Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDescriptor As Long

bInheritHandle As Long

End Type

Function StripTerminator(ByVal strString As String) As String

Dim intZeroPos As Integer

intZeroPos = InStr(strString, Chr$(0))

If intZeroPos > 0 Then

StripTerminator = Left$(strString, intZeroPos - 1)

Else

StripTerminator = strString

End If

End Function

' -----------------------------------------------------------

' 给目录添加分割线

'

' -----------------------------------------------------------

'

Sub AddDirSep(strPathName As String)

If Right(Trim(strPathName), Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR And _

Right(Trim(strPathName), Len(gstrSEP_DIR)) <> gstrSEP_DIR Then

strPathName = RTrim$(strPathName) & gstrSEP_DIR

End If

End Sub

' -----------------------------------------------------------

' 调用API函数获得Windows的系统目录

'

' -----------------------------------------------------------

'

Function GetWindowsSysDir() As String

Dim strBuf As String

strBuf = Space$(gintMAX_SIZE)

If GetSystemDirectory(strBuf, gintMAX_SIZE) > 0 Then

strBuf = StripTerminator(strBuf)

AddDirSep strBuf

GetWindowsSysDir = strBuf

Else

GetWindowsSysDir = vbNullString

End If

End Function

' -----------------------------------------------------------

' 调用API函数获取Windows目录

'

' -----------------------------------------------------------

'

Function GetWindowsDir() As String

Dim strBuf As String

strBuf = Space$(gintMAX_SIZE)

If GetWindowsDirectory(strBuf, gintMAX_SIZE) > 0 Then

strBuf = StripTerminator$(strBuf)

AddDirSep strBuf

GetWindowsDir = strBuf

Else

GetWindowsDir = vbNullString

End If

End Function

' --------------------------------------

' 测试目录是否存在

'

' --------------------------------------

'

Public Function DirExists(Path As String) As Boolean

On Error Resume Next

'对于网络地址采用*.*形式

If InStr(Path, "\\") Then

DirExists = (Dir$(Path & "\*.*") <> "")

Else

DirExists = (Dir$(Path & "\nul") <> "")

End If

End Function

' --------------------------------------

' 建立文件夹(含多层结构)

'

' --------------------------------------

'

Public Sub CreateFloder(floder As String)

Dim i As Integer

Dim Path As String

Dim FloderStr() As String

On Error Resume Next

FloderStr = Split(floder, "\")

Path = FloderStr(0)

For i = 1 To UBound(FloderStr) - 1

Path = Path & "\" & FloderStr(i)

If Not DirExists(Path) Then

MkDir Path

End If

Next

End Sub

' --------------------------------------

' 获得长文件名的短文件名

'

' --------------------------------------

'

Function GetShortFileName(FileName As String) As String

Dim str As String

str = String(LenB(FileName), Chr(0))

If GetShortPathName(FileName, str, LenB(FileName)) <> 0 Then

str = Left(str, InStr(str, vbNullChar) - 1)

If str = "" Then

GetShortFileName = FileName

Else

GetShortFileName = str

End If

Else

GetShortFileName = FileName

End If

End Function

' --------------------------------------

' 获得文件名

'

' --------------------------------------

'

Public Function GetFileName(fileNamePath As String) As String

Dim AuxVar() As String

AuxVar() = Split(fileNamePath, "\", , vbTextCompare)

GetFileName = AuxVar(UBound(AuxVar))

End Function

' --------------------------------------

' 获得文件的扩展名

'

' --------------------------------------

'

Public Function GetExt(FileName As String) As String

Dim AuxVar() As String

On Error Resume Next

AuxVar() = Split(FileName, "\", , vbTextCompare)

AuxVar() = Split(AuxVar(UBound(AuxVar)), ".", , vbTextCompare)

GetExt = AuxVar(UBound(AuxVar))

End Function

' --------------------------------------

' 测试文件是否存在(不能测试隐含文件和系统文件)

'

' --------------------------------------

'

Public Function FileExists(FileName As String) As Boolean

On Error Resume Next

FileExists = (Dir$(FileName) <> "")

End Function

' --------------------------------------

' 查找文件

'

' --------------------------------------

'

Function GetFiles(filespec As String, Optional Attributes As VbFileAttribute) As String()

Dim result() As String

Dim FileName As String, count As Long, path2 As String

Const ALLOC_CHUNK = 50

ReDim result(0 To ALLOC_CHUNK) As String

FileName = Dir$(filespec, Attributes)

Do While Len(FileName)

count = count + 1

If count > UBound(result) Then

ReDim Preserve result(0 To count + ALLOC_CHUNK) As String

End If

result(count) = FileName

FileName = Dir$

Loop

ReDim Preserve result(0 To count) As String

GetFiles = result

End Function

' --------------------------------------

' 转换字符串

'

' --------------------------------------

'

Public Function StringFromBuffer(buffer As String) As String

Dim nPos As Long

nPos = InStr(buffer, vbNullChar)

If nPos > 0 Then

StringFromBuffer = Left$(buffer, nPos - 1)

Else

StringFromBuffer = buffer

End If

End Function

' --------------------------------------

' 写内容到文本文件中

'

' --------------------------------------

'

Sub WriteTextFileContents(text As String, FileName As String, Optional AppendMode As Boolean)

Dim fnum As Integer, isOpen As Boolean

On Error GoTo Error_Handler

fnum = FreeFile()

If AppendMode Then

Open FileName For Append As #fnum

Else

Open FileName For Output As #fnum

End If

isOpen = True

Print #fnum, text

Error_Handler:

If isOpen Then Close #fnum

If Err Then Err.Raise Err.Number, , Err.Description

End Sub

' --------------------------------------

' 读信息到Ini文件中

'

' --------------------------------------

'

Public Function ReadIniFile(ByVal strIniFile As String, ByVal strSection As String, ByVal strKey As String) As String

Dim strBuffer As String * 255

If GetPrivateProfileString(strSection, strKey, vbNullString, strBuffer, 255, strIniFile) Then

ReadIniFile = StringFromBuffer(strBuffer)

End If

End Function

' --------------------------------------

' 添加信息到ListView控件中

'

' --------------------------------------

'

Sub lstvInfo_Add(LstVControl As ListView, InfoNum As Integer, SelectedFlag As Boolean, ParamArray InfoStr())

Dim i As Integer

With LstVControl

.ListItems.Add , , Trim(InfoStr(0))

If SelectedFlag Then

.ListItems(.ListItems.count).Selected = True

Else

.ListItems(.ListItems.count).Selected = False

End If

For i = 2 To InfoNum

.ListItems(.ListItems.count).ListSubItems.Add , , Trim(InfoStr(i - 1))

Next

.ListItems(.ListItems.count).EnsureVisible

End With

End Sub

自此,代码Copy完成,这时你再打开工程,编译运行。

1. 信息打包:在frmMain窗体中点击“打包”,直至打开frmAddInfo窗体,在其中点击“添加信息”进行信息添加项,同时,你也可以修改目标信息的路径及文件(说明修改完成后,别忘了点击“修改信息”信息按钮噢),你也可以给你的压缩包修改一个名字。最后点击“信息打包”按钮,进行打包;

2. 信息包展开:打包完成,你可以通过frmMain窗体中的展开程序进行压缩包展开,该展开形式对于存在的文件将覆盖,你可以修给代码,使之符合你自己的要求;

3. 你可以将你的压缩和该程序一同发给你的客户,这样,客户通过展开按钮便可以给你的程序进行信息更新了;

4. 你也可以将这些代码变通形式内嵌在你的程序中,通过文件关联,直接打开你的包文件,这样会更有趣;

5. 若你是Dephi或C++程序员,我相信你看了代码后,用你的方式做起来会更简单。

J 若仍不明白,或需求源代码,请来信告诉我,请来信告诉我,我会尽量满足你的要求!

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有