//安岡日記エディターソースコード

Option Explicit

Private Declare Function GetWindowsDirectory Lib "Kernel32.dll" Alias "
GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "Kernel32.dll" Alias "
GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "Kernel32.dll" Alias "GetTempPathA"
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal
hWndOwner As Long, ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pIDL As
Long, ByVal pszPath As String) As Long

Private Const CSIDL_DESKTOP As Long = &H0
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_CONTROLS As Long = &H3
Private Const CSIDL_PRINTERS As Long = &H4
Private Const CSIDL_PERSONAL As Long = &H5
Private Const CSIDL_FAVORITES As Long = &H6
Private Const CSIDL_STARTUP As Long = &H7
Private Const CSIDL_RECENT As Long = &H8
Private Const CSIDL_SENDTO As Long = &H9
Private Const CSIDL_BITBUCKET As Long = &HA
Private Const CSIDL_STARTMENU As Long = &HB
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Private Const CSIDL_DRIVES As Long = &H11
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_NETHOOD As Long = &H13
Private Const CSIDL_FONTS As Long = &H14
Private Const CSIDL_SHELLNEW As Long = &H15

Public Declare Function ShellExecute Lib "shell32.dll" _
  Alias "ShellExecuteA" _
  (ByVal hWnd As Long, _
  ByVal lpVerb As String, _
  ByVal lpFile As String, _
  ByVal lpParameters As String, _
  ByVal lpDirectory As String, _
  ByVal nShowCmd As Long) As Long

Sub FolderSearch(strPath As String, colFolder As Collection)
  Dim str1 As String
  Dim str2 As String

  If Right(strPath, 1) <> "\" Then
  strPath = strPath & "\"
  End If

  str1 = Dir(strPath, vbDirectory)

  Do Until str1 = ""
  If str1 = "." Or str1 = ".." Then
  Else
  If GetAttr(strPath & str1) And vbDirectory Then
  colFolder.Add strPath & str1
  Call FolderSearch(strPath & str1, colFolder)
  str2 = Dir(strPath, vbDirectory)
  Do Until str2 = str1
  str2 = Dir
  Loop
  End If
  End If
  str1 = Dir
  Loop
End Sub
------------------------------------------------------------------------------
--

Sub FileSearch(colFolder As Collection, colFile As Collection)
  Dim i As Integer
  Dim str As String
  Dim strPath As String

  For i = 1 To colFolder.Count
  strPath = colFolder.Item(i)
  If Right(strPath, 1) <> "\" Then
  strPath = strPath & "\"
  End If
  str = Dir(strPath, vbNormal)
  Do Until str = ""
  colFile.Add strPath & str
  str = Dir
  Loop
  Next
End Sub

------------------------------------------------------------------------------
--

Public Function GetWindowsFolderPath() As String
Dim path As String * 255
Dim Pathlen As Long

Pathlen = GetWindowsDirectory(path, Len(path))

GetWindowsFolderPath = Left(path, InStr(path, vbNullChar) - 1)
End Function
------------------------------------------------------------------------------
--

Public Function GetSystemFolderPath() As String
Dim path As String * 255
Dim Pathlen As Long

Pathlen = GetSystemDirectory(path, Len(path))

GetSystemFolderPath = Left(path, InStr(path, vbNullChar) - 1)
End Function
------------------------------------------------------------------------------
--

Public Function GetTempFolderPath() As String
Dim Buffer As String * 255
Dim Ret As Long
Dim path As String

Ret = GetTempPath(Len(Buffer), Buffer)
GetTempFolderPath = Left(Buffer, InStr(Buffer, vbNullChar) - 2)
End Function
------------------------------------------------------------------------------
--

Private Function GetSpecialFolderPath(ByVal hWnd, _
  ByVal Index As Long, _
  ByRef Buffer As String) As Long
Dim Ret As Long
Dim Location As Long
Dim path As String * 255


