DOS/V Power Report 1998 November/VPR9811A.BIN/VPR_DATA/Program/Vb/FormMain.frm

Text File | 1998-08-31 | 9KB | 277 lines

VERSION 5.00
Begin VB.Form FormMain
   BorderStyle     =   1  '固定(実線)
   Caption         =   "FormMain"
   ClientHeight    =   6465
   ClientLeft      =   585
   ClientTop       =   1140
   ClientWidth     =   9195
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6465
   ScaleWidth      =   9195
   Begin VB.CommandButton CommandCopy
      Caption         =   "Copy"
      Height          =   375
      Left            =   8040
      TabIndex        =   4
      Top             =   5400
      Width           =   1095
   End
   Begin VB.CommandButton CommandPaste
      Caption         =   "Paste"
      Height          =   375
      Left            =   8040
      TabIndex        =   3
      Top             =   960
      Width           =   1095
   End
   Begin VB.CommandButton CommandDataGenerate
      Caption         =   "データ作成"
      Height          =   375
      Left            =   8040
      TabIndex        =   2
      Top             =   2040
      Width           =   1095
   End
   Begin VB.TextBox TextMain
      BeginProperty Font
         Name            =   "ＭＳ ゴシック"
         Size            =   9
         Charset         =   128
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3495
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  '垂直
      TabIndex        =   1
      Top             =   2880
      Width           =   7815
   End
   Begin VB.TextBox TextSource
      BeginProperty Font
         Name            =   "ＭＳ ゴシック"
         Size            =   9
         Charset         =   128
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2655
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  '垂直
      TabIndex        =   0
      Top             =   120
      Width           =   7815
   End
End
Attribute VB_Name = "FormMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'改行ごとに切り分ける
Function StrCrLf(ByVal sourceStr As String, ByRef distStr As String, ByVal strPntOld As Integer) As Integer
    Dim strPointer As Integer

    If sourceStr = "" Then
        StrCrLf = -1    '文字列が空なら-1を返す
        Exit Function
    End If
    strPointer = InStr(strPntOld + 1, sourceStr, vbCrLf)

    If strPointer > 0 Then
        strPointer = strPointer - 1 '末尾が改行なら、改行分ポインターを前にずらす
    Else
        strPointer = Len(sourceStr) '文字列の末尾に改行がないなら、文字変数の末尾にポインターを置く
    End If
    If strPointer >= strPntOld Then  'ポインターが正常なら、現在行の文字列を切り取る
        distStr = Mid(sourceStr, strPntOld + 1, strPointer - strPntOld)
    Else
        StrCrLf = -1    '異常、あるいは文字変数の末尾までチェック済みなら、-1を返す
        Exit Function
    End If
    StrCrLf = strPointer + 2    'ポインターを改行分だけ後ろにずらす
End Function
'改行コード直前にある、不可視コードを削除
Function RemoveLineLastSpace(TextSource As String) As String
    Dim ptr As Long
    Dim strBuf As String

    ptr = Len(TextSource)
    Do While ptr > 0
        Select Case Mid(TextSource, ptr, 1)
            Case " ", "　", vbTab
                ptr = ptr - 1
            Case Else
                Exit Do
        End Select
    Loop
    RemoveLineLastSpace = Left(TextSource, ptr)
End Function
'行頭にある、不可視コードを削除
Function RemoveLineFirstSpace(TextSource As String) As String
    Dim ptrLast As Long
    Dim ptr As Long
    Dim strBuf As String

    ptrLast = Len(TextSource)
    ptr = 1
    Do While ptr < ptrLast
        Select Case Mid(TextSource, ptr, 1)
            Case " ", "　", vbTab
                ptr = ptr + 1
            Case Else
                Exit Do
        End Select
    Loop
    RemoveLineFirstSpace = Right(TextSource, ptrLast - ptr + 1)
End Function
'１行が指定文字数以上の単一の文字で埋められているかどうか
Function CheckUnificationCharactor(TextSource As String, valLimit As Integer) As Boolean
    Dim ptr As Long
    Dim strDistination As String

    If Len(TextSource) < valLimit Then
        CheckUnificationCharactor = False
        Exit Function
    End If

    strDistination = ""
    For ptr = 0 To valLimit - 1
        strDistination = strDistination + Right(TextSource, 1)
    Next ptr
    CheckUnificationCharactor = (Right(TextSource, 10) = strDistination)

