www.pudn.com > Txt-To-Image.rar > CTxtToImage.ctl, change:2010-05-12,size:19417b


VERSION 5.00 
Object = "{A230E645-C65E-4224-B28F-A273472FD8D8}#1.0#0"; "SavePictureMoreType.ocx" 
Begin VB.UserControl CTxtToImage  
   ClientHeight    =   615 
   ClientLeft      =   0 
   ClientTop       =   0 
   ClientWidth     =   1395 
   ScaleHeight     =   615 
   ScaleWidth      =   1395 
   Begin SavePictureMoreType.CSavePicture CSavePicture1  
      Height          =   375 
      Left            =   0 
      TabIndex        =   1 
      Top             =   0 
      Width           =   375 
      _ExtentX        =   661 
      _ExtentY        =   661 
   End 
   Begin VB.Label labTxtToImg  
      AutoSize        =   -1  'True 
      Caption         =   "TxtToImg" 
      Height          =   180 
      Left            =   480 
      TabIndex        =   0 
      Top             =   240 
      Width           =   720 
   End 
End 
Attribute VB_Name = "CTxtToImage" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = True 
Attribute VB_PredeclaredId = False 
Attribute VB_Exposed = True 
Option Explicit 
 
'将文本文件,转换为图片 
Public Function TxtToImage(ByVal SourceFile As String, ByVal TargetFile As String, ByVal Width As Long, ByVal Pic As String, ByVal strBackColor As String, ByVal FontName As String, ByVal FontBold As Long, ByVal FontItalic As Long, ByVal FontUnderline As Long, ByVal FontStrikethru As Long, ByVal strFontColor As String, ByVal FontSize As Long, ByVal WordWidth As Long, ByVal WordHeight As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As Long 
    On Error GoTo ErrorTag 
    Dim BackColor As Long, FontColor As Long 
    BackColor = GetColorFromStr(strBackColor) 
    FontColor = GetColorFromStr(strFontColor) 
    '判断输入参数合法性 
    If Pic <> "gif" Then Pic = "jpg"            '统一文件类型 
    If BackColor > &HFFFFFF Or BackColor < 0 Then BackColor = &HFFFFFF 
    If FontName = "" Then FontName = "宋体" 
    If FontBold <> 0 Then FontBold = 1          '统一是否加粗 
    If FontItalic <> 0 Then FontItalic = 1 
    If FontUnderline <> 0 Then FontUnderline = 1 
    If FontStrikethru <> 0 Then FontStrikethru = 1 
    If FontColor > &HFFFFFF Or FontColor < 0 Then FontColor = 0 
    If FontSize < 1 Then FontSize = 12          '字体大小 
    If WordWidth < 0 Then WordWidth = 1        '字符间间隔 
    If WordHeight < 0 Then WordHeight = 5        '字符间间隔 
    If Left < 0 Then Left = 0 
    If Top < 0 Then Top = 0 
    If Right < 0 Then Right = 0 
    If Bottom < 0 Then Bottom = 0 
    '读取源文本文件 
    Dim strSrcData As String 
    strSrcData = ReadFileToString(SourceFile) 
    If strSrcData <> "" Then            '如果不为空 
        '初始化一个新的绘图 
        If modDrawDC.Init(Width, BackColor, FontName, FontSize, WordWidth, WordHeight, Left, Top, Right, Bottom) = 0 Then 
            GoTo ErrorTag 
        Else 
            Dim strFirst As String, strSecond As String, lngFontColor As Long, lngFontBold As Long, lngFontItalic As Long, lngFontUnderline As Long, lngFontStrikethru As Long, strFontName As String, lngEndPos As Long 
            Dim lngStartPos As Long 
            lngStartPos = 1 
            lngEndPos = 1 
            Do While True 
                If GetStyleString(strSrcData, lngStartPos, strFirst, strSecond, lngFontColor, lngFontBold, lngFontItalic, lngFontUnderline, lngFontStrikethru, strFontName, lngEndPos) = True Then 
                    '输出第一个字符串 
                    Dim strNowString As String, Pos As Long 
                    For Pos = 1 To Len(strFirst) 
                        strNowString = Mid$(strFirst, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strFirst, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                        End If 
                    Next Pos 
                    '输出第二个字符串 
                    For Pos = 1 To Len(strSecond) 
                        strNowString = Mid$(strSecond, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strSecond, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, IIf(lngFontColor = -1, FontColor, lngFontColor), IIf(lngFontBold = -1, FontBold, lngFontBold), IIf(lngFontItalic = -1, FontItalic, lngFontItalic), IIf(lngFontUnderline = -1, FontUnderline, lngFontUnderline), IIf(lngFontStrikethru = -1, FontStrikethru, lngFontStrikethru), IIf(strFontName = "", FontName, strFontName) 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, IIf(lngFontColor = -1, FontColor, lngFontColor), IIf(lngFontBold = -1, FontBold, lngFontBold), IIf(lngFontItalic = -1, FontItalic, lngFontItalic), IIf(lngFontUnderline = -1, FontUnderline, lngFontUnderline), IIf(lngFontStrikethru = -1, FontStrikethru, lngFontStrikethru), IIf(strFontName = "", FontName, strFontName) 
                        End If 
                    Next Pos 
                    If lngEndPos >= Len(strSrcData) Then        '如果达到最后一个字符了 
                        Exit Do 
                    End If 
                    lngStartPos = lngEndPos 
                Else            '如果没发现成对的字符串,则肯定是最后一段了,直接输出即可 
                    strFirst = Mid$(strSrcData, lngEndPos) 
                    For Pos = 1 To Len(strFirst) 
                        strNowString = Mid$(strFirst, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strFirst, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                        End If 
                    Next Pos 
                    Exit Do 
                End If 
            Loop 
        End If 
    Else 
        GoTo ErrorTag 
    End If 
    '获得结果位图 
    Dim hBitmap As Long, bmWidth As Long, bmHeight As Long 
    hBitmap = modDrawDC.GetBitmap(bmWidth, bmHeight) 
    If hBitmap = 0 Then 
        modDrawDC.Destory 
        Exit Function 
    Else 
        '保存位图到文图文件 
        If SaveBitmap.SaveBitmapAsToFile(hBitmap, App.Path + "\TempTempTempTTTT.bmp") = False Then 
            modDrawDC.Destory 
            Exit Function 
        Else 
            Dim PicShow As IPictureDisp 
            Set PicShow = LoadPicture(App.Path + "\TempTempTempTTTT.bmp") 
            Kill App.Path + "\TempTempTempTTTT.bmp" 
            If CSavePicture1.SavePic(PicShow, TargetFile, Pic) = False Then 
                modDrawDC.Destory 
                Exit Function 
            End If 
            Set PicShow = Nothing 
        End If 
    End If 
    modDrawDC.Destory 
    TxtToImage = 1          '执行成功 
    Exit Function 
ErrorTag: 
    TxtToImage = 0 
End Function 
 
'将文本转换为图片 
Public Function StringToImage(ByVal strString As String, ByVal TargetFile As String, ByVal Width As Long, ByVal Pic As String, ByVal strBackColor As String, ByVal FontName As String, ByVal FontBold As Long, ByVal FontItalic As Long, ByVal FontUnderline As Long, ByVal FontStrikethru As Long, ByVal strFontColor As String, ByVal FontSize As Long, ByVal WordWidth As Long, ByVal WordHeight As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As Long 
    On Error GoTo ErrorTag 
    Dim BackColor As Long, FontColor As Long 
    BackColor = GetColorFromStr(strBackColor) 
    FontColor = GetColorFromStr(strFontColor) 
    '判断输入参数合法性 
    If Pic <> "gif" Then Pic = "jpg"            '统一文件类型 
    If BackColor > &HFFFFFF Or BackColor < 0 Then BackColor = &HFFFFFF 
    If FontName = "" Then FontName = "宋体" 
    If FontBold <> 0 Then FontBold = 1          '统一是否加粗 
    If FontColor > &HFFFFFF Or FontColor < 0 Then FontColor = 0 
    If FontSize < 1 Then FontSize = 12          '字体大小 
    If WordWidth < 0 Then WordWidth = 1        '字符间间隔 
    If WordHeight < 0 Then WordHeight = 5        '字符间间隔 
    If Left < 0 Then Left = 0 
    If Top < 0 Then Top = 0 
    If Right < 0 Then Right = 0 
    If Bottom < 0 Then Bottom = 0 
    '读取源文本文件 
    Dim strSrcData As String 
    strSrcData = strString 
    If strSrcData <> "" Then            '如果不为空 
        '初始化一个新的绘图 
        If modDrawDC.Init(Width, BackColor, FontName, FontSize, WordWidth, WordHeight, Left, Top, Right, Bottom) = 0 Then 
            GoTo ErrorTag 
        Else 
            Dim strFirst As String, strSecond As String, lngFontColor As Long, lngFontBold As Long, lngFontItalic As Long, lngFontUnderline As Long, lngFontStrikethru As Long, strFontName As String, lngEndPos As Long 
            Dim lngStartPos As Long 
            lngStartPos = 1 
            lngEndPos = 1 
            Do While True 
                If GetStyleString(strSrcData, lngStartPos, strFirst, strSecond, lngFontColor, lngFontBold, lngFontItalic, lngFontUnderline, lngFontStrikethru, strFontName, lngEndPos) = True Then 
                    '输出第一个字符串 
                    Dim strNowString As String, Pos As Long 
                    For Pos = 1 To Len(strFirst) 
                        strNowString = Mid$(strFirst, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strFirst, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                        End If 
                    Next Pos 
                    '输出第二个字符串 
                    For Pos = 1 To Len(strSecond) 
                        strNowString = Mid$(strSecond, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strSecond, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, IIf(lngFontColor = -1, FontColor, lngFontColor), IIf(lngFontBold = -1, FontBold, lngFontBold), IIf(lngFontItalic = -1, FontItalic, lngFontItalic), IIf(lngFontUnderline = -1, FontUnderline, lngFontUnderline), IIf(lngFontStrikethru = -1, FontStrikethru, lngFontStrikethru), IIf(strFontName = "", FontName, strFontName) 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, IIf(lngFontColor = -1, FontColor, lngFontColor), IIf(lngFontBold = -1, FontBold, lngFontBold), IIf(lngFontItalic = -1, FontItalic, lngFontItalic), IIf(lngFontUnderline = -1, FontUnderline, lngFontUnderline), IIf(lngFontStrikethru = -1, FontStrikethru, lngFontStrikethru), IIf(strFontName = "", FontName, strFontName) 
                        End If 
                    Next Pos 
                    If lngEndPos >= Len(strSrcData) Then        '如果达到最后一个字符了 
                        Exit Do 
                    End If 
                    lngStartPos = lngEndPos 
                Else            '如果没发现成对的字符串,则肯定是最后一段了,直接输出即可 
                    strFirst = Mid$(strSrcData, lngEndPos) 
                    For Pos = 1 To Len(strFirst) 
                        strNowString = Mid$(strFirst, Pos, 1) 
                        If strNowString = Chr$(13) Then         '是否是回车 
                            If Mid$(strFirst, Pos + 1, 1) = Chr$(10) Then           '是回车 
                                modDrawDC.NewLine 
                                Pos = Pos + 1 
                            Else 
                                modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                            End If 
                        Else 
                            modDrawDC.StringOut strNowString, FontColor, FontBold, FontItalic, FontUnderline, FontStrikethru, FontName 
                        End If 
                    Next Pos 
                    Exit Do 
                End If 
            Loop 
        End If 
    Else 
        GoTo ErrorTag 
    End If 
    '获得结果位图 
    Dim hBitmap As Long, bmWidth As Long, bmHeight As Long 
    hBitmap = modDrawDC.GetBitmap(bmWidth, bmHeight) 
    If hBitmap = 0 Then 
        StringToImage = 0 
        modDrawDC.Destory 
        Exit Function 
    Else 
        '保存位图到文图文件 
        If SaveBitmap.SaveBitmapAsToFile(hBitmap, App.Path + "\TempTempTempTTTT.bmp") = False Then 
            StringToImage = 0 
            modDrawDC.Destory 
            Exit Function 
        Else 
            Dim PicShow As IPictureDisp 
            Set PicShow = LoadPicture(App.Path + "\TempTempTempTTTT.bmp") 
            Kill App.Path + "\TempTempTempTTTT.bmp" 
            If CSavePicture1.SavePic(PicShow, TargetFile, Pic) = False Then 
                StringToImage = 0 
                modDrawDC.Destory 
                Exit Function 
            End If 
            Set PicShow = Nothing 
        End If 
    End If 
    modDrawDC.Destory 
    StringToImage = 1          '执行成功 
    Exit Function 
ErrorTag: 
    StringToImage = 0 
End Function 
 
'从startpos处获得style的两段数据,如果没有style,则strSecond="",样式例子:<style fontcolor:ffffff fontbold>内容</style> 
Private Function GetStyleString(strTxtData As String, lngStartPos As Long, strFirst As String, strSecond As String, FontColor As Long, FontBold As Long, FontItalic As Long, FontUnderline As Long, FontStrikethru As Long, strFontName As String, EndPos As Long) As Boolean 
    FontColor = -1          '用来区分是否设置 
    FontBold = -1           '用来区分是否设置 
    FontItalic = -1 
    FontUnderline = -1 
    FontStrikethru = -1 
    strFontName = "" 
    Dim strData As String 
    strData = LCase(strTxtData)         '全部转化为小写 
    Do While True 
        '找style 
        Dim StyleTagPos As Long 
        '先找'<style' 
        StyleTagPos = InStr(lngStartPos, strData, "<style") 
        If StyleTagPos = 0 Then GoTo NoStyleTag 
        '再找style的结束'>' 
        Dim StyleTagEndPos As Long 
        StyleTagEndPos = InStr(StyleTagPos, strData, ">") 
        If StyleTagEndPos = 0 Then GoTo NoStyleTag 
        '再找'</style>' 
        Dim EndStyleTagPos As Long 
        EndStyleTagPos = InStr(StyleTagEndPos, strData, "</style>") 
        If EndStyleTagPos = 0 Then GoTo NoStyleTag 
        Dim strProp As String 
        strProp = Mid$(strData, StyleTagPos, StyleTagEndPos - StyleTagPos + 1) 
        '找是否有fontcolor,fontbold,FontStrikethru,FontItalic,FontUnderline 
        '查找fontbold 
        Dim lngTempPos As Long 
        lngTempPos = InStr(1, strProp, "fontbold:") 
        If lngTempPos > 0 Then 
            If Mid$(strProp, lngTempPos + Len("fontbold:"), 1) = "0" Then 
                FontBold = 0 
            ElseIf Mid$(strProp, lngTempPos + Len("fontbold:"), 1) = "1" Then 
                FontBold = 1 
            End If 
        End If 
        '查找fontitalic 
        lngTempPos = InStr(1, strProp, "fontitalic:") 
        If lngTempPos > 0 Then 
            If Mid$(strProp, lngTempPos + Len("fontitalic:"), 1) = "0" Then 
                FontItalic = 0 
            ElseIf Mid$(strProp, lngTempPos + Len("fontitalic:"), 1) = "1" Then 
                FontItalic = 1 
            End If 
        End If 
        '查找fontunderline 
        lngTempPos = InStr(1, strProp, "fontunderline:") 
        If lngTempPos > 0 Then 
            If Mid$(strProp, lngTempPos + Len("fontunderline:"), 1) = "0" Then 
                FontUnderline = 0 
            ElseIf Mid$(strProp, lngTempPos + Len("fontunderline:"), 1) = "1" Then 
                FontUnderline = 1 
            End If 
        End If 
        '查找fontstrikethru 
        lngTempPos = InStr(1, strProp, "fontstrikethru:") 
        If lngTempPos > 0 Then 
            If Mid$(strProp, lngTempPos + Len("fontstrikethru:"), 1) = "0" Then 
                FontStrikethru = 0 
            ElseIf Mid$(strProp, lngTempPos + Len("fontstrikethru:"), 1) = "1" Then 
                FontStrikethru = 1 
            End If 
        End If 
        '查找fontcolor 
        lngTempPos = InStr(1, strProp, "fontcolor:") 
        If lngTempPos <> 0 Then 
            Dim Pos As Long 
            For Pos = lngTempPos + 10 To Len(strProp) 
                If Mid$(strProp, Pos, 1) = " " Or Mid$(strProp, Pos, 1) = ">" Then 
                    If Pos = lngTempPos + 10 Then 
                        Exit For 
                    Else 
                        FontColor = GetColorFromStr(Mid$(strProp, lngTempPos + 10, Pos - 1 - (lngTempPos + 10) + 1)) 
                        Exit For 
                    End If 
                End If 
            Next Pos 
        End If 
        '查找字体名称 
        lngTempPos = InStr(1, strProp, "fontname:") 
        If lngTempPos <> 0 Then 
            For Pos = lngTempPos + 9 To Len(strProp) 
                If Mid$(strProp, Pos, 1) = " " Or Mid$(strProp, Pos, 1) = ">" Then 
                    Exit For 
                End If 
            Next Pos 
            If Pos = lngTempPos + 9 Then 
                'do nothing 
            Else 
                strFontName = Mid$(strProp, lngTempPos + 9, Pos - (lngTempPos + 9)) 
            End If 
        End If 
        If FontColor = -1 And FontBold = -1 And FontItalic = -1 And FontUnderline = -1 And FontStrikethru = -1 And strFontName = "" Then 
            lngStartPos = EndStyleTagPos 
        Else 
            '获得结果串 
            strFirst = Mid$(strData, lngStartPos, StyleTagPos - 1 - lngStartPos + 1) 
            strSecond = Mid$(strData, StyleTagEndPos + 1, EndStyleTagPos - 1 - (StyleTagEndPos + 1) + 1) 
            '获得结束位置 
            EndPos = EndStyleTagPos + 8 
            GetStyleString = True 
            Exit Function 
        End If 
    Loop 
NoStyleTag: 
    GetStyleString = False 
End Function