modmain.bas

这是一个电子书制作生成的工具源码,十分有价值,而且运用了加密解密的技术

Attribute VB_Name = "ModMain"
'--------------------------------------------------'
' DM Ebook Designer Beta 1                         '
' Written and designed by Ben Jones                '
' Email1 [e-mail]                         '
' Email2 [e-mail]                       '
' Web-site http://dmeasyhttp.2ya.com               '
' Last updated 28-10-03                            '
' Freeware Open Source eBook Designer for Windows  '
'--------------------------------------------------'

' If you would like to make some chnages to this project
' Then your are free to do so I whould also like to see if some
' Someone has upadted it.
'如果你想要对这个工程做出某些改变
'那么你可以随意这样做我也想要看一些
'已经有人更新了。


' If you like to post the code onto your website then please do.
' But please remmber were it came from. Please just don't says it all your own work.
' This Project is FREEWARE that means you may not use it to gain any sort of profit
'如果你愿意发送这程序代码在你的网址上那么请完成。
'但是请注明它是来自。请不要只说它全部是你自己的工作。
'这工程是免费软件，那么意味你不能使用它为了获得任何方式的利润
'Thank you.
'Ben Jones

Public BookPath As String


Type MyEbook
    eBookTitle As String
    eBookAuthor As String
    eBookHomePage As String
    eBookkExeName As String
    eBookCompDate As Date
End Type

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public TEBook As MyEbook

' Default consts for the ebook
Public Const m_def_ebookTitle = "My eBook"
Public Const m_def_eBookAuthor = "Ben Jones"
Public Const m_def_eBookEXEName = "ebook.exe"

Private Const BIF_RETURNONLYFSDIRS = &H1            '仅返回文件系统目录。如果用户选择的文件夹不是文件系统的一部分，这OK按钮是灰色的。
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const WS_EX_STATICEDGE = &H20000
Private Const GWL_EXSTYLE = (-20)
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2

Private Const RT_STRING = 6& ' String Resource const

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'转换项目标识符列表到文件系统路径。
' API calls used for chnageing and updateing a programs resource files
Declare Function BeginUpdateResource Lib "kernel32" Alias "BeginUpdateResourceA" (ByVal pFileName As String, ByVal bDeleteExistingResources As Long) As Long
Private Declare Function UpdateResource Lib "kernel32" Alias "UpdateResourceA" (ByVal hUpdate As Long, ByVal lpType As String, ByVal lpName As Integer, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long
Declare Function EndUpdateResource Lib "kernel32" Alias "EndUpdateResourceA" (ByVal hUpdate As Long, ByVal fDiscard As Long) As Long

Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Public Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long

'打开读取二进制文件
'重大Bug,不知道原作者做了测试没有,网页中的图片无法显示,背景音乐也不能播放,我发现这是
'因为这些二进制文件已经被损坏了,原因就是因为作者使用String类型来存放,肯定会出错啦.
'应该用Byte型数组,Byte类型才是操作二进制文件要用到的类型.
'Public Function OpenFile(lzFilename As String) As String
Public Function OpenFile(lzFilename As String) As Byte()

Dim TFile As Long
'Dim StrBuffer As String
Dim bytBuffer() As Byte
Dim lngLength As Long

    TFile = FreeFile
    Open lzFilename For Binary As #TFile
'        StrBuffer = Space(LOF(TFile))
        lngLength = LOF(TFile)
        ReDim bytBuffer(1 To lngLength)
        Get #TFile, , bytBuffer()
'        Get #TFile, , StrBuffer
    Close #TFile
'    OpenFile = StrBuffer
    OpenFile = bytBuffer()
    
'    StrBuffer = ""
End Function
'判断文件是否存在
Public Function FindFile(lzFile As String) As Boolean
    ' This function will retun a result of a file of exsitence file found will return with a true value
    If Dir$(lzFile) = "" Then FindFile = False Else FindFile = True
End Function
'整理路径
Public Function FixPath(lzPath As String) As String
    ' Fixes a path by adding a back slash if required
    If Right$(lzPath, 1) = "\" Then FixPath = lzPath Else FixPath = lzPath & "\"
End Function
'取得文件扩展名
Public Function GetFileExt(lzFile As String) As String
Dim i As Long, iPart As Long, StrA As String
   For i = Len(lzFile) To 1 Step -1
        StrA = Mid(lzFile, i, 1)
        If StrA = "." Then
            iPart = i
            Exit For
        End If
   Next
   
   If iPart = 0 Then
        GetFileExt = ""
    Else
        GetFileExt = UCase$(Mid$(lzFile, iPart + 1, Len(lzFile)))
   End If
   '良好的编程习惯，用完后数值型变量清零，字符型变量清空为空串。
   iPart = 0: i = 0
   StrA = ""
   
End Function
'用SHBrowseForFolder函数获得用户选择的文件夹路径
Function GetFolder(ByVal hWndOwner As Long, ByVal sTitle As String) As String
Dim bInf As BROWSEINFO
Dim RetVal As Long
Dim PathID As Long
Dim RetPath As String
Dim OffSet As Integer

    bInf.hOwner = hWndOwner
    bInf.lpszTitle = sTitle
    bInf.ulFlags = BIF_RETURNONLYFSDIRS
'    bInf.pszDisplayName = "C:\windos\"
    PathID = SHBrowseForFolder(bInf)
    RetPath = Space$(512)
    RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)
    If RetVal Then
        OffSet = InStr(RetPath, Chr$(0))
        GetFolder = Left$(RetPath, OffSet - 1)
    End If