Ret = SHGetSpecialFolderLocation(ByVal hWnd, ByVal Index, Location)
 
If Ret = 0& Then
  Ret = SHGetPathFromIDList(Location, path)
  If Ret <> 0 Then
  Buffer = Left(path, InStr(path, vbNullChar) - 1)
  GetSpecialFolderPath = 0
  Else
  GetSpecialFolderPath = 1
  End If
Else
  GetSpecialFolderPath = 2
End If

End Function
------------------------------------------------------------------------------
--

Public Function GetDesktopFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_DESKTOP, GetDesktopFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetWinProgramFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_PROGRAMS, GetWinProgramFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetPersonalDocmentFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_PERSONAL, GetPersonalDocmentFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetFavoritesFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_FAVORITES, GetFavoritesFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetStartUpFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_STARTUP, GetStartUpFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetRecentFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_RECENT, GetRecentFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetSendToFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_SENDTO, GetSendToFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetStartMenuFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_STARTMENU, GetStartMenuFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetNetHoodFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_NETHOOD, GetNetHoodFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetFontsFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_FONTS, GetFontsFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetShellNewFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_SHELLNEW, GetShellNewFolderPath)
End Function
------------------------------------------------------------------------------
--


Public Function AddBS(path As String) As String
If Right(path, 1) <> "\" Then
  AddBS = path & "\"
Else
  AddBS = path
End If


End Function
------------------------------------------------------------------------------
--

Public Function GetHistoryFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_HISTORY, GetHistoryFolderPath)
End Function
------------------------------------------------------------------------------
--

Public Function GetProgramFilesFolderPath() As String
Dim Ret As Long
Ret = GetSpecialFolderPath(0, CSIDL_PROGRAMFILE, GetProgramFilesFolderPath)
End Function





Public Declare Function Unlha Lib "unlha32" ( _
  ByVal hWnd As Long, _
  ByVal szCmdLine As String, _
  ByVal szOutput As String, _
  ByVal dwSize As Long) As Long


Global strTitle As String
Global varfiledate As Variant
Global varfiledate2 As Variant

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


-------------------------Form1---------------------------------------
Option Explicit"Private Declare Function Unlha Lib "unlha32" ( _
  ByVal hWnd As Long, _
  ByVal szCmdLine As String, _
  ByVal szOutput As String, _
  ByVal dwSize As Long) As Long
<hr>"Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Command2_Click()
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
ChDir prg

Dim x As Variant
Dim y As Variant
Dim w As Variant
Dim ans As Integer
Dim cancel As Integer
Dim intErrNum As Variant
Dim strOutput As Variant
Dim strCmd As Variant
Dim rc As Variant
Dim mv As Variant

x = prg & "\Data\*.diary"
mv = prg & "\LHADiaryData.lzh"

ans = MsgBox("プロジェクトを保存します。よろしいですか？", 1)
Select Case ans
Case vbOK
: GoTo stepF1
Case vbCancel
cancel = True
Exit Sub
End Select

stepF1:

ChDir prg

On Error GoTo ErrHandler
 
  With CommonDialog1
  .CancelError = True
 
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowSave
  y = .FileName
 
  End With
 
 
  intErrNum = ERR.Number
 
  w = y
  If intErrNum <> cdlCancel Then
 
  strOutput = String(1000, 0)
  ChDir prg
 
  strCmd = "u LHADiaryData.lzh Data\*"
 
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  ChDir prg
  FileCopy mv, w
 
  GoTo LA
 
End If


LA:
rc = MsgBox("処理は正常に終了しました", vbOK)

ErrHandler:

End Sub
<hr>"Private Sub Command1_Click()
Form4.Show
End Sub
<hr>"Private Sub Command2_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Command3_Click()
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim w As Variant
Dim prg As String
Dim strOutput As String
  Dim strCmd As String
  Dim Ret As Variant
Dim ans As Integer
Dim cancel As Integer
Dim intErrNum As Variant
Dim rc As Variant
Dim mv As Variant

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"