End Function
'データ作成
Private Sub CommandDataGenerate_Click()
    Dim sourceText As String
    Dim distText As String
    Dim pointText As Integer
    Dim pointNew As Integer
    Dim bufText As String
    Dim lineBufText As String
    Dim tempText As String
    Dim flgAddCrLfBef As Boolean
    Dim flgAddCrLfPre As Boolean
    Dim flgAddCrLfPost As Boolean
    Dim strCond1(10) As String
    Dim strCond2(10) As String
    Dim strCond3(10) As String
    Dim booFS As Boolean
    Dim booCR As Boolean
    Dim booURL As Boolean
    Dim booChar As Boolean
    Dim valChar As Integer

    sourceText = TextSource.Text

    pointText = 0
    lineBufText = ""
    flgAddCrLfBef = True
    FormPref.getPref strCond1, strCond2, strCond3, booFS, booCR, booURL, booChar, valChar

    Do
        '一行取り出し
        pointNew = StrCrLf(sourceText, distText, pointText)
        If pointNew = -1 Then Exit Do
        pointText = pointNew
        flgAddCrLfPre = False
        flgAddCrLfPost = False

        lineBufText = RemoveLineLastSpace(distText)

        If booFS Then
            lineBufText = RemoveLineFirstSpace(lineBufText)
        End If

        '改行だけの行
        '改行だけの行を付加
        If booCR And (distText = "") Then
            flgAddCrLfPost = True
'            flgAddCrLfPre = True
        End If

        tempText = Left(distText, 1)
        '特定の文字が行頭の時に、前の行の行末に改行を付加
        '"　", " ", "■", "★", "▼", "○", "●", "※", vbTab
        '直前が改行だった場合は、改行を付加しない
        Select Case tempText
            Case strCond1(0), strCond1(1), strCond1(2), strCond1(3), strCond1(4), strCond1(5), strCond1(6), strCond1(7), strCond1(8)
                flgAddCrLfPre = True
        End Select

        '特定の文字が行頭の時に、行末に改行を付加
        '">", "＞", "■", "★", "▼", "○", "●":
        Select Case tempText
             Case strCond3(0), strCond3(1), strCond3(2), strCond3(3), strCond3(4), strCond3(5), strCond3(6)
                flgAddCrLfPost = True
        End Select

        '特定の文字が行末の時に、行末に改行を付加
        '"。", "．", "."    ")", "）", "」", "＞", ">":
        Select Case Right(distText, 1)
            Case strCond2(0), strCond2(1), strCond2(2), strCond2(3), strCond2(4), strCond2(5), strCond2(6), strCond2(7)
                flgAddCrLfPost = True
        End Select

        '一行が単一の文字で埋められている場合
        If booChar And CheckUnificationCharactor(lineBufText, valChar) Then
            flgAddCrLfPost = True
        End If

        'URLの場合
        If booURL And ("http://" = Left(lineBufText, 7)) Then
            flgAddCrLfPost = True
        End If

        '改行の付加
        If flgAddCrLfPre And (Not flgAddCrLfBef) Then
            bufText = bufText + vbCrLf
        End If
        bufText = bufText + lineBufText
        flgAddCrLfBef = False
        If flgAddCrLfPost Then
            bufText = bufText + vbCrLf
            flgAddCrLfBef = True
        End If
    Loop

    TextMain.Text = bufText

End Sub

Private Sub CommandCopy_Click()
    Clipboard.SetText TextMain.Text

End Sub
'クリップボードからペースト
Private Sub CommandPaste_Click()
    TextSource.Text = Clipboard.GetText

End Sub

Private Sub Form_Load()
    Top = GetSetting(App.Title, Me.Name, "Top", 0)
    Left = GetSetting(App.Title, Me.Name, "Left", 0)
    FormMain.Caption = App.Title
    FormPref.Show

End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveSetting App.Title, Me.Name, "Top", Top
    SaveSetting App.Title, Me.Name, "Left", Left
    Unload FormPref

End Sub