CherryTreeProxy.VBS

'====================================================================
' AJPapps - CherryTree proxy
' Линда Кайе 2015. Посвящается Ариэль
'
' Этот скрипт призван бороться с непониманием программой CherryThree
' кириллицы в командной строке. Например, если попытаться открыть
' через командную строку (или ассоциации) файл "Вишня.CTD",
' то CherryTree запустится и покажет пустой документ вместо того,
' который мы хотели открыть. Чтобы исправить такое поведение,
' следует запускать данный скрипт и с именем файла в командной
' строке, а уж он сам запустит CherryTree.
'
' Скрипт действует следующим образом. Получая имя файла через
' командную строку, от открывает конфиг CherryTree, записывает это
' имя как последний открытый файл, а заодно включает открытие
' последнего файла при запуске программы. Далее скрипт запускает
' CherryTree. Запущенная программа проверяет конфиг и открывает
' указанный скриптом файл. Работа скрипта на этом завершается.
' Если в процессе произойдут какие-либо ошибки, скрипт сообщит о них
' и прервёт работу.
'
' Если имя передаваемого файла содержит пробелы, то его следует
' заключить в кавычки.
'
' ВНИМАНИЕ! Перед началом работы скрипта рекомендуется создать
' резервную копию конфига CherryTree. Это файл config.cfg в каталоге
' программы (при портабельной установке), либо где-то в AppData.
'
' Также перед использованием придётся немного поправить сам скрипт.
' Необходимо модифицировать значения следующих констант:
'
' • CFG_FILE_NAME - здесь указывается полное имя файла конфига,
'                   файл config.cfg.
' • EXE_FILE_NAME - здесь указывается полное имя исполняемого файла
'                   CherryTree, файл cherrytree.exe.
'
' Данные константы уже заполнены какими-то значениями, поэтому их
' придётся лишь аккуратно их поправить.
'
' • 24.03.2015
'   Первая версия ^^
'
'====================================================================
' Маленький копирайт
'
' 1. Программа и исходный код распространяются бесплатно.
' 2. Вы имеете право распространять их на тех же условиях.
' 3. Вы не имеете права использовать имя автора после модификации
'    исходного кода.
' 4. При этом желательно указывать ссылку на автора оригинальной
'    версии исходного кода.
' 5. Вы не имеете права на платное распространение исходного кода,
'    а также программных модулей, содержащих данный исходнй код.
' 6. Программа и исходный код распространяются как есть. Автор не
'    несёт ответственности за любые трагедии или несчастные случаи,
'    вызванные использованием программы и исходного кода.
' 7. Для любого пункта данного соглашения может быть сделано
'    исключение с разрешения автора программы.
' 8. По любым вопросам, связанным с данной программой, обращайтесь
'    по адресу lindaoneesama@gmail.com
'
' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/
'====================================================================
Option Explicit

Const AppTitle = "AJPapps - CherryTree proxy"

Const CFG_FILE_NAME = "Y:\PortableApps.10000\Cherrytree\bin\config.cfg"
Const EXE_FILE_NAME = "Y:\PortableApps.10000\Cherrytree\bin\cherrytree.exe"

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

Dim FSO

DoIt

'====================================================================
Private Sub DoIt()
  Dim DocFileName

  Set FSO = CreateObject("Scripting.FileSystemObject")

  Select Case WScript.Arguments.Count
    Case 0
      DocFileName = ""
    Case 1
      DocFileName = Trim(WScript.Arguments(0))
    Case Else
      MsgBox "Использование: CherryTreeProxy.VBS [FileName]", vbExclamation, AppTitle
      Exit Sub
  End Select

  If DocFileName = "/?" Then
    MsgBox "Использование: CherryTreeProxy.VBS [FileName]", vbInformation, AppTitle
    Exit Sub
  End If

  If DocFileName <> "" Then _
    If Not ModifyCherryTreeConfig(DocFileName) Then Exit Sub

  RunCherryTree
End Sub

'====================================================================
Private Function ModifyCherryTreeConfig(ByVal DocFileName)
  Dim File
  Dim DocFileNameOnly
  Dim DocFilePath
  Dim TXT

  On Error Resume Next

  ModifyCherryTreeConfig = False

  Set File = FSO.GetFile(DocFileName)
  If Err.Number <> 0 Then
    MsgBox DocFileName & vbCrLf & vbCrLf & _
           "Файл не найден.", vbCritical, AppTitle
    Exit Function
  End If

  If Not SplitFileName(File.Path, DocFilePath, DocFileNameOnly) Then
    MsgBox DocFileName & vbCrLf & vbCrLf & _
           "Не удалось разбить имя файла.", vbCritical, AppTitle
    Exit Function
  End If

  TXT = GetFile(CFG_FILE_NAME)
  If Err.Number <> 0 Then
    MsgBox CFG_FILE_NAME & vbCrLf & vbCrLf & _
           "Не удалось прочитать конфиг CherryTree.", vbCritical, AppTitle
    Exit Function
  End If

  ' [Debug] MsgBox TXT

  TXT = InsertStringsToCherryTreeConfig(TXT, DocFilePath, DocFileNameOnly)
  If TXT = "" Then Exit Function

  ' [Debug] MsgBox TXT

  PutFile CFG_FILE_NAME, TXT
  If Err.Number <> 0 Then
    MsgBox CFG_FILE_NAME & vbCrLf & vbCrLf & _
           "Не удалось записать конфиг CherryTree.", vbCritical, AppTitle
    Exit Function
  End If

  ModifyCherryTreeConfig = True