mv = prg & "\LHADiaryData.lzh"

x = prg & "\Data\*"
z = prg & "Data"

ChDir prg
On Error GoTo ErrHandler

If Form1.Command7.Enabled = False Then
End
End If

Ret = MsgBox("プロジェクトを保存して終了しますか？", vbQuestion +
vbYesNoCancel, "確認")
Select Case Ret
Case vbYes
: GoTo StepYes
Case vbNo
: GoTo StepNo
Case vbCancel
: GoTo stepCancel

Exit Sub
End Select

StepYes:

ChDir prg

  On Error GoTo ErrHandler2
 
  With CommonDialog1
  .CancelError = True
 
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowSave
  y = .FileName
 
  End With
 
  On Error GoTo ErrHandler
  intErrNum = ERR.Number
 
  w = y
  If intErrNum <> cdlCancel Then
 
  strOutput = String(1000, 0)
  ChDir prg
 
  strCmd = "u LHADiaryData.lzh Data\*"
 
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  ChDir prg
  FileCopy mv, w
 
  GoTo LA
 
End If


LA:
rc = MsgBox("処理は正常に終了しました", vbOK)
ChDir prg
Kill x
Kill "LHADiaryData.lzh"
End



StepNo:
On Error Resume Next
ChDir prg
Kill x
ChDir prg
Kill "LHADiaryData.lzh"
End


ErrHandler:
End

ErrHandler2:

stepCancel:

End Sub
<hr>"Private Sub Command3_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Command4_Click()
Dim intErrNum As Integer
  Dim x As Variant
  Dim y As Variant
  Dim z As Variant
  Dim w As Variant
  Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\"
 
  ChDir prg
 
  On Error Resume Next
 
  With CommonDialog1
  .CancelError = True
  On Error GoTo ErrHandler
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowOpen
  y = .FileName
 
  End With
 
 
  intErrNum = ERR.Number
 
  On Error GoTo 0
 
  If intErrNum <> cdlCancel Then
  x = prg & "data\" & "diary.lzh"
  FileCopy y, x
 
  z = prg & "data"
 
  ChDir z
 
 
 
 
 
  Dim strOutput As String
  Dim strCmd As String
  Dim rc As Long
  Dim Ret As String
  Dim j As Long
  strOutput = String(1000, 0)
 
  strCmd = "e diary.lzh"
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  Kill "diary.lzh"
 
 
  End If
 
  Command7.Enabled = True
  Command6.Enabled = False
  Form1.mnew.Enabled = False
  Form1.mopen.Enabled = False
  Form1.msave.Enabled = True
  Form1.mclose.Enabled = True
  Form1.mend.Enabled = True
 
  Form3.Show
 
 

ErrHandler:
 
  Exit Sub
End Sub
<hr>"Private Sub Command4_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Command5_Click()
End
End Sub
<hr>"Private Sub Command6_Click()
Form6.Show
End Sub
<hr>"Private Sub Command6_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Command7_Click()
Dim x As Variant
Dim prg As String
Dim Ret As Variant

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
x = prg & "\Data\*"

On Error GoTo StepNo

Ret = MsgBox("プロジェクトを閉じます。よろしいですか？", vbYesNo, "確認")

Select Case Ret
Case Is = vbYes
: GoTo StepYes
Case Is = vbNo
: GoTo StepNo

End Select

StepYes:
ChDir prg
Kill x
Label1.Caption = ""
Command1.Enabled = False
Command2.Enabled = False
Command4.Enabled = True
Command6.Enabled = True
Command7.Enabled = False
Form1.msave.Enabled = False
Form1.mclose.Enabled = False
Form1.mnew.Enabled = True
Form1.mopen.Enabled = True
Form1.mwrite.Enabled = False
Form1.mchangeprojecttitle.Enabled = False
Form1.mchangepassword.Enabled = False

