frmmain.frm

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

      X1              =   135
      X2              =   5445
      Y1              =   1350
      Y2              =   1350
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00808080&
      X1              =   120
      X2              =   5430
      Y1              =   1335
      Y2              =   1335
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "工程文件："
      BeginProperty Font 
         Name            =   "Verdana"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   135
      TabIndex        =   4
      Top             =   1425
      Width           =   900
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "作者名字："
      BeginProperty Font 
         Name            =   "Verdana"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   225
      TabIndex        =   2
      Top             =   840
      Width           =   900
   End
   Begin VB.Label lbltitle 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "eBook标题："
      BeginProperty Font 
         Name            =   "Verdana"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   210
      TabIndex        =   0
      Top             =   345
      Width           =   1080
   End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'--------------------------------------------------'
' 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

Private Declare Function UpdateResource Lib "kernel32" Alias "UpdateResourceA" (ByVal hUpdate As Long, ByVal lpType As Integer, ByVal lpName As String, ByVal wLanguage As Long, lpData As Any, ByVal cbData As Long) As Long

    Dim CD As New cFileDialog

Sub LbSelect()
Dim Icount As Long
' I used this to select or deselect all items in a listbox
    For Icount = 0 To lstFiles.ListCount - 1
        lstFiles.Selected(Icount) = True
    Next
    
    lstFiles.Refresh
    Icount = 0
    
End Sub

Private Sub cmdabout_Click()
Dim Msg As String
    
    Msg = Msg & "新林Ebook制作工具 Beta 1" _
    & vbCrLf & vbCrLf & "这程序是免费软件。" & vbCrLf & vbCrLf & "简单容易地创建你们自己的Windows Ebook。" _
    & vbCrLf & vbCrLf & "程序编写和设计者：新林。" _
    & vbCrLf & vbCrLf & "请发送任何的评论或问题到∶" _
    & vbCrLf & "[e-mail]"
    
    MsgBox Msg, vbInformation, "关于... " & frmmain.Caption ' Shows the programs about box.
    
End Sub

Private Sub cmdcompile_Click()
Dim sHead As String, mBookSfx As String, StrData As String, iResult As Long, iRet As Long, hUpdate As Long
Dim lzFullPath As String, i As Long, OutputDir As String, OutPutFile As String
Dim bytData() As Byte

    ' The code below just does some simple validation checks
    If Len(BookPath) = 0 Then
        MsgBox "没有找到工程文件,请选择你的工程文件夹。", vbInformation, frmmain.Caption
        Exit Sub
    ElseIf lstFiles.ListCount = 0 Then
        MsgBox "没有找到工程文件,请选择你的工程文件夹。", vbInformation, frmmain.Caption
        Exit Sub
    ElseIf Len(Trim(txtHomepage.Text)) = 0 Then
        MsgBox "你需要包括你的默认索引页名字。", vbInformation, frmmain.Caption
        Exit Sub
    ElseIf FindFile(BookPath & txtHomepage.Text) = False Then
        MsgBox "你输入的索引页名字没有找到。" & vbCrLf & vbCrLf & BookPath & txtHomepage, vbCritical, frmmain.Caption
        Exit Sub
    ElseIf Len(Trim(txtOutfile.Text)) = 0 Then
        MsgBox "你没有为你的ebook输入一个名字。将为你是提供缺省名。", vbInformation, frmmain.Caption
    ElseIf Len(txtOutfile.Text) > 0 And Not UCase(Right(txtOutfile.Text, 4)) = ".EXE" Then
        txtOutfile.Text = txtOutfile.Text & ".exe"
    End If
    
    ' Update the Ebook type Struc
    TEBook.eBookTitle = txtTitle.Text       ' Add ebook title
    TEBook.eBookAuthor = txtAuthor.Text     ' Add the Author of the ebook
    TEBook.eBookHomePage = txtHomepage.Text     ' Add the default index page will be the start page
    TEBook.eBookkExeName = txtOutfile.Text   ' This will become executable name of ebook
