form1.frm

加密文本编辑器 VB

IntType = 1
Form3.Show 1
End Sub
Private Sub copy_Click()
CopyIt
End Sub
Private Sub csetup_Click()
Form4.Show 1
End Sub
Private Sub Cut_Click()
CutIt
End Sub
Private Sub exit_Click()
Unload Me
End
End Sub
Private Sub find_Click()
If Text1.SelText <> "" Then
With Form2.Text1
.SelText = Form1.Text1.SelText
End With
findtext = Form2.Text1.Text

End If
gfristTime = True
Form2.Show
End Sub
Private Sub findnext_Click()
If findtext = "" Then
Form2.Show
Else
FindIt
End If
End Sub
Private Sub Form_Load()
Dim myini As String
myini = App.Path & "\me.ini"
q: mbackcolor = GetProfile(myini, "database", "mbackcolor")
mforecolor = GetProfile(myini, "database", "mforecolor")
mfontsize = GetProfile(myini, "database", "mfontsize")
mfontname = GetProfile(myini, "database", "mfontname")
mheight = GetProfile(myini, "database", "mheight")
mtop = GetProfile(myini, "database", "mtop")
mleft = GetProfile(myini, "database", "mleft")
mwidth = GetProfile(myini, "database", "mwidth")
With Text1
.BackColor = mbackcolor
.ForeColor = mforecolor
.FontSize = mfontsize
.FontName = mfontname
End With
With Form1
.Top = mtop
.Height = mheight
.Left = mleft
.Width = mwidth
End With
GoTo b
b:
NewFile

End Sub
Private Sub Form_Resize()
Dim change As Boolean
change = True
If Form1.Height <= 1080 Then
change = False
Else: change = True
End If
On Error GoTo 1
If change = True Then
Text1.Height = Form1.ScaleHeight - 420
Text1.Width = Form1.ScaleWidth
ElseIf change = False Then
Text1.Height = Form1.ScaleHeight
Text1.Width = Form1.ScaleWidth
End If
1: Exit Sub
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim myini As String
myini = App.Path & "\me.ini"
If dirty = True Then
s = MsgBox(filename & "文件未保存" & Chr$(13) & "保存吗?", vbYesNoCancel, "为保存")
Select Case s
Case 6
SaveFile
Case 7
Cancel = 0
Case 2
Cancel = 1
End Select
End If
mbackcolor = Form1.Text1.BackColor
mforecolor = Form1.Text1.ForeColor
mfontsize = Form1.Text1.FontSize
mfontname = Form1.Text1.FontName
mheight = Form1.Height
mtop = Form1.Top
mleft = Form1.Left
mwidth = Form1.Width
 setProfile myini, "database", "mbackcolor", mbackcolor
 setProfile myini, "database", "mforecolor", mforecolor
 setProfile myini, "database", "mfontsize", mfontsize
setProfile myini, "database", "mfontname", mfontname
setProfile myini, "database", "mheight", mheight
setProfile myini, "database", "mleft", mleft
setProfile myini, "database", "mtop", mtop
setProfile myini, "database", "mwidth", mwidth

End

End Sub
Private Sub fsetup_Click()
Dialog1.CancelError = True
On Error GoTo ErrHandler
Dialog1.Flags = cdlCFBoth
Dialog1.ShowFont
Text1.Font.Name = Dialog1.FontName
Text1.Font.Size = Dialog1.FontSize
Text1.Font.Bold = Dialog1.FontBold
ErrHandler:
Exit Sub
End Sub
Private Sub looklong_Click()
 Dim filelong, filesize As Long
  mytext = Form1.Text1.Text
  filelong = Len(mytext)
 filesize = Int(filelong / 1024)
say = "文件长度" & filelong & "字节" & Chr$(13) & "文件大小" & filesize & "KB"
MsgBox say, , "据统计"
End Sub
Private Sub new_Click()
NewFile
End Sub
Private Sub open1_Click()
getFileName
If toobig = True Then GoTo v
openfile
v: Form1.Caption = myName & "-" & filename
End Sub

Private Sub open2_Click()
getFileName
If toobig = True Then GoTo v
openfile
v: Form1.Caption = myName & "-" & filename
IntType = 3
Form3.Show
End Sub
Private Sub paste_Click()
PasteIt
End Sub
Private Sub save1_Click()
SaveFile
End Sub