Unload Form2
Unload Form3
Unload Form4
Unload Form5
Unload Form6
Unload Form7

x = MsgBox("プロジェクトを閉じました", 0)

StepNo:



End Sub
<hr>"Private Sub Command7_MouseDown(Button As Integer, Shift As Integer, x
As Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Form_Load()
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\"
ChDir prg

Command2.Enabled = False
Command6.Enabled = True
Command7.Enabled = False
msave.Enabled = False
mclose.Enabled = False
Form1.mwrite.Enabled = False
Form1.mchangeprojecttitle.Enabled = False
Form1.mchangepassword.Enabled = False

On Error GoTo ErrHandler
MkDir "Data"
ErrHandler:
End Sub
<hr>"Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As
Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>"Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As
Single, y As Single)
If Button = vbRightButton Then
PopupMenu mfile
End If
End Sub
<hr>



Private Sub mchangepassword_Click()
Form9.Show
End Sub
<hr>"Private Sub mchangeprojecttitle_Click()
Form8.Show
End Sub
<hr>"Private Sub mclose_Click()
Dim x As Variant
Dim prg As String
Dim Ret As Variant

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
x = prg & "\Data\*"

On Error GoTo StepNo

Ret = MsgBox("プロジェクトを閉じます。よろしいですか？", vbYesNo, "確認")

Select Case Ret
Case Is = vbYes
: GoTo StepYes
Case Is = vbNo
: GoTo StepNo

End Select

StepYes:
ChDir prg
Kill x
Label1.Caption = ""
Command1.Enabled = False
Command2.Enabled = False
Command4.Enabled = True
Command6.Enabled = True
Command7.Enabled = False
Form1.msave.Enabled = False
Form1.mclose.Enabled = False
Form1.mnew.Enabled = True
Form1.mopen.Enabled = True
Form1.mwrite.Enabled = False
Form1.mchangeprojecttitle.Enabled = False
Form1.mchangepassword.Enabled = False

Unload Form2
Unload Form3
Unload Form4
Unload Form5
Unload Form6
Unload Form7

x = MsgBox("プロジェクトを閉じました", 0)

StepNo:


End Sub
<hr>"Private Sub mend_Click()
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim w As Variant
Dim prg As String
Dim strOutput As String
  Dim strCmd As String
  Dim Ret As Variant
Dim ans As Integer
Dim cancel As Integer
Dim intErrNum As Variant
Dim rc As Variant
Dim mv As Variant

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"

mv = prg & "\LHADiaryData.lzh"

x = prg & "\Data\*"
z = prg & "Data"

ChDir prg
On Error GoTo ErrHandler

If Form1.Command7.Enabled = False Then
End
End If

Ret = MsgBox("プロジェクトを保存して終了しますか？", vbQuestion +
vbYesNoCancel, "確認")
Select Case Ret
Case vbYes
: GoTo StepYes
Case vbNo
: GoTo StepNo
Case vbCancel
: GoTo stepCancel

Exit Sub
End Select

StepYes:

ChDir prg

  On Error GoTo ErrHandler2
 
  With CommonDialog1
  .CancelError = True
 
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowSave
  y = .FileName
 
  End With
 
  On Error GoTo ErrHandler
  intErrNum = ERR.Number
 
  w = y
  If intErrNum <> cdlCancel Then
 
  strOutput = String(1000, 0)
  ChDir prg
 
  strCmd = "u LHADiaryData.lzh Data\*"
 
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  ChDir prg
  FileCopy mv, w
 
  GoTo LA
 
End If


LA:
rc = MsgBox("処理は正常に終了しました", vbOK)
ChDir prg
Kill x
Kill "LHADiaryData.lzh"
End



StepNo:
On Error Resume Next
ChDir prg
Kill x
ChDir prg
Kill "LHADiaryData.lzh"
End


ErrHandler:
End

ErrHandler2:

stepCancel:

