|
|
楼主 |
发表于 2008-5-17 23:22:40
|
显示全部楼层
批量生成资源文件工具
'**************************************************************************
'**模 块 名：RES批量生成 - frmRES
'**说 明：魔灵圣域 版权所有2008 - 2009(C)
'**创 建 人：郭卫(魔灵)
'**日 期：2008-05-16 01:33:59
'**修 改 人：郭卫
'**日 期：
'**描 述：郭卫制作
'**版 本：V1.0.2 http://icecept.blog.sohu.com
'*************************************************************************
Option Explicit
'让shell等待的API及参数
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredaccess&, ByVal bInherithandle&, ByVal dwProcessid&) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpexitcode As Long) As Long
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Sub Form_Load() '选择默认路径
Dir1.Path = App.Path
File1.Path = Dir1.Path
File1.Pattern = "*.bmp"
Text2.Text = File1.Path
End Sub
Private Sub Combo1_Change()
File1.Pattern = "*" & "." & Combo1.Text
End Sub
Private Sub Combo1_Click()
File1.Pattern = "*" & "." & Combo1.Text
End Sub
Private Sub Drive1_Change() '选择驱动器
Dir1.Path = Drive1.Drive
End Sub
Private Sub Dir1_Change() '选择文件夹
File1.Pattern = "*" & "." & Combo1.Text
File1.Path = Dir1.Path
Text2.Text = File1.Path
End Sub
Private Sub Command1_Click()
On Error Resume Next
If InStr(Dir1.Path, Chr(32)) Then
MsgBox "路径中不能含有空格，此文件未编译!请把此程序放到没有空格的文件夹中运行", vbOKOnly Or vbInformation, "提示"
Exit Sub
End If
Dim DestinationFile As String, SourceFile As String, i As Long
Dim RES As String, FileStyle As String
Open CheckFilePath(App.Path) & "RES.rc" For Output As #1
Print #1, vbNullString;
Close #1
If File1.ListCount > 0 Then
For i = 0 To File1.ListCount - 1
File1.ListIndex = i
SourceFile = File1.Path & "\" & File1.FileName
Select Case Combo1.Text
Case "bmp"
FileStyle = "BITMAP"
Case "txt"
FileStyle = "TEXTFILE"
Case "ico"
FileStyle = "ICON"
Case "cur"
FileStyle = "CURSOR"
Case "wav"
FileStyle = "WAVE"
End Select
DestinationFile = File1.Path & "\" & "A" & i + 1 & "." & Combo1.Text
Name SourceFile As DestinationFile
Open CheckFilePath(App.Path) & "RES.rc" For Append As #1
Print #1, 100 + i + 1 & Space(2) & FileStyle & Space(2) & DestinationFile
Close #1
Next i
File1.Refresh
ShellWait CheckFilePath(App.Path) & "RC.EXE /r RES.rc", vbHide
End If
Kill CheckFilePath(App.Path) & "RES.rc"
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Function CheckFilePath(ByVal Path As String) As String
'检查文件是否在根目录下
If Right(Path, 1) <> "\" Then
CheckFilePath = Path & "\"
Else
CheckFilePath = Path
End If
End Function
'让shell等待的函数
Public Sub ShellWait(cCommandLine As String, Optional WindowsStyle As VbAppWinStyle)
Dim hShell As Long
Dim hProc As Long
Dim lExit As Long
If Not IsMissing(WindowsStyle) Then WindowsStyle = vbNormalFocus
hShell = Shell(cCommandLine, WindowsStyle)
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
Do
GetExitCodeProcess hProc, lExit
DoEvents
Loop While lExit = STILL_ACTIVE
End Sub
Private Sub mnuabout_Click()
Dim about As String
about = "作者：郭卫，昵称：魔灵。喜欢用Visual Basic编程序的平面设计师，从中学时代就酷爱编程，"
about = about & "从Gwbasic到Visual Basic，创作了不少的作品。并且我还特别喜"
about = about & "欢平面设计，熟练使用photoshop和coreldraw，并创作了不少的作品."
about = about & "作品有记事薄（类似于写字板）、华容道（20局的游戏）、企业商品"
about = about & "管理、程序自动保存、整点报时、可产生关联的flash播放器、资源文件批量生成工具等一批软件，"
about = about & "如果大家对我的程序感兴趣，请与我联系." & vbCrLf & "QQ:543375508"
about = about & vbCrLf & "E-mail:icecept@163.com"
about = about & vbCrLf & "魔灵圣域之情感世界 http://icecept.blog.sohu.com"
MsgBox about, vbOKOnly Or vbInformation, "作者信息"
End Sub
Private Sub mnutishi_Click()
MsgBox "本程序为了加快资源生成速度，会批量更改文件夹中文件的名称" & vbCrLf & "请备份此文件夹中的文件.", vbOKOnly Or vbInformation, "提示"
End Sub
 附件: 批量生成资源文件.rar
[ 本帖最后由 icecept 于 2008-5-17 23:25 编辑 ] |
评分
-
查看全部评分
|
楼主: icecept
IP卡
狗仔卡
发表于 2008-5-7 12:49:34
发表于 2008-5-18 10:52:04