End Function

'====================================================================
Private Function SplitFileName(ByVal FullFileName, _
                               ByRef DocFilePath, _
                               ByRef DocFileNameOnly)
  Dim RC

  SplitFileName = False

  RC = InStrRev(FullFileName, "\")
  If RC = 0 Then Exit Function

  DocFilePath = Left(FullFileName, RC)
  If Len(DocFilePath) <= 1 Then Exit Function

  DocFileNameOnly = Mid(FullFileName, RC + 1)
  If Len(DocFileNameOnly) <= 0 Then Exit Function

  SplitFileName = True
End Function

'====================================================================
Private Function GetFile(ByVal FileName)
  Dim Stream

  Set Stream = FSO.OpenTextFile(FileName, ForReading, False, False)
  GetFile = Stream.ReadAll()
  Stream.Close

  GetFile = Utf8ToChar(GetFile)
End Function

'====================================================================
Private Sub PutFile(ByVal FileName, ByVal Data)
  Dim Stream

  Data = CharToUtf8(Data)

  Set Stream = FSO.OpenTextFile(FileName, ForWriting, True, False)
  Stream.Write Data
  Stream.Close
End Sub

'====================================================================
' file_dir = ...
' file_name = ...
' reload_doc_last = True
'====================================================================
Private Function InsertStringsToCherryTreeConfig(ByVal ConfigText, _
                                                 ByVal DocFilePath, _
                                                 ByVal DocFileNameOnly)
  Dim Lines
  Dim TMP

  InsertStringsToCherryTreeConfig = ""

  Lines = Split(ConfigText, vbLf)
  For TMP = LBound(Lines) To UBound(Lines)
    If LCase(Left(Lines(TMP), 10)) = "file_dir =" Or _
       LCase(Left(Lines(TMP), 9)) = "file_dir=" Then
      Lines(TMP) = "file_dir = " & DocFilePath

    ElseIf LCase(Left(Lines(TMP), 11)) = "file_name =" Or _
           LCase(Left(Lines(TMP), 10)) = "file_name=" Then
      Lines(TMP) = "file_name = " & DocFileNameOnly

    ElseIf LCase(Left(Lines(TMP), 17)) = "reload_doc_last =" Or _
           LCase(Left(Lines(TMP), 16)) = "reload_doc_last=" Then
      Lines(TMP) = "reload_doc_last = True"
    End If
  Next

  InsertStringsToCherryTreeConfig = Join(Lines, vbLf)
End Function

'====================================================================
Private Sub RunCherryTree()
  Dim WShell
  Dim RC

  Set WShell = CreateObject("WScript.Shell")

  On Error Resume Next

  RC = WShell.Run("""" & EXE_FILE_NAME & """", 10, False)
  If Err.Number <> 0 Then
    MsgBox EXE_FILE_NAME & vbCrLf & vbCrLf & _
           "Не удалось запустить CherryTree.", vbCritical, AppTitle
  End If
End Sub

'====================================================================
' Перекодировка с использованием встроенного объекта.
' Найдено тут: http://forum.script-coding.com/viewtopic.php?id=1179
'====================================================================
Private Function CharToOem(ByVal Text)
  CharToOem = CharTranslate(Text, "windows-1251", "cp866")
End Function

Private Function OemToChar(ByVal Text)
  OemToChar = CharTranslate(Text, "cp866", "windows-1251")
End Function

Private Function CharToUtf8(ByVal Text)
  CharToUtf8 = CharTranslate(Text, "windows-1251", "utf-8")

  ' Удаляем UTF-8 сигнатуру, которая на самом деле в данном случае
  ' не нужна. Если пишем файл, то будем писать её отдельно, там,
  ' где файл пишется...
  If Left(CharToUtf8, 3) = Chr(&HEF) & Chr(&HBB) & Chr(&HBF) Then _
    CharToUtf8 = Mid(CharToUtf8, 4)
End Function

Private Function Utf8ToChar(ByVal Text)
  Utf8ToChar = CharTranslate(Text, "utf-8", "windows-1251")
End Function

'====================================================================
' Общая функция перекодировки из чего угодно во что угодно.
'====================================================================
Function CharTranslate(ByVal Text, _
                       ByVal SourceCharset, _
                       ByVal DestCharset)
  Dim Stream

  Set Stream = CreateObject("ADODB.Stream")
  Stream.Type = 2
  Stream.Mode = 3
  Stream.Open
  Stream.Charset = DestCharset
  Stream.WriteText Text
  Stream.Position = 0
  Stream.Charset = SourceCharset
  CharTranslate = Stream.ReadText
End Function