Private Sub save2_Click()
IntType = 2
Form3.Show
End Sub

Private Sub saveas_Click()
Dim falsename
falsename = filename
filename = ""
SaveFile
If filename = "" Then filename = falsename
End Sub
Private Sub selecttoall_Click()
selectall
End Sub
Private Sub Text1_Change()
dirty = True
If Text1.Text = "" Then
dirty = False
End If
End Sub
Private Sub TIMEorDATE_Click()
    Form1.Text1.SelText = Now
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "open"
open1_Click
Case "help"
about_Click
Case "save"
save1_Click
Case "new"
new_Click
Case "copy"
CopyIt
Case "cut"
CutIt
Case "paste"
PasteIt
Case "TIMEorDATE"
TIMEorDATE_Click
Case "font"
fsetup_Click
Case "color"
csetup_Click
Case "find"
find_Click
Case "lock text"
addm_Click
Case "unlock text"
uaddm_Click
Case "lock save"
save2_Click
Case "lock open"
open2_Click
End Select
End Sub
 Function setProfile(strFileName As String, strSection As String, strName As String, strSave) As Boolean
  
  
  Dim strTemp As String
  Dim strfileback As String
  Dim strreturn As String
  strfileback = App.Path & "\me.tmp"
  
  Open strFileName For Input As #1
  Open strfileback For Output As #2
   Do While Not EOF(1)
    Line Input #1, strTemp
    strreturn = strTemp
    Print #2, strreturn
    If InStr(1, Trim(strTemp), "[") <> 0 Then
      If InStr(1, Trim(strTemp), Trim(strSection)) <> 0 Then
        Do While Not EOF(1)
            Line Input #1, strTemp
            If InStr(1, Trim(strTemp), Trim(strName)) <> 0 Then Exit Do  '找到所要修改的字段值
            strreturn = strTemp
            Print #2, strreturn
         Loop
         strreturn = strName & "=" & strSave
         Print #2, strreturn
      End If
    End If
   Loop
  Close #1
  Close #2
  Open strfileback For Input As #1
  Open strFileName For Output As #2
  Do While Not EOF(1) And EOF(2)
  Line Input #1, strreturn
   Print #2, strreturn
  Loop
  Close #1
  Close #2
Kill (strfileback)
End Function
Function GetProfile(strFileName As String, strSection As String, strName)
     Dim strcharA As String
     Dim strcharB As String
     strSectionTemp = ""
   strNameTemp = ""
   strreturn = ""
   On Error GoTo ErrSrchSection
   Open strFileName For Input As #1
     Do While Not EOF(1)
        strcharA = Input(1, #1)
        If strcharA = "[" Then
           Do While Not EOF(1)
             strcharB = Input(1, #1)
             If strcharB = "]" Then Exit Do
             strSectionTemp = strSectionTemp & strcharB
           Loop
        End If
        If strSectionTemp = strSection Then
          strcharA = Input(2, #1)
          Exit Do
        Else
          strSectionTemp = ""
        End If
     Loop
 On Error GoTo ErrReadFile
  
aa:
    strNameTemp = ""
    Do While Not EOF(1)
      strcharA = Input(1, #1)
      If strcharA <> "=" Then
        strNameTemp = strNameTemp & strcharA  '得到名称
      Else
        Exit Do
      End If
    Loop
        If strNameTemp = strName Then
       Line Input #1, strreturn  '如果找到与它匹配的字段名，就返回得到的值
    Else
       Line Input #1, strreturn  '如果未找到与它匹配的字段名，就继续找
       GoTo aa
    End If
    Close #1
    GetProfile = strreturn
    Exit Function
ErrReadFile:
    Dim inrRet As Integer
    intret = MsgBox("在文件中没有找到所要查找的字段", vbAbortRetryIgnore, "错误信息")
    Select Case intret
       Case vbAbort
          GetProfile = ""
          Close #1
          Exit Function
       Case vbRetry
          Resume
       Case vbIgnore
          Resume Next
     End Select
ErrSrchSection:
     MsgBox "文件出错", vbOKOnly
     GetProfile = ""
     Close #1
End Function

Private Sub uaddm_Click()
IntType = 1
Form3.Show 1
End Sub