'    TEBook.eBookCompDate = Format(Date, "dd/mm/yyyy") ' Add in the compile date the ebook was made
    TEBook.eBookCompDate = Date
    
    If Trim(Len(txtTitle.Text)) = 0 Then ' If no title was found set a default one
        TEBook.eBookTitle = m_def_ebookTitle
    End If
    
    If Trim(Len(txtAuthor.Text)) = 0 Then
        TEBook.eBookAuthor = m_def_eBookAuthor ' If no author was set a default one
    End If
    
    If Trim(Len(txtOutfile.Text)) = 0 Then
        TEBook.eBookkExeName = m_def_eBookEXEName ' If no ebook exe name was found set the default one
    End If

    OutputDir = txtOutfolder.Text ' Path of the ebook
    OutPutFile = OutputDir & TEBook.eBookkExeName ' Full path and Filename of the ebook

    ' Ok the code below will copy the ebook sfx file to the new file for the ebook.
    ' You can find the sfx file in the dmsfx folder of this project.
    ' You need to compile first as you already no that that :)
    
    'mBookSfx = FixPath(App.Path) & "dmsfx\dmsfx.dat" ' Path to the ebook executable file
    mBookSfx = FixPath(App.Path) & "EbookViewer\EbookViewer.dat"

    If FindFile(mBookSfx) = False Then ' Check to see if the sfx file exsists
        MsgBox "查找文件存在错误。" & vbCrLf & vbCrLf _
        & "请检查所有文件是否安装正确。", vbCritical, frmmain.Caption       'There was an error finding the file:
        Exit Sub
    Else
        ' Below we use the code to copy the sfx file to
        ' were the ebook is to be created as we do not want to chnage the original sfx file
        FileCopy mBookSfx, OutPutFile
    End If
    
    sHead = TEBook.eBookTitle & ":" & TEBook.eBookAuthor & ":" & TEBook.eBookHomePage _
    & ":" & TEBook.eBookCompDate    ' Information for the ebook

    iResult = AddInfoRes(OutPutFile, sHead)
    sHead = "" ' Clear info buffer
    
    If Not iResult > 0 Then
        MsgBox "当编译你的ebook时出现错误。", vbCritical, "编译错误"          'There was an error while compileing your ebook
        Kill OutPutFile ' Kill the output file we no need for this now
        Exit Sub ' we can also Stop here
    Else
        For i = 0 To lstFiles.ListCount - 1 ' Loop though the listbox
            If lstFiles.Selected(i) = True Then ' See if the item is selected
                lzFullPath = BookPath & lstFiles.List(i) ' Get the full path of the file in the listbox
'                StrData = OpenFile(lzFullPath) ' Get the data from the file
                bytData = OpenFile(lzFullPath)
                hUpdate = BeginUpdateResource(OutPutFile, False) ' Get the hangle of the file
'                iRet = UpdateResource(hUpdate, 2110, UCase(lstFiles.List(I)), 1033, ByVal StrData, Len(StrData)) ' Update files resource with our ebook data
                iRet = UpdateResource(hUpdate, 2110, UCase(lstFiles.List(i)), 1033, bytData(1), UBound(bytData))        '在这时我开始一直犯了个大错误,lpData参数我开始用bytData和bytData(),我想一下子引用,这是不对的,正确的是第一个bytData(1)
                '至此这个问题已经解决了,原作者是错在用String类型来读取二进制文件,这当然会引起错误,只能正确识别Html文件,其它的二进制文件则无法显示和使用.
                iRet = EndUpdateResource(hUpdate, False) ' Save the data to the file
            End If
        Next
    End If
    
    '改变EXE文件的图标
'        Dim Err As String
    ReplaceIcons CD.Filename, OutPutFile, Err          '这个替换图标完全是采用文件操作,比较不稳定,有时会出错
'    bytData = OpenFile(CD.Filename)
'    hUpdate = BeginUpdateResource(OutPutFile, False)
'    iRet = UpdateResource(Update, 3, CD.Filename, 1033, bytData(1), UBound(bytData))
'    iRet = EndUpdateResource(hUpdate, False)

    
    ' Clear vars
    StrData = ""
    lzFullPath = ""
    iRet = 0
    MsgBox "你的ebook现在已经编译为" & vbCrLf & vbCrLf & OutPutFile, vbInformation, "编译完成。"
    
End Sub

Private Sub cmdExit_Click()
    Unload frmmain ' Unload the form
End Sub

Private Sub cmdLoadIcon_Click()
'可以选择ICO文件载入或EXE文件载入
    On Error Resume Next
    Dim Ret As Long
    
    With CD
        .Filter = "(所有支持类型文件(*.ICO,*.EXE))|*.ICO;*.EXE|(ICO图标文件) *.ICO|*.ICO|(EXE可执行文件) *.EXE|*.EXE"
        .flags = DialogFlags.OFN_FILEMUSTEXIST
        .hwnd = Me.hwnd
        .CancelError = False
        .ShowOpen
    End With
    If CD.Filename = "" Then Exit Sub
    If LCase(ExtractFileExt(CD.Filename)) = "ico" Then             '如果是选择了ICO图标文件
        picIcon.Picture = LoadPicture(CD.Filename)
    
    ElseIf LCase(ExtractFileExt(CD.Filename)) = "exe" Then      '选择了EXE文件
        picIcon.Picture = LoadPicture("")       '先清空图像
        Ret = ExtractIcon(App.hInstance, CD.Filename, 0)
        Ret = DrawIcon(picIcon.hdc, 0, 0, Ret)
        picIcon.Refresh

    End If
    