End Sub
<hr>"Private Sub mmake_Click()
Form6.Show
End Sub
<hr>"Private Sub mnew_Click()
Form6.Show
End Sub
<hr>"Private Sub mopen_Click()
Dim intErrNum As Integer
  Dim x As Variant
  Dim y As Variant
  Dim z As Variant
  Dim w As Variant
  Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\"
 
  ChDir prg
 
  On Error Resume Next
 
  With CommonDialog1
  .CancelError = True
  On Error GoTo ErrHandler
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowOpen
  y = .FileName
 
  End With
 
 
  intErrNum = ERR.Number
 
  On Error GoTo 0
 
  If intErrNum <> cdlCancel Then
  x = prg & "data\" & "diary.lzh"
  FileCopy y, x
 
  z = prg & "data"
 
  ChDir z
 
 
 
 
 
  Dim strOutput As String
  Dim strCmd As String
  Dim rc As Long
  Dim Ret As String
  Dim j As Long
  strOutput = String(1000, 0)
 
  strCmd = "e diary.lzh"
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  Kill "diary.lzh"
 
 
  End If
 
  Command7.Enabled = True
  Command6.Enabled = False
  Command4.Enabled = False
  Form1.mnew.Enabled = False
  Form1.mopen.Enabled = False
  Form1.msave.Enabled = True
  Form1.mclose.Enabled = True
  Form1.mend.Enabled = True
 
  Form3.Show
 
 

ErrHandler:
 
  Exit Sub
End Sub
<hr>"Private Sub msave_Click()
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
ChDir prg

Dim x As Variant
Dim y As Variant
Dim w As Variant
Dim ans As Integer
Dim cancel As Integer
Dim intErrNum As Variant
Dim strOutput As Variant
Dim strCmd As Variant
Dim rc As Variant
Dim mv As Variant

x = prg & "\Data\*.diary"
mv = prg & "\LHADiaryData.lzh"

ans = MsgBox("プロジェクトを保存します。よろしいですか？", 1)
Select Case ans
Case vbOK
: GoTo stepF1
Case vbCancel
cancel = True
Exit Sub
End Select

stepF1:

ChDir prg

On Error GoTo ErrHandler
 
  With CommonDialog1
  .CancelError = True
 
  .Flags = cdlOFNPathMustExist
  .InitDir = prg
  .ShowSave
  y = .FileName
 
  End With
 
 
  intErrNum = ERR.Number
 
  w = y
  If intErrNum <> cdlCancel Then
 
  strOutput = String(1000, 0)
  ChDir prg
 
  strCmd = "u LHADiaryData.lzh Data\*"
 
  rc = Unlha(Me.hWnd, strCmd, strOutput, Len(strOutput))
 
  ChDir prg
  FileCopy mv, w
 
  GoTo LA
 
End If


LA:
rc = MsgBox("処理は正常に終了しました", vbOK)

ErrHandler:

End Sub
<hr>"Private Sub mwrite_Click()
Form4.Show
End Sub

-------------------------Form2---------------------------------------
Private Sub Command1_Click()
On Error GoTo ERR
With Form2.CommonDialog1
.CancelError = True
.Flags = cdlPDHidePrintToFile Or cdlPDNoSelection
.ShowPrinter
End With"With Printer
With .Font
.Size = 15
End With
End With

Printer.Print RichTextBox1.Text
Printer.EndDoc
ERR:
End Sub
<hr>"Private Sub Command2_Click()
Form4.Show
End Sub
<hr>"Private Sub Command3_Click()
On Error GoTo ERR
With Form2.CommonDialog1
.CancelError = True
.Flags = cdlPDPrintSetup
.ShowPrinter
End With

ERR:

End Sub
<hr>"Private Sub Form_Load()
RichTextBox1.Locked = True
Text1.Locked = True


Dim x As String
Dim y As Variant
Dim z As Variant
Dim w As Variant
Dim q As Variant
Dim m As Variant"Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data"
ChDir prg

