SHARE
TWEET

CherryTreeProxy.VBS

Linda-chan Mar 23rd, 2015 (edited) 345 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '====================================================================
  2. ' AJPapps - CherryTree proxy
  3. ' Линда Кайе 2015. Посвящается Ариэль
  4. '
  5. ' Этот скрипт призван бороться с непониманием программой CherryThree
  6. ' кириллицы в командной строке. Например, если попытаться открыть
  7. ' через командную строку (или ассоциации) файл "Вишня.CTD",
  8. ' то CherryTree запустится и покажет пустой документ вместо того,
  9. ' который мы хотели открыть. Чтобы исправить такое поведение,
  10. ' следует запускать данный скрипт и с именем файла в командной
  11. ' строке, а уж он сам запустит CherryTree.
  12. '
  13. ' Скрипт действует следующим образом. Получая имя файла через
  14. ' командную строку, от открывает конфиг CherryTree, записывает это
  15. ' имя как последний открытый файл, а заодно включает открытие
  16. ' последнего файла при запуске программы. Далее скрипт запускает
  17. ' CherryTree. Запущенная программа проверяет конфиг и открывает
  18. ' указанный скриптом файл. Работа скрипта на этом завершается.
  19. ' Если в процессе произойдут какие-либо ошибки, скрипт сообщит о них
  20. ' и прервёт работу.
  21. '
  22. ' Если имя передаваемого файла содержит пробелы, то его следует
  23. ' заключить в кавычки.
  24. '
  25. ' ВНИМАНИЕ! Перед началом работы скрипта рекомендуется создать
  26. ' резервную копию конфига CherryTree. Это файл config.cfg в каталоге
  27. ' программы (при портабельной установке), либо где-то в AppData.
  28. '
  29. ' Также перед использованием придётся немного поправить сам скрипт.
  30. ' Необходимо модифицировать значения следующих констант:
  31. '
  32. ' • CFG_FILE_NAME - здесь указывается полное имя файла конфига,
  33. '                   файл config.cfg.
  34. ' • EXE_FILE_NAME - здесь указывается полное имя исполняемого файла
  35. '                   CherryTree, файл cherrytree.exe.
  36. '
  37. ' Данные константы уже заполнены какими-то значениями, поэтому их
  38. ' придётся лишь аккуратно их поправить.
  39. '
  40. ' • 24.03.2015
  41. '   Первая версия ^^
  42. '
  43. '====================================================================
  44. ' Маленький копирайт
  45. '
  46. ' 1. Программа и исходный код распространяются бесплатно.
  47. ' 2. Вы имеете право распространять их на тех же условиях.
  48. ' 3. Вы не имеете права использовать имя автора после модификации
  49. '    исходного кода.
  50. ' 4. При этом желательно указывать ссылку на автора оригинальной
  51. '    версии исходного кода.
  52. ' 5. Вы не имеете права на платное распространение исходного кода,
  53. '    а также программных модулей, содержащих данный исходнй код.
  54. ' 6. Программа и исходный код распространяются как есть. Автор не
  55. '    несёт ответственности за любые трагедии или несчастные случаи,
  56. '    вызванные использованием программы и исходного кода.
  57. ' 7. Для любого пункта данного соглашения может быть сделано
  58. '    исключение с разрешения автора программы.
  59. ' 8. По любым вопросам, связанным с данной программой, обращайтесь
  60. '    по адресу lindaoneesama@gmail.com
  61. '
  62. ' Загружено с http://purl.oclc.org/Linda_Kaioh/Homepage/
  63. '====================================================================
  64. Option Explicit
  65.  
  66. Const AppTitle = "AJPapps - CherryTree proxy"
  67.  
  68. Const CFG_FILE_NAME = "Y:\PortableApps.10000\Cherrytree\bin\config.cfg"
  69. Const EXE_FILE_NAME = "Y:\PortableApps.10000\Cherrytree\bin\cherrytree.exe"
  70.  
  71. Const ForReading = 1
  72. Const ForWriting = 2
  73. Const ForAppending = 8
  74.  
  75. Dim FSO
  76.  
  77. DoIt
  78.  
  79. '====================================================================
  80. Private Sub DoIt()
  81.   Dim DocFileName
  82.  
  83.   Set FSO = CreateObject("Scripting.FileSystemObject")
  84.  
  85.   Select Case WScript.Arguments.Count
  86.     Case 0
  87.       DocFileName = ""
  88.     Case 1
  89.       DocFileName = Trim(WScript.Arguments(0))
  90.     Case Else
  91.       MsgBox "Использование: CherryTreeProxy.VBS [FileName]", vbExclamation, AppTitle
  92.       Exit Sub
  93.   End Select
  94.  
  95.   If DocFileName = "/?" Then
  96.     MsgBox "Использование: CherryTreeProxy.VBS [FileName]", vbInformation, AppTitle
  97.     Exit Sub
  98.   End If
  99.  
  100.   If DocFileName <> "" Then _
  101.     If Not ModifyCherryTreeConfig(DocFileName) Then Exit Sub
  102.  
  103.   RunCherryTree
  104. End Sub
  105.  
  106. '====================================================================
  107. Private Function ModifyCherryTreeConfig(ByVal DocFileName)
  108.   Dim File
  109.   Dim DocFileNameOnly
  110.   Dim DocFilePath
  111.   Dim TXT
  112.  
  113.   On Error Resume Next
  114.  
  115.   ModifyCherryTreeConfig = False
  116.  
  117.   Set File = FSO.GetFile(DocFileName)
  118.   If Err.Number <> 0 Then
  119.     MsgBox DocFileName & vbCrLf & vbCrLf & _
  120.            "Файл не найден.", vbCritical, AppTitle
  121.     Exit Function
  122.   End If
  123.  
  124.   If Not SplitFileName(File.Path, DocFilePath, DocFileNameOnly) Then
  125.     MsgBox DocFileName & vbCrLf & vbCrLf & _
  126.            "Не удалось разбить имя файла.", vbCritical, AppTitle
  127.     Exit Function
  128.   End If
  129.  
  130.   TXT = GetFile(CFG_FILE_NAME)
  131.   If Err.Number <> 0 Then
  132.     MsgBox CFG_FILE_NAME & vbCrLf & vbCrLf & _
  133.            "Не удалось прочитать конфиг CherryTree.", vbCritical, AppTitle
  134.     Exit Function
  135.   End If
  136.  
  137.   ' [Debug] MsgBox TXT
  138.  
  139.   TXT = InsertStringsToCherryTreeConfig(TXT, DocFilePath, DocFileNameOnly)
  140.   If TXT = "" Then Exit Function
  141.  
  142.   ' [Debug] MsgBox TXT
  143.  
  144.   PutFile CFG_FILE_NAME, TXT
  145.   If Err.Number <> 0 Then
  146.     MsgBox CFG_FILE_NAME & vbCrLf & vbCrLf & _
  147.            "Не удалось записать конфиг CherryTree.", vbCritical, AppTitle
  148.     Exit Function
  149.   End If
  150.  
  151.   ModifyCherryTreeConfig = True
  152. End Function
  153.  
  154. '====================================================================
  155. Private Function SplitFileName(ByVal FullFileName, _
  156.                                ByRef DocFilePath, _
  157.                                ByRef DocFileNameOnly)
  158.   Dim RC
  159.  
  160.   SplitFileName = False
  161.  
  162.   RC = InStrRev(FullFileName, "\")
  163.   If RC = 0 Then Exit Function
  164.  
  165.   DocFilePath = Left(FullFileName, RC)
  166.   If Len(DocFilePath) <= 1 Then Exit Function
  167.  
  168.   DocFileNameOnly = Mid(FullFileName, RC + 1)
  169.   If Len(DocFileNameOnly) <= 0 Then Exit Function
  170.  
  171.   SplitFileName = True
  172. End Function
  173.  
  174. '====================================================================
  175. Private Function GetFile(ByVal FileName)
  176.   Dim Stream
  177.  
  178.   Set Stream = FSO.OpenTextFile(FileName, ForReading, False, False)
  179.   GetFile = Stream.ReadAll()
  180.   Stream.Close
  181.  
  182.   GetFile = Utf8ToChar(GetFile)
  183. End Function
  184.  
  185. '====================================================================
  186. Private Sub PutFile(ByVal FileName, ByVal Data)
  187.   Dim Stream
  188.  
  189.   Data = CharToUtf8(Data)
  190.  
  191.   Set Stream = FSO.OpenTextFile(FileName, ForWriting, True, False)
  192.   Stream.Write Data
  193.   Stream.Close
  194. End Sub
  195.  
  196. '====================================================================
  197. ' file_dir = ...
  198. ' file_name = ...
  199. ' reload_doc_last = True
  200. '====================================================================
  201. Private Function InsertStringsToCherryTreeConfig(ByVal ConfigText, _
  202.                                                  ByVal DocFilePath, _
  203.                                                  ByVal DocFileNameOnly)
  204.   Dim Lines
  205.   Dim TMP
  206.  
  207.   InsertStringsToCherryTreeConfig = ""
  208.  
  209.   Lines = Split(ConfigText, vbLf)
  210.   For TMP = LBound(Lines) To UBound(Lines)
  211.     If LCase(Left(Lines(TMP), 10)) = "file_dir =" Or _
  212.        LCase(Left(Lines(TMP), 9)) = "file_dir=" Then
  213.       Lines(TMP) = "file_dir = " & DocFilePath
  214.      
  215.     ElseIf LCase(Left(Lines(TMP), 11)) = "file_name =" Or _
  216.            LCase(Left(Lines(TMP), 10)) = "file_name=" Then
  217.       Lines(TMP) = "file_name = " & DocFileNameOnly
  218.      
  219.     ElseIf LCase(Left(Lines(TMP), 17)) = "reload_doc_last =" Or _
  220.            LCase(Left(Lines(TMP), 16)) = "reload_doc_last=" Then
  221.       Lines(TMP) = "reload_doc_last = True"
  222.     End If
  223.   Next
  224.  
  225.   InsertStringsToCherryTreeConfig = Join(Lines, vbLf)
  226. End Function
  227.  
  228. '====================================================================
  229. Private Sub RunCherryTree()
  230.   Dim WShell
  231.   Dim RC
  232.  
  233.   Set WShell = CreateObject("WScript.Shell")
  234.  
  235.   On Error Resume Next
  236.  
  237.   RC = WShell.Run("""" & EXE_FILE_NAME & """", 10, False)
  238.   If Err.Number <> 0 Then
  239.     MsgBox EXE_FILE_NAME & vbCrLf & vbCrLf & _
  240.            "Не удалось запустить CherryTree.", vbCritical, AppTitle
  241.   End If
  242. End Sub
  243.  
  244. '====================================================================
  245. ' Перекодировка с использованием встроенного объекта.
  246. ' Найдено тут: http://forum.script-coding.com/viewtopic.php?id=1179
  247. '====================================================================
  248. Private Function CharToOem(ByVal Text)
  249.   CharToOem = CharTranslate(Text, "windows-1251", "cp866")
  250. End Function
  251.  
  252. Private Function OemToChar(ByVal Text)
  253.   OemToChar = CharTranslate(Text, "cp866", "windows-1251")
  254. End Function
  255.  
  256. Private Function CharToUtf8(ByVal Text)
  257.   CharToUtf8 = CharTranslate(Text, "windows-1251", "utf-8")
  258.  
  259.   ' Удаляем UTF-8 сигнатуру, которая на самом деле в данном случае
  260.  ' не нужна. Если пишем файл, то будем писать её отдельно, там,
  261.  ' где файл пишется...
  262.  If Left(CharToUtf8, 3) = Chr(&HEF) & Chr(&HBB) & Chr(&HBF) Then _
  263.     CharToUtf8 = Mid(CharToUtf8, 4)
  264. End Function
  265.  
  266. Private Function Utf8ToChar(ByVal Text)
  267.   Utf8ToChar = CharTranslate(Text, "utf-8", "windows-1251")
  268. End Function
  269.  
  270. '====================================================================
  271. ' Общая функция перекодировки из чего угодно во что угодно.
  272. '====================================================================
  273. Function CharTranslate(ByVal Text, _
  274.                        ByVal SourceCharset, _
  275.                        ByVal DestCharset)
  276.   Dim Stream
  277.  
  278.   Set Stream = CreateObject("ADODB.Stream")
  279.   Stream.Type = 2
  280.   Stream.Mode = 3
  281.   Stream.Open
  282.   Stream.Charset = DestCharset
  283.   Stream.WriteText Text
  284.   Stream.Position = 0
  285.   Stream.Charset = SourceCharset
  286.   CharTranslate = Stream.ReadText
  287. End Function
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top