mdlfunction.bas

一个自己把自己想要的东西刻录光盘的程序原代码

Attribute VB_Name = "MdlFunction"
Option Explicit

Public gMakeCDExe As String '刻盘程序路径
Public Const XTTS = "系统提示" '提示信息
Public Const gRegSubKey = "SOFTWARE\方正奥德计算机系统有限公司\文件管理" '注册表子键
Public gErrDescription As String '错误描述
Public Const LXGLY = "请立即与管理员联系！" '提示信息

'####################################################################
'系统主函数
'####################################################################
Public Sub Main()
On Error GoTo Err

If App.PrevInstance Then
   MsgBox "刻盘程序正在运行。不能多次启动！", vbOKOnly Or vbInformation, XTTS
   End
End If

If LoadReg = False Then
   If CreateReg = False Then GoTo Err
End If
If LoadReg = False Then GoTo Err

FrmCreateCD.Show

Exit Sub
Err:
   MsgErr "系统初始化", "1001", gErrDescription, True, LXGLY, Err.Description
   End
End Sub

'####################################################################
'系统初始化读注册表函数，返回值Boolean
'####################################################################
Public Function LoadReg() As Boolean
On Error GoTo Err
Dim t As String

If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "MakeCDExe", gMakeCDExe) = False Then
   gMakeCDExe = "c:\smartstor archive\runfsapi.exe"
End If

LoadReg = True
Exit Function
Err:
   LoadReg = False
End Function

'####################################################################
'系统初始化创建注册表函数，返回值Boolean
'####################################################################
Public Function CreateReg() As Boolean
On Error GoTo Err

If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "MakeCDExe", "c:\smartstor archive\runfsapi.exe") = False Then GoTo Err
CreateReg = True
Exit Function
Err:
   CreateReg = False
End Function

'####################################################################
'系统报错函数，返回值Boolean
'####################################################################
Public Sub MsgErr(ErrSource As String, ErrCode As String, ErrDes As String, ViewMsgBox As Boolean, PromptStr As String, SysErr As String)
On Error GoTo Err
If ViewMsgBox = True Then
   If PromptStr = "" Then
      MsgBox "错误来源：" + ErrSource + Chr(10) + "错误代码：" + ErrCode + Chr(10) + "错误描述：" + ErrDes + Chr(10) + "系统描述：" + Err.Description, vbExclamation, "系统错误"
   Else
      MsgBox "错误来源：" + ErrSource + Chr(10) + "错误代码：" + ErrCode + Chr(10) + "错误描述：" + ErrDes + Chr(10) + "系统描述：" + Err.Description + Chr(13) + Chr(13) + PromptStr, vbExclamation, "系统错误"
   End If
End If
'写日志
Close #1
Open App.Path + "\ErrorLog.txt" For Append As #1
   Print #1, "错误时间：" + Format(Date, "yyyy-mm-dd") + " " + Format(Time, "hh:mm:ss")
   Print #1, "错误来源：" + ErrSource + " 错误描述：" + ErrDes
   Print #1, "错误代码：" + ErrCode + " 系统描述：" + SysErr
   Print #1, ""
Close #1
Err:
End Sub


' "Software\方正奥德计算机系统有限公司\SystemManage\"
Public Function GetRegVal(SubKey As String, RtnString As String) As Boolean
On Error GoTo Err
Dim Reg_Size As Long
Dim Reg_buffer As String
Dim Reg_Result As Long
Reg_buffer = String$(1024, 0)
Reg_Size = 1024
Reg_Result = RegQueryValue(HKEY_LOCAL_MACHINE, SubKey, Reg_buffer, Reg_Size)
If Reg_Result <> 0 And Reg_Result <> 13 Then GoTo Err
If InStr(1, Reg_buffer, ";") <= 1 Then
   RtnString = Left(Trim(Reg_buffer), Reg_Size - 1)
Else
   RtnString = Left(Trim(Reg_buffer), InStr(1, Reg_buffer, ";") - 1)
End If
GetRegVal = True
Exit Function
Err:
   GetRegVal = False
End Function

'#####################################################################################
'获取系统路径
'#####################################################################################
Public Function GetSysPath() As String
On Error GoTo ErrHandle
Dim lngResult As Long
Dim lpBuffer$
Dim StrGetWin As String
lpBuffer = Space$(2048)
lngResult = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
StrGetWin = Left(Trim(lpBuffer), Len(Trim(lpBuffer)) - 1)
GetSysPath = StrGetWin
Exit Function
ErrHandle:
   MsgBox "系统错误" + Chr(10) + "错误描述：" + Err.Description
End Function

'#####################################################################################
'获取IE路径
'#####################################################################################
Public Function GetIEPath(r_IE_Path As String) As Boolean
On Error GoTo Err
r_IE_Path = ""

If RegGetString(HKEY_LOCAL_MACHINE, "Software\Microsoft\IE4\Setup", "Path", r_IE_Path) = False Then GoTo Err
r_IE_Path = Replace(r_IE_Path, "%programfiles%", "c:\program files")
If Dir(r_IE_Path + "\Iexplore.exe") = "" Then GoTo Err
r_IE_Path = r_IE_Path + "\Iexplore.exe"
GetIEPath = True
Exit Function
Err:
   r_IE_Path = ""
   GetIEPath = False
End Function