Debug.Print strTitle

On Error GoTo ErrHandler
Open strTitle ForInputAs #175
Do Until EOF(175)
LineInput #175, m
Loop
Close #175

Text1.Text = m



ErrHandler:

Text1.Text = m

End Sub"

-------------------------Form3---------------------------------------

Private Sub Command1_Click()
On Error Resume Next
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data"
ChDir prg

Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim w As Variant
Dim q As Variant
Dim j As Long
Dim p As String
Dim ypass As String
Dim inpass As String
Dim m As String

inpass = Form3.Text1.Text

m = prg & "\title.title"
  Open m ForInputAs #155
  LineInput #155, p
  Close #155

x = prg & "\password.dat"
z = prg & "\" & "*"
Open x ForInputAs #1
LineInput #1, ypass
Close #1

Debug.Print ypass
Debug.Print inpass

Select Case inpass

Case Is <> ypass
On Error Resume Next
Kill z
w = MsgBox("パスワードが違います。プログラムを強制終了します", 0)
End"Case Is = ypass

Form7.Show
Form5.Show

Form5.Label1.Caption = "日記データを読み込み中"
Form5.ProgressBar1.Visible = True
Form5.ProgressBar1.Max = 5000
For j = 1 To 5000
Form5.ProgressBar1.Value = j
Next j
Form5.ProgressBar1.Visible = False
Unload Form5

Form1.Command1.Enabled = True
Form1.mwrite.Enabled = True
Form1.Command2.Enabled = True

Form1.Label1.Caption = p
Form1.Command4.Enabled = False
Form1.mchangeprojecttitle.Enabled = True
Form1.mchangepassword.Enabled = True

Unload Me

End Select


End Sub"
-------------------------Form4---------------------------------------
Private Sub Command1_Click()

Unload Form7

Dim z As Variant
Dim x As Variant
Dim y As Variant
Dim w As Variant
Dim MB As Variant
Dim prg As String
Dim dpr As String
Dim strTargetDir As Variant
Dim strDirItem As Variant
 
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
dpr = prg & "\Data\"

z = Split(DTPicker1.Value, "/")
y = dpr & z(0) & "-" & z(1) & "-" & z(2) & ".diary"
x = dpr & z(0) & "-" & z(1) & "-" & z(2) & "-title.title"

MB = MsgBox("上記の内容を日記欄に保存します。よろしいですか？", vbYesNo)
Select Case MB
Case Is = vbYes
w = Text1.Text
Open x For Output As #1
Print #1, w
Close #1

RichTextBox1.SaveFile y, rtfText


Form7.List1.Clear

strTargetDir = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data\*.diary"
 
  strDirItem = Dir(strTargetDir)
  Do While strDirItem <> ""
 
  x = Split(strDirItem, ".")
  On Error Resume Next
  y = x(0)
  z = Split(y, "-")
 
  w = z(0) & "年" & z(1) & "月" & z(2) & "日"
  Form7.List1.AddItem w
 
 
  strDirItem = Dir
 
 
  Loop


Form5.Show
Form5.ProgressBar1.Visible = True
Form5.ProgressBar1.Max = 1500
For j = 1 To 1500
Form5.ProgressBar1.Value = j
Next j
Form5.ProgressBar1.Visible = False
Unload Form5

Form7.Show

Unload Me

Case Is = vbNo

End Select"End Sub
<hr>"Private Sub Command2_Click()
Unload Me
End Sub
<hr>"Private Sub DTPicker1_Change()
Dim z As Variant
Dim za As Variant
Dim xa As Variant
Dim ya As Variant
Dim w As Variant
Dim MB As Variant
Dim prg As String
Dim dpr As String


z = Split(DTPicker1.Value, "/")
Label3.Caption = "現在" & z(0) & "年" & z(1) & "月" & z(2) & "日の日記書き込み
欄が選択されています。"

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data\"
dpr = prg & "\Data\"
ChDir prg

ya = prg & z(0) & "-" & z(1) & "-" & z(2) & ".diary"
xa = prg & z(0) & "-" & z(1) & "-" & z(2) & "-title.title"

Debug.Print ya

On Error GoTo ErrHandler

Open xa ForInputAs #1
Do Until EOF(1)
LineInput #1, w
Loop
Close #1
Form4.Text1.Text = w

w = RichTextBox1.Text
RichTextBox1.LoadFile ya

GoTo Step1

ErrHandler:

Text1.Text = ""
RichTextBox1.Text = ""

Step1:

 
End Sub
<hr>"Private Sub Form_Load()
Dim x As String
Dim y As Variant
Dim z As Variant

Unload Form2

DTPicker1.Value = Date
x = Date
y = Split(x, "/")
Label2.Caption = "現在のシステムの日付は" & y(0) & "年" & y(1) & "月" & y(2)
& "日です。"

z = Split(DTPicker1.Value, "/")
Label3.Caption = "現在" & z(0) & "年" & z(1) & "月" & z(2) & "日の日記書き込み
欄が選択されています。"



Dim za As Variant
Dim xa As Variant
Dim ya As Variant
Dim w As Variant
Dim MB As Variant
Dim prg As String
Dim dpr As String

prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
dpr = prg & "\Data\"

za = Split(DTPicker1.Value, "/")
ya = dpr & za(0) & "-" & za(1) & "-" & za(2) & ".diary"
xa = dpr & za(0) & "-" & za(1) & "-" & za(2) & "-title.title"

On Error GoTo ErrHandler
Open xa ForInputAs #1
Do Until EOF(1)
LineInput #1, w
Loop
Close #1
Form4.Text1.Text = w

RichTextBox1.LoadFile ya

ErrHandler:

End Sub
<hr>"Private Sub mcopy_Click()
With RichTextBox1
If .SelLength > 0 Then
Clipboard.SetText .SelText
End If
End With
End Sub
<hr>"Private Sub mcut_Click()
With RichTextBox1
If .SelLength > 0 Then
Clipboard.SetText .SelText
.SelText = ""
End If
End With
End Sub
<hr>"Private Sub mdelete_Click()
With RichTextBox1
If .SelLength > 0 Then
.SelText = ""
End If
End With
End Sub
<hr>"Private Sub mpaste_Click()
If Clipboard.GetText <> "" Then
RichTextBox1.SelText = Clipboard.GetText
End If
End Sub
<hr>"Private Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer,
x As Single, y As Single)
If Button = vbRightButton Then
PopupMenu medit
End If
End Sub

-------------------------Form5---------------------------------------
Private Sub ProgressBar1_MouseDown(Button As Integer, Shift As Integer, x As
Single, y As Single)
Unload Me
End Sub

-------------------------Form6---------------------------------------
Private Sub Command1_Click()

Dim x As Variant
Dim y As Variant
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
ChDir prg

If Text1.Text = "" Then
x = MsgBox("タイトルを入力してください", vbOKOnly)
End If"If Text2.Text = "" Then
x = MsgBox("パスワードを入力してください", vbOKOnly)
End If

y = Text1.Text
x = prg & "\Data\title.title"

Open x For Output As #1
Print #1, y
Close #1

y = Text2.Text
x = prg & "\Data\password.dat"
Open x For Output As #1
Print #1, y
Close #1

Form1.Label1.Caption = Form6.Text1.Text
Form1.Command6.Enabled = False
Form1.Command4.Enabled = False
Form1.Command1.Enabled = True
Form1.Command2.Enabled = True
Form1.Command3.Enabled = True
Form1.Command7.Enabled = True
Form1.msave.Enabled = True
Form1.mclose.Enabled = True
Form1.mend.Enabled = True
Form1.mnew.Enabled = False
Form1.mopen.Enabled = False
Form1.mwrite.Enabled = True
Form1.mchangeprojecttitle.Enabled = True
Form1.mchangepassword.Enabled = True