End Function

'平面边框
Private Function FlatBorder(ByVal hwnd As Long, MakeControlFlat As Boolean)
Dim TFlat As Long
    TFlat = GetWindowLong(hwnd, GWL_EXSTYLE)
    If MakeControlFlat Then
        TFlat = TFlat And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
    Else
        TFlat = TFlat And Not WS_EX_STATICEDGE Or WS_EX_CLIENTEDGE
    End If
    SetWindowLong hwnd, GWL_EXSTYLE, TFlat
    SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE
  
End Function

'生成平面控件(ListBox,Textbox)
Public Function MakeFlatControls(frm As Form)
Dim Icnt As Long
    ' Returns long 32bit hangle of each control found for the flatborder function
    For Icnt = 0 To frm.Controls.Count - 1
        Select Case TypeName(frm.Controls(Icnt))
            Case "ListBox", "TextBox"
                FlatBorder frm.Controls(Icnt).hwnd, True ' applys flatborder to each control found
        End Select
    Next Icnt
    Icnt = 0
    
End Function

Public Function AddInfoRes(mResFile As String, mInfo As String) As Long
Dim iRet As Long
Dim hUpdate As Long

    hUpdate = BeginUpdateResource(mResFile, False)
    
    If hUpdate = 0 Then AddInfoRes = 0: Exit Function
    
    iRet = UpdateResource(hUpdate, "CUSTOM", 101, 1033, ByVal mInfo, LenC(mInfo))
    '上面的语句发现问题,可能因为是用ANSI的内码,而不是Unicode码,所以中文算两个字节,英文算一个字节.所以你中英文混合情况直接用Len是不对的.
    
    If iRet = 0 Then AddInfoRes = 0: Exit Function
    
    iRet = EndUpdateResource(hUpdate, False)
    
    If iRet = 0 Then AddInfoRes = 0: Exit Function
    AddInfoRes = 1
    
End Function

'取长度,中文两个字节,英文符号一个字节长度
Public Function LenC(ByVal SourceString As String) As Integer
    Dim byts() As Byte
    byts = SourceString
    LenC = LenB(StrConv(byts, vbFromUnicode))
End Function

Public Function ExtractFileExt(Value As String) As String  '获取文件的后辍名

 On Error Resume Next
 
  Dim Tmp As String
  Dim tmpCount As Integer
  Dim MainCount As Integer
  
  tmpCount = Len(Value)
  
  For MainCount = 0 To Len(Value)
    
   If Mid$(Value, tmpCount, 1) <> "." Then
   
    Tmp = Mid$(Value, tmpCount, 1) + Tmp
    tmpCount = tmpCount - 1
  
   Else
  
    If Tmp <> "" Then ExtractFileExt = Tmp
          
    Exit Function
   
   End If
  
 Next MainCount

End Function