End Sub

Private Sub cmdNewP_Click()
    '初始化工作环境
    txtTitle.Text = ""
    txtAuthor.Text = ""
    txtPath.Text = ""
    txtHomepage.Text = ""
    lstFiles.Clear
    txtOutfolder.Text = ""
    txtOutfile.Text = ""
    
    
End Sub

Private Sub cmdopen_Click()
Dim FolName As String
Dim x As String

    FolName = FixPath(GetFolder(frmmain.hwnd, "选择你全部文件所在的文件夹:"))           'Choose the folder were all your files are in below:
    If Len(FolName) <= 1 Then
        Exit Sub
        ' Exit out sub if the folder length is lower of equal to 1
    Else
        txtPath.Text = FolName ' Assign textbox with folder path
        BookPath = FolName ' Assign Bookpath with folder path
        txtOutfolder.Text = FolName
        lstFiles.Clear   ' Clear the list box
    
        x = Dir(FolName)
        ' Code below will loop though all the files in the folder.
        ' Note I not added code for sub folders.
        ' If you like to add this in please do so.
        Do While x <> ""
            lstFiles.AddItem x
            x = Dir
            DoEvents
        Loop
    End If

End Sub

Private Sub cmdoutput_Click()
Dim FolName As String
    FolName = FixPath(GetFolder(frmmain.hwnd, "Choose the folder were all your files are in below:"))
    If Len(FolName) <= 1 Then Exit Sub
    ' Exit out sub if the folder length is lower of equal to 1
    txtOutfolder.Text = FolName
    
End Sub

Private Sub cmdselall_Click()
    LbSelect ' Select all items in the listbox
End Sub
Private Sub Command1_Click()
End Sub

Private Sub Command2_Click()

End Sub

Private Sub cmdSetDefIcon_Click()
    Dim Ret As Long
'    picIcon.Cls
'    picIcon.Picture = LoadPicture("")       '先清空图像
    picIcon.Picture = Nothing
    
    Ret = ExtractIcon(App.hInstance, App.Path & "\EbookViewer\EbookViewer.dat", 0)
    Ret = DrawIcon(picIcon.hdc, 0, 0, Ret)
'    picIcon.Refresh
    

End Sub

Private Sub Form_Load()
    Dim Ret As Long, Ret2 As Long
    
    MakeFlatControls frmmain ' Function that turns all controls flat see ModMain
    LoadHelpFile FixPath(App.Path) & "help.txt"
    For i = 0 To imghelp.Count - 1
        imghelp(i).Picture = img1.Picture
    Next
    
    Ret = ExtractIcon(App.hInstance, App.Path & "\EbookViewer\EbookViewer.dat", 0)
    Ret = DrawIcon(picIcon.hdc, 0, 0, Ret)
'    picIcon.Refresh

'    txtPath.Text = "E:\My Files\xinlin51\VBGood\电子书制作器\eBookDesigner\TestProject"
    txtHomepage.Text = "index.html"
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmmain = Nothing ' Release the form from memory
End Sub

Private Sub imghelp_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    imghelp(Index).BorderStyle = 1
End Sub

Private Sub imghelp_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    imghelp(Index).BorderStyle = 0
    Showhelp imghelp(Index).Tag
End Sub

Private Sub txtPath_KeyPress(KeyAscii As Integer)
    Dim FolName As String
    
    If KeyAscii = 13 Then
        KeyAscii = 0
        FolName = txtPath.Text
        If Right$(FolName, 1) <> "\" Then
            FolName = FolName & "\"
        End If
        If Dir$(FolName, vbDirectory) <> "" Then
        
            txtPath.Text = FolName ' Assign textbox with folder path
            BookPath = FolName ' Assign Bookpath with folder path
            txtOutfolder.Text = FolName
            lstFiles.Clear   ' Clear the list box
        
            x = Dir(FolName)
            Do While x <> ""
                lstFiles.AddItem x
                x = Dir
                DoEvents
            Loop
        End If
    End If
End Sub