x = MsgBox("あなたのパスワードは" & y & "です。" & "パスワードは貴方の大切な日
記を他人から保護する大切なものです。忘れると二度と閲覧できませんので大切に保管
してください。", vbOKOnly)
Unload Me



End Sub
<hr>"Private Sub Command2_Click()
Unload Me
End Sub

-------------------------Form7---------------------------------------
Private Sub Form_Load()
Dim strTargetDir As Variant
  Dim strDirItem As Variant
  Dim x As Variant
  Dim y As Variant
  Dim z As Variant
  Dim w As Variant
  strTargetDir = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data\*.diary
"
 
  strDirItem = Dir(strTargetDir)
  Do While strDirItem <> ""
 
  x = Split(strDirItem, ".")
  On Error Resume Next
  y = x(0)
  z = Split(y, "-")
 
  w = z(0) & "年" & z(1) & "月" & z(2) & "日"
  Form7.List1.AddItem w
 
 
  strDirItem = Dir
 
 
  Loop
 
End Sub
<hr>"Private Sub List1_Click()
Dim x As String
Dim y As String
Dim z As String
Dim w As Variant
Dim q As String
Dim p As String
Dim s As Variant
Dim m As Variant"Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor\Data"

On Error GoTo ErrHandler
ChDir prg

Unload Form2

x = List1.List(List1.ListIndex)

z = Mid(x, 1, 4)
w = Mid(x, 6, 2)
q = Mid(x, 9, 2)

p = z & "-" & w & "-" & q & ".diary"
strTitle = z & "-" & w & "-" & q & "-title.title"



y = x & ".diary"

Form2.Show
Form2.Caption = x & "の日記"
Form2.Label1.Caption = x & "の日記"
Form2.RichTextBox1.LoadFile p


ErrHandler:


End Sub

-------------------------Form8---------------------------------------
Private Sub Command1_Click()
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
ChDir prg
On Error GoTo ERR
Dim x As String
Dim y As Variant
Dim z As Variant


x = prg & "\Data\title.title"
y = Text1.Text

z = MsgBox("上記の内容でプロジェクトタイトルを変更します。よろしいですか？",
vbYesNo)

If z = vbYes Then
Open x For Output As #1
Print #1, y
Close #1
z = MsgBox("保存処理は無事に終了しました。", vbOKOnly)
Form1.Label1.Caption = y
GoTo LE
End If"If z = vbNo Then
GoTo LE
End If

ERR:
z = MsgBox("保存処理中エラーが発生しました。", vbOKOnly)
Unload Me

LE:
Unload Me

End Sub
<hr>"Private Sub Command2_Click()
Unload Me
End Sub

-------------------------Form9---------------------------------------
Private Sub Command1_Click()
Dim prg As String
prg = Environ("ProgramFiles") & "\YasuokaDiaryEditor"
ChDir prg
On Error GoTo ERR
Dim x As String
Dim y As Variant
Dim z As Variant


x = prg & "\Data\password.dat"
y = Text1.Text

z = MsgBox("新しいパスワードを" & y & "に変更します。よろしいですか？",
vbYesNo)

If z = vbYes Then
Open x For Output As #1
Print #1, y
Close #1
z = MsgBox("パスワードを" & y & "に変更しました。パスワードは貴方の大切な日記
を他人から保護する大切なものです。忘れると二度と閲覧できませんので大切に保管し
てください。", vbOKOnly)
z = MsgBox("プロジェクトを保存するまでパスワードの変更は設定に反映されません。
御注意ください。", vbOKOnly)
GoTo LE
End If"If z = vbNo Then
GoTo LE
End If

ERR:
z = MsgBox("パスワード変更中にエラーが発生しました。", vbOKOnly)
Unload Me

LE:
Unload Me
End Sub
<hr>"Private Sub Command2_Click()
Unload Me
End Sub