1
0

ModBase.vb 118 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471
  1. Imports System.IO.Compression
  2. Imports System.Management
  3. Imports System.Security.Cryptography
  4. Imports System.Security.Principal
  5. Imports System.Windows.Markup
  6. Imports Newtonsoft.Json
  7. Public Module ModBase
  8. #Region "声明"
  9. '下列版本信息由更新器自动修改
  10. Public Const VersionBaseName As String = "2.3.1" '不含分支前缀的显示用版本名
  11. Public Const VersionStandardCode As String = "2.3.1." & VersionBranchCode '标准格式的四段式版本号
  12. #If BETA Then
  13. Public Const VersionCode As Integer = 257 'Release
  14. #Else
  15. Public Const VersionCode As Integer = 259 'Snapshot
  16. #End If
  17. '自动生成的版本信息
  18. Public Const VersionDisplayName As String = VersionBranchName & " " & VersionBaseName
  19. #If RELEASE Then
  20. Public Const VersionBranchName As String = "Snapshot"
  21. Public Const VersionBranchCode As String = "0"
  22. #ElseIf BETA Then
  23. Public Const VersionBranchName As String = "Release"
  24. Public Const VersionBranchCode As String = "50"
  25. #ElseIf DEBUG Then
  26. Public Const VersionBranchName As String = "Debug"
  27. Public Const VersionBranchCode As String = "100"
  28. #End If
  29. ''' <summary>
  30. ''' 主窗口句柄。
  31. ''' </summary>
  32. Public Handle As IntPtr
  33. ''' <summary>
  34. ''' 程序的启动路径,以“\”结尾。
  35. ''' </summary>
  36. Public Path As String = AppDomain.CurrentDomain.SetupInformation.ApplicationBase
  37. ''' <summary>
  38. ''' 包含程序名的完整路径。
  39. ''' </summary>
  40. Public PathWithName As String = Path & AppDomain.CurrentDomain.SetupInformation.ApplicationName
  41. ''' <summary>
  42. ''' 程序内嵌图片文件夹路径,以“/”结尾。
  43. ''' </summary>
  44. Public PathImage As String = "pack://application:,,,/images/"
  45. ''' <summary>
  46. ''' 当前程序的语言。
  47. ''' </summary>
  48. Public Lang As String = "zh_CN"
  49. ''' <summary>
  50. ''' 设置对象。
  51. ''' </summary>
  52. Public Setup As New ModSetup
  53. ''' <summary>
  54. ''' 程序的打开计时。
  55. ''' </summary>
  56. Public ApplicationStartTick As Long
  57. ''' <summary>
  58. ''' 程序打开时的时间。
  59. ''' </summary>
  60. Public ApplicationOpenTime As Date = Date.Now
  61. ''' <summary>
  62. ''' 设备唯一标识符。
  63. ''' </summary>
  64. Public UniqueAddress As String = SecretGetUniqueAddress()
  65. ''' <summary>
  66. ''' 程序是否已结束。
  67. ''' </summary>
  68. Public IsProgramEnded As Boolean = False
  69. ''' <summary>
  70. ''' 是否为 32 位系统。
  71. ''' </summary>
  72. Public Is32BitSystem As Boolean = Not Environment.Is64BitOperatingSystem
  73. ''' <summary>
  74. ''' 操作系统版本。Win10 为 10.0。
  75. ''' </summary>
  76. Public OsVersion As Version = Environment.OSVersion.Version
  77. ''' <summary>
  78. ''' 程序的缓存文件夹路径,以“\”结尾。
  79. ''' </summary>
  80. Public PathTemp As String = If(Setup.Get("SystemSystemCache") = "", IO.Path.GetTempPath() & "PCL\", Setup.Get("SystemSystemCache")).ToString.Replace("/", "\").TrimEnd("\") & "\"
  81. #End Region
  82. #Region "矢量图标"
  83. Public Class Logo
  84. ''' <summary>
  85. ''' 图标按钮,心(空心),1.1x
  86. ''' </summary>
  87. Public Const IconButtonLikeLine As String = "M512 896a42.666667 42.666667 0 0 1-30.293333-12.373333l-331.52-331.946667a224.426667 224.426667 0 0 1 0-315.733333 223.573333 223.573333 0 0 1 315.733333 0L512 282.026667l46.08-46.08a223.573333 223.573333 0 0 1 315.733333 0 224.426667 224.426667 0 0 1 0 315.733333l-331.52 331.946667A42.666667 42.666667 0 0 1 512 896zM308.053333 256a136.533333 136.533333 0 0 0-97.28 40.106667 138.24 138.24 0 0 0 0 194.986666L512 792.746667l301.226667-301.653334a138.24 138.24 0 0 0 0-194.986666 141.653333 141.653333 0 0 0-194.56 0l-76.373334 76.8a42.666667 42.666667 0 0 1-60.586666 0L405.333333 296.106667A136.533333 136.533333 0 0 0 308.053333 256z"
  88. ''' <summary>
  89. ''' 图标按钮,心(实心),1.1x
  90. ''' </summary>
  91. Public Const IconButtonLikeFill As String = "M700.856 155.543c-74.769 0-144.295 72.696-190.046 127.26-45.737-54.576-115.247-127.26-190.056-127.26-134.79 0-244.443 105.78-244.443 235.799 0 77.57 39.278 131.988 70.845 175.713C238.908 694.053 469.62 852.094 479.39 858.757c9.41 6.414 20.424 9.629 31.401 9.629 11.006 0 21.998-3.215 31.398-9.63 9.782-6.662 240.514-164.703 332.238-291.701 31.587-43.724 70.874-98.143 70.874-175.713-0.001-130.02-109.656-235.8-244.445-235.8z m0 0"
  92. ''' <summary>
  93. ''' 图标按钮,垃圾桶,1.1x
  94. ''' </summary>
  95. Public Const IconButtonDelete As String = "M520.192 0C408.43 0 317.44 82.87 313.563 186.734H52.736c-29.038 0-52.663 21.943-52.663 49.079s23.625 49.152 52.663 49.152h58.075v550.473c0 103.35 75.118 187.757 167.717 187.757h472.43c92.599 0 167.716-83.894 167.716-187.757V285.477h52.59c29.038 0 52.59-21.943 52.663-49.08-0.073-27.135-23.625-49.151-52.663-49.151H726.235C723.237 83.017 631.955 0 520.192 0zM404.846 177.957c3.803-50.03 50.176-89.015 107.447-89.015 57.197 0 103.57 38.985 106.788 89.015H404.92zM284.379 933.669c-33.353 0-69.997-39.351-69.997-95.525v-549.01H833.39v549.522c0 56.247-36.645 95.525-69.998 95.525H284.379v-0.512z M357.23 800.695a48.274 48.274 0 0 0 47.616-49.006V471.7a48.274 48.274 0 0 0-47.543-49.08 48.274 48.274 0 0 0-47.69 49.006V751.69c0 27.282 20.846 49.006 47.617 49.006z m166.62 0a48.274 48.274 0 0 0 47.688-49.006V471.7a48.274 48.274 0 0 0-47.689-49.08 48.274 48.274 0 0 0-47.543 49.006V751.69c0 27.282 21.431 49.006 47.543 49.006z m142.92 0a48.274 48.274 0 0 0 47.543-49.006V471.7a48.274 48.274 0 0 0-47.543-49.08 48.274 48.274 0 0 0-47.616 49.006V751.69c0 27.282 20.773 49.006 47.543 49.006z"
  96. ''' <summary>
  97. ''' 图标按钮,笔,1x
  98. ''' </summary>
  99. Public Const IconButtonEdit As String = "M732.64 64.32C688.576 21.216 613.696 21.216 569.6 64.32L120.128 499.52c-17.6 12.896-26.432 30.144-30.848 51.68L32 870.048c0 25.856 8.8 56 26.432 73.248 17.632 17.216 17.632 48.704 88.64 48.704h13.248l326.08-56c22.016-4.32 39.68-12.928 52.864-30.176l449.472-435.2c22.048-21.536 35.264-47.36 35.264-77.536 0-30.176-13.216-56-35.264-77.568l-256.096-251.2zM139.712 903.776l56-326.912 311.04-295.136 267.104 269.44-310.976 295.168-323.168 57.44zM844.576 467.84l-273.984-260.672 61.856-59.84c8.832-8.512 26.528-8.512 39.776 0l234.24 226.496c4.384 4.288 8.832 12.8 8.832 17.088s-4.416 8.544-8.864 12.8l-61.856 64.128z"
  100. ''' <summary>
  101. ''' 图标按钮,齿轮,1.1x
  102. ''' </summary>
  103. Public Const IconButtonSetup As String = "M651.946667 1001.813333c-22.186667 0-42.666667-10.24-61.44-27.306666-23.893333-23.893333-49.493333-35.84-75.093334-35.84-29.013333 0-56.32 11.946667-73.386666 30.72v3.413333c-17.066667 17.066667-42.666667 27.306667-66.56 27.306667h-6.826667c-6.826667 0-11.946667-1.706667-15.36-1.706667l-6.826667-1.706667c-64.853333-20.48-121.173333-54.613333-168.96-98.986666-29.013333-23.893333-37.546667-63.146667-25.6-95.573334 8.533333-23.893333 5.12-51.2-10.24-75.093333-15.36-27.306667-34.133333-40.96-59.733333-47.786667h-1.706667l-5.12-1.706666c-35.84-8.533333-61.44-34.133333-66.56-69.973334C1.706667 575.146667 0 537.6 0 512c0-32.426667 3.413333-63.146667 8.533333-93.866667v-6.826666l3.413334-8.533334c10.24-23.893333 23.893333-40.96 44.373333-51.2 5.12-3.413333 11.946667-6.826667 20.48-8.533333 27.306667-8.533333 51.2-25.6 63.146667-44.373333 13.653333-23.893333 17.066667-52.906667 10.24-81.92-11.946667-34.133333 0-71.68 30.72-93.866667 44.373333-37.546667 97.28-68.266667 158.72-93.866667l3.413333-1.706666c44.373333-13.653333 75.093333 3.413333 92.16 20.48 23.893333 23.893333 49.493333 35.84 75.093333 35.84 30.72 0 56.32-10.24 71.68-30.72l3.413334-3.413334c27.306667-27.306667 63.146667-35.84 93.866666-22.186666 63.146667 22.186667 117.76 54.613333 165.546667 97.28 29.013333 23.893333 37.546667 63.146667 25.6 95.573333-8.533333 23.893333-5.12 51.2 10.24 75.093333 15.36 27.306667 34.133333 40.96 59.733333 47.786667h1.706667l5.12 1.706667c35.84 8.533333 61.44 34.133333 66.56 71.68 6.826667 30.72 10.24 63.146667 11.946667 93.866666v3.413334c0 32.426667-3.413333 63.146667-8.533334 93.866666v6.826667l-3.413333 8.533333c-10.24 23.893333-23.893333 40.96-44.373333 51.2-5.12 3.413333-11.946667 6.826667-20.48 8.533334-27.306667 8.533333-51.2 25.6-63.146667 46.08-13.653333 23.893333-17.066667 52.906667-10.24 81.92 11.946667 35.84-1.706667 75.093333-30.72 95.573333-44.373333 35.84-95.573333 66.56-157.013333 92.16-15.36 3.413333-27.306667 3.413333-35.84 3.413333z m3.413333-83.626666z m1.706667 0zM517.12 853.333333c47.786667 0 93.866667 20.48 134.826667 59.733334 1.706667 1.706667 3.413333 1.706667 3.413333 3.413333 52.906667-22.186667 97.28-49.493333 136.533333-80.213333l1.706667-1.706667v-3.413333c-13.653333-52.906667-8.533333-104.106667 17.066667-148.48 23.893333-39.253333 64.853333-69.973333 114.346666-85.333334 1.706667 0 3.413333-1.706667 6.826667-6.826666 5.12-25.6 8.533333-51.2 8.533333-78.506667-1.706667-29.013333-3.413333-56.32-10.24-81.92v-5.12h-1.706666c-51.2-11.946667-90.453333-39.253333-119.466667-87.04-27.306667-44.373333-34.133333-100.693333-17.066667-148.48l-1.706666-1.706667h-3.413334c-39.253333-35.84-85.333333-63.146667-136.533333-80.213333H648.533333s-1.706667 1.706667-3.413333 1.706667c-32.426667 39.253333-80.213333 59.733333-136.533333 59.733333-47.786667 0-93.866667-20.48-134.826667-59.733333l-1.706667-1.706667h-1.706666c-54.613333 22.186667-98.986667 49.493333-136.533334 80.213333l-1.706666 1.706667v3.413333c13.653333 52.906667 8.533333 104.106667-17.066667 148.48-23.893333 39.253333-64.853333 69.973333-114.346667 85.333334-1.706667 0-3.413333 1.706667-6.826666 6.826666-6.826667 25.6-8.533333 51.2-8.533334 78.506667 0 30.72 3.413333 58.026667 6.826667 76.8l1.706667 5.12h1.706666c51.2 11.946667 90.453333 39.253333 119.466667 87.04 27.306667 44.373333 34.133333 100.693333 17.066667 148.48l1.706666 1.706667 1.706667 1.706666c37.546667 35.84 83.626667 63.146667 134.826667 80.213334 1.706667 0 3.413333 0 3.413333 1.706666h1.706667s1.706667 0 5.12-1.706666c34.133333-37.546667 81.92-59.733333 136.533333-59.733334z m-6.826667-146.773333c-110.933333 0-199.68-85.333333-199.68-196.266667 0-109.226667 87.04-196.266667 199.68-196.266666s199.68 85.333333 199.68 196.266666c-1.706667 109.226667-88.746667 196.266667-199.68 196.266667z m0-307.2c-63.146667 0-114.346667 49.493333-114.346666 110.933333 0 63.146667 49.493333 110.933333 114.346666 110.933334 30.72 0 59.733333-11.946667 80.213334-32.426667 20.48-20.48 32.426667-49.493333 32.426666-78.506667 0-63.146667-49.493333-110.933333-112.64-110.933333z"
  104. ''' <summary>
  105. ''' 图标按钮,重置,0.9x
  106. ''' </summary>
  107. Public Const IconButtonReset As String = "M667.6817627 313.65283203l-45.28564454 55.76660156L858.06933594 391.27124023 787.61950684 165.93066406l-56.01379395 69.01611328A354.47387695 354.47387695 0 0 0 520.89892578 165.93066406C324.87536621 165.93066406 165.93066406 324.43041992 165.93066406 519.91015625c0 195.52917481 158.94470215 353.97949219 354.96826172 353.97949219a355.06713867 355.06713867 0 0 0 331.73217774-227.66418458 50.52612305 50.52612305 0 0 0-29.21813966-65.25878905 50.77331543 50.77331543 0 0 0-65.50598144 29.16870117A253.61938477 253.61938477 0 0 1 520.94836426 772.78796387c-140.05920411 0-253.61938477-113.21411133-253.61938477-252.87780762 0-139.61425781 113.56018067-252.82836914 253.61938477-252.82836914 53.59130859 0 104.46350098 16.61132813 146.73339843 46.57104492"
  108. ''' <summary>
  109. ''' 图标按钮,刷新,0.85x
  110. ''' </summary>
  111. Public Const IconButtonRefresh As String = "M875.52 148.48C783.36 56.32 655.36 0 512 0 291.84 0 107.52 138.24 30.72 332.8l122.88 46.08C204.8 230.4 348.16 128 512 128c107.52 0 199.68 40.96 271.36 112.64L640 384h384V0L875.52 148.48zM512 896c-107.52 0-199.68-40.96-271.36-112.64L384 640H0v384l148.48-148.48C240.64 967.68 368.64 1024 512 1024c220.16 0 404.48-138.24 481.28-332.8L870.4 645.12C819.2 793.6 675.84 896 512 896z"
  112. ''' <summary>
  113. ''' 图标按钮,软盘,1x
  114. ''' </summary>
  115. Public Const IconButtonSave As String = "M819.392 0L1024 202.752v652.16a168.96 168.96 0 0 1-168.832 168.768h-104.192a47.296 47.296 0 0 1-10.752 0H283.776a47.232 47.232 0 0 1-10.752 0H168.832A168.96 168.96 0 0 1 0 854.912V168.768A168.96 168.96 0 0 1 168.832 0h650.56z m110.208 854.912V242.112l-149.12-147.776H168.896c-41.088 0-74.432 33.408-74.432 74.432v686.144c0 41.024 33.344 74.432 74.432 74.432h62.4v-190.528c0-33.408 27.136-60.544 60.544-60.544h440.448c33.408 0 60.544 27.136 60.544 60.544v190.528h62.4c41.088 0 74.432-33.408 74.432-74.432z m-604.032 74.432h372.864v-156.736H325.568v156.736z m403.52-596.48a47.168 47.168 0 1 1 0 94.336H287.872a47.168 47.168 0 1 1 0-94.336h441.216z m0-153.728a47.168 47.168 0 1 1 0 94.4H287.872a47.168 47.168 0 1 1 0-94.4h441.216z"
  116. ''' <summary>
  117. ''' 图标按钮,信息,1.05x
  118. ''' </summary>
  119. Public Const IconButtonInfo As String = "M512 917.333333c223.861333 0 405.333333-181.472 405.333333-405.333333S735.861333 106.666667 512 106.666667 106.666667 288.138667 106.666667 512s181.472 405.333333 405.333333 405.333333z m0 106.666667C229.226667 1024 0 794.773333 0 512S229.226667 0 512 0s512 229.226667 512 512-229.226667 512-512 512z m-32-597.333333h64a21.333333 21.333333 0 0 1 21.333333 21.333333v320a21.333333 21.333333 0 0 1-21.333333 21.333333h-64a21.333333 21.333333 0 0 1-21.333333-21.333333V448a21.333333 21.333333 0 0 1 21.333333-21.333333z m0-192h64a21.333333 21.333333 0 0 1 21.333333 21.333333v64a21.333333 21.333333 0 0 1-21.333333 21.333333h-64a21.333333 21.333333 0 0 1-21.333333-21.333333v-64a21.333333 21.333333 0 0 1 21.333333-21.333333z"
  120. ''' <summary>
  121. ''' 图标按钮,列表,1x
  122. ''' </summary>
  123. Public Const IconButtonList As String = "M384 128h640v128H384zM160 192m-96 0a96 96 0 1 0 192 0 96 96 0 1 0-192 0ZM384 448h640v128H384zM160 512m-96 0a96 96 0 1 0 192 0 96 96 0 1 0-192 0ZM384 768h640v128H384zM160 832m-96 0a96 96 0 1 0 192 0 96 96 0 1 0-192 0Z"
  124. ''' <summary>
  125. ''' 图标按钮,文件夹,1.15x
  126. ''' </summary>
  127. Public Const IconButtonOpen As String = "M889.018182 418.909091H884.363636V316.509091a93.090909 93.090909 0 0 0-99.607272-89.832727h-302.545455l-93.090909-76.334546A46.545455 46.545455 0 0 0 358.865455 139.636364H146.152727A93.090909 93.090909 0 0 0 46.545455 229.469091V837.818182a46.545455 46.545455 0 0 0 46.545454 46.545454 46.545455 46.545455 0 0 0 16.756364-3.258181 109.381818 109.381818 0 0 0 25.134545 3.258181h586.472727a85.178182 85.178182 0 0 0 87.04-63.301818l163.374546-302.545454a46.545455 46.545455 0 0 0 5.585454-21.876364A82.385455 82.385455 0 0 0 889.018182 418.909091z m-744.727273-186.181818h198.283636l93.09091 76.334545a46.545455 46.545455 0 0 0 29.323636 10.705455h319.301818a12.101818 12.101818 0 0 1 6.516364 0V418.909091H302.545455a85.178182 85.178182 0 0 0-87.04 63.301818L139.636364 622.778182V232.727273a19.549091 19.549091 0 0 1 6.516363 0z m578.094546 552.029091a27.461818 27.461818 0 0 0-2.792728 6.516363H154.530909l147.083636-272.290909a27.461818 27.461818 0 0 0 2.792728-6.981818h565.061818z"
  128. ''' <summary>
  129. ''' 图标按钮,名片,1.1x
  130. ''' </summary>
  131. Public Const IconButtonCard As String = "M834.5 684.1c-31.2-70.4-98.9-120.9-179.1-127.3 63.5-8.5 112.6-63 112.6-128.8 0-71.8-58.2-130-130-130s-130 58.2-130 130c0 65.9 49 120.3 112.6 128.8-80.2 6.4-148 57-179.1 127.3-8.7 19.7 6 42 27.6 42 12.1 0 22.7-7.5 27.7-18.5 24.3-53.9 78.5-91.5 141.3-91.5s117 37.6 141.3 91.5c5 11.1 15.6 18.5 27.7 18.5 21.4 0 36.1-22.3 27.4-42zM567.9 427.9c0-38.6 31.4-70 70-70s70 31.4 70 70-31.4 70-70 70-70-31.4-70-70zM460.3 347.9H216.9c-16.6 0-30 13.4-30 30s13.4 30 30 30h243.3c16.6 0 30-13.4 30-30 0.1-16.5-13.4-30-29.9-30zM367.4 459.6H216.9c-16.6 0-30 13.4-30 30s13.4 30 30 30h150.4c16.6 0 30-13.4 30-30 0.1-16.6-13.4-30-29.9-30zM297.4 571.2H217c-16.6 0-30 13.4-30 30s13.4 30 30 30h80.4c16.6 0 30-13.4 30-30 0-16.5-13.5-30-30-30zM900 236v552H124V236h776m0-60H124c-33.1 0-60 26.9-60 60v552c0 33.1 26.9 60 60 60h776c33.1 0 60-26.9 60-60V236c0-33.1-26.9-60-60-60z"
  132. ''' <summary>
  133. ''' 图标按钮,×,0.85x
  134. ''' </summary>
  135. Public Const IconButtonCross As String = "F1 M 26.9166,22.1667L 37.9999,33.25L 49.0832,22.1668L 53.8332,26.9168L 42.7499,38L 53.8332,49.0834L 49.0833,53.8334L 37.9999,42.75L 26.9166,53.8334L 22.1666,49.0833L 33.25,38L 22.1667,26.9167L 26.9166,22.1667 Z"
  136. ''' <summary>
  137. ''' 图标按钮,Mojang,1.1x
  138. ''' </summary>
  139. Public Const IconButtonMojang As String = "M9.183,18.967c-0.109-2.239,1.336-5.119,3.92-4.96c3.657-0.027,7.319-0.044,10.977,0.005 c3.712,0.214,6.596,2.759,9.652,4.533c0.181-1.697-0.197-3.717,1.237-4.982c1.899,2.091,3.143,4.894,5.677,6.334 c1.577,0.805,2.973-0.668,4.221-1.44c1.55,2.305,2.108,5.075,2.622,7.752c0.657,3.438,0.947,6.925,1.111,10.413 c-1.734-0.733-3.355-1.708-4.971-2.671c-1.396-4.933-5.349-8.656-9.723-11.059c-3.46-1.817-7.752-2.185-11.338-0.52 c-3.761,1.593-6.285,5.666-5.891,9.75c0.121,4.577,3.17,8.765,7.391,10.456c7.746,3.285,16.407,2.234,24.521,1.243 c0.454,2.315-1.511,4.527-3.695,4.889c-10.577,0.038-21.148-0.011-31.725,0.022c-2.217,0.279-4.079-1.879-3.964-4.008 C9.167,36.141,9.216,27.556,9.183,18.967z M40.114,8.09c0.294-0.801,0.872-1.417,1.542-1.924c1.379,2.589,2.742,5.482,2.311,8.491 c-0.332,2.54-4.42,2.507-5.052,0.163C38.349,12.527,39.209,10.178,40.114,8.09z M0,53 l0.1,0 z"
  140. ''' <summary>
  141. ''' 图标按钮,用户,0.95x
  142. ''' </summary>
  143. Public Const IconButtonUser As String = "M660.338 528.065c63.61-46.825 105.131-121.964 105.131-206.83 0-141.7-115.29-256.987-256.997-256.987-141.706 0-256.998 115.288-256.998 256.987 0 85.901 42.52 161.887 107.456 208.562-152.1 59.92-260.185 207.961-260.185 381.077 0 21.276 17.253 38.53 38.53 38.53 21.278 0 38.53-17.254 38.53-38.53 0-183.426 149.232-332.671 332.667-332.671 1.589 0 3.113-0.207 4.694-0.244 0.8 0.056 1.553 0.244 2.362 0.244 183.434 0 332.664 149.245 332.664 332.671 0 21.276 17.255 38.53 38.533 38.53 21.277 0 38.53-17.254 38.53-38.53 0-174.885-110.354-324.13-264.917-382.809z m-331.803-206.83c0-99.22 80.72-179.927 179.935-179.927s179.937 80.708 179.937 179.927c0 99.203-80.721 179.91-179.937 179.91s-179.935-80.708-179.935-179.91z"
  144. ''' <summary>
  145. ''' 图标,音符,1x
  146. ''' </summary>
  147. Public Const IconMusic As String = "M348.293565 716.53287V254.797913c0-41.672348 28.004174-78.358261 68.919652-90.37913L815.994435 40.826435c62.775652-18.610087 125.907478 26.579478 125.907478 89.933913v539.158261c8.013913 42.25113-8.94887 89.177043-47.014956 127.109565a232.848696 232.848696 0 0 1-170.785392 65.758609c-61.885217-2.938435-111.081739-33.435826-129.113043-80.050087-18.031304-46.614261-2.137043-102.177391 41.672348-145.853218a232.848696 232.848696 0 0 1 170.785391-65.80313c21.014261 1.024 40.514783 5.164522 57.878261 12.065391V233.338435c0-12.109913-10.551652-20.034783-20.569044-20.034783a24.620522 24.620522 0 0 0-5.787826 0.934957L439.785739 338.18713a19.545043 19.545043 0 0 0-14.825739 19.144348v438.984348H423.846957c11.53113 43.987478-5.164522 94.208-45.412174 134.322087a232.848696 232.848696 0 0 1-170.785392 65.758609c-61.885217-2.938435-111.081739-33.435826-129.113043-80.050087-18.031304-46.614261-2.137043-102.177391 41.672348-145.853218a232.848696 232.848696 0 0 1 170.785391-65.80313c20.791652 1.024 40.069565 5.075478 57.299478 11.842783z"
  148. ''' <summary>
  149. ''' 图标,播放,0.8x
  150. ''' </summary>
  151. Public Const IconPlay As String = "M803.904 463.936a55.168 55.168 0 0 1 0 96.128l-463.616 264.448C302.848 845.888 256 819.136 256 776.448V247.616c0-42.752 46.848-69.44 84.288-48.064l463.616 264.384z"
  152. End Class
  153. #End Region
  154. #Region "自定义类"
  155. ''' <summary>
  156. ''' 支持小数与常见类型隐式转换的颜色。
  157. ''' </summary>
  158. Public Class MyColor
  159. Public A As Double = 255
  160. Public R As Double = 0
  161. Public G As Double = 0
  162. Public B As Double = 0
  163. '类型转换
  164. Public Shared Widening Operator CType(str As String) As MyColor
  165. Return New MyColor(str)
  166. End Operator
  167. Public Shared Widening Operator CType(col As Color) As MyColor
  168. Return New MyColor(col)
  169. End Operator
  170. Public Shared Widening Operator CType(conv As MyColor) As Color
  171. Return Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B))
  172. End Operator
  173. Public Shared Widening Operator CType(conv As MyColor) As System.Drawing.Color
  174. Return System.Drawing.Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B))
  175. End Operator
  176. Public Shared Widening Operator CType(bru As SolidColorBrush) As MyColor
  177. Return New MyColor(bru.Color)
  178. End Operator
  179. Public Shared Widening Operator CType(conv As MyColor) As SolidColorBrush
  180. Return New SolidColorBrush(Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B)))
  181. End Operator
  182. Public Shared Widening Operator CType(bru As Brush) As MyColor
  183. Return New MyColor(bru)
  184. End Operator
  185. Public Shared Widening Operator CType(conv As MyColor) As Brush
  186. Return New SolidColorBrush(Color.FromArgb(MathByte(conv.A), MathByte(conv.R), MathByte(conv.G), MathByte(conv.B)))
  187. End Operator
  188. '颜色运算
  189. Public Shared Operator +(a As MyColor, b As MyColor) As MyColor
  190. Return New MyColor With {.A = a.A + b.A, .B = a.B + b.B, .G = a.G + b.G, .R = a.R + b.R}
  191. End Operator
  192. Public Shared Operator -(a As MyColor, b As MyColor) As MyColor
  193. Return New MyColor With {.A = a.A - b.A, .B = a.B - b.B, .G = a.G - b.G, .R = a.R - b.R}
  194. End Operator
  195. Public Shared Operator *(a As MyColor, b As Double) As MyColor
  196. Return New MyColor With {.A = a.A * b, .B = a.B * b, .G = a.G * b, .R = a.R * b}
  197. End Operator
  198. Public Shared Operator /(a As MyColor, b As Double) As MyColor
  199. Return New MyColor With {.A = a.A / b, .B = a.B / b, .G = a.G / b, .R = a.R / b}
  200. End Operator
  201. Public Shared Operator =(a As MyColor, b As MyColor) As Boolean
  202. If IsNothing(a) AndAlso IsNothing(b) Then Return True
  203. If IsNothing(a) OrElse IsNothing(b) Then Return False
  204. Return a.A = b.A AndAlso a.R = b.R AndAlso a.G = b.G AndAlso a.B = b.B
  205. End Operator
  206. Public Shared Operator <>(a As MyColor, b As MyColor) As Boolean
  207. If IsNothing(a) AndAlso IsNothing(b) Then Return False
  208. If IsNothing(a) OrElse IsNothing(b) Then Return True
  209. Return Not (a.A = b.A AndAlso a.R = b.R AndAlso a.G = b.G AndAlso a.B = b.B)
  210. End Operator
  211. '构造函数
  212. Public Sub New()
  213. End Sub
  214. Public Sub New(col As Color)
  215. Me.A = col.A
  216. Me.R = col.R
  217. Me.G = col.G
  218. Me.B = col.B
  219. End Sub
  220. Public Sub New(HexString As String)
  221. Dim StringColor As Media.Color = ColorConverter.ConvertFromString(HexString)
  222. A = StringColor.A
  223. R = StringColor.R
  224. G = StringColor.G
  225. B = StringColor.B
  226. End Sub
  227. Public Sub New(newA As Double, col As MyColor)
  228. Me.A = newA
  229. Me.R = col.R
  230. Me.G = col.G
  231. Me.B = col.B
  232. End Sub
  233. Public Sub New(newR As Double, newG As Double, newB As Double)
  234. Me.A = 255
  235. Me.R = newR
  236. Me.G = newG
  237. Me.B = newB
  238. End Sub
  239. Public Sub New(newA As Double, newR As Double, newG As Double, newB As Double)
  240. Me.A = newA
  241. Me.R = newR
  242. Me.G = newG
  243. Me.B = newB
  244. End Sub
  245. Public Sub New(brush As Brush)
  246. Dim Color As Color = CType(brush, SolidColorBrush).Color
  247. A = Color.A
  248. R = Color.R
  249. G = Color.G
  250. B = Color.B
  251. End Sub
  252. Public Sub New(brush As SolidColorBrush)
  253. Dim Color As Color = brush.Color
  254. A = Color.A
  255. R = Color.R
  256. G = Color.G
  257. B = Color.B
  258. End Sub
  259. Public Sub New(obj As Object)
  260. If obj Is Nothing Then
  261. A = 255 : R = 255 : G = 255 : B = 255
  262. Else
  263. If TypeOf obj Is SolidColorBrush Then
  264. '避免反复获取 Color 对象造成性能下降
  265. Dim Color As Color = CType(obj, SolidColorBrush).Color
  266. A = Color.A
  267. R = Color.R
  268. G = Color.G
  269. B = Color.B
  270. Else
  271. A = obj.A
  272. R = obj.R
  273. G = obj.G
  274. B = obj.B
  275. End If
  276. End If
  277. End Sub
  278. 'HSL
  279. Public Function Hue(v1 As Double, v2 As Double, vH As Double) As Double
  280. If vH < 0 Then vH += 1
  281. If vH > 1 Then vH -= 1
  282. If vH < 0.16667 Then Return v1 + (v2 - v1) * 6 * vH
  283. If vH < 0.5 Then Return v2
  284. If vH < 0.66667 Then Return v1 + (v2 - v1) * (4 - vH * 6)
  285. Return v1
  286. End Function
  287. Public Function FromHSL(sH As Double, sS As Double, sL As Double) As MyColor
  288. If sS = 0 Then
  289. R = sL * 2.55
  290. G = R
  291. B = R
  292. Else
  293. Dim H = sH / 360
  294. Dim S = sS / 100
  295. Dim L = sL / 100
  296. S = If(L < 0.5, S * L + L, S * (1.0 - L) + L)
  297. L = 2 * L - S
  298. R = 255 * Hue(L, S, H + 1 / 3)
  299. G = 255 * Hue(L, S, H)
  300. B = 255 * Hue(L, S, H - 1 / 3)
  301. End If
  302. A = 255
  303. Return Me
  304. End Function
  305. Public Function FromHSL2(sH As Double, sS As Double, sL As Double) As MyColor
  306. If sS = 0 Then
  307. R = sL * 2.55 : G = R : B = R
  308. Else
  309. '初始化
  310. sH = (sH + 3600000) Mod 360
  311. Dim cent As Double() = {
  312. +0.1, -0.06, -0.3, '0, 30, 60
  313. -0.19, -0.15, -0.24, '90, 120, 150
  314. -0.32, -0.09, +0.18, '180, 210, 240
  315. +0.05, -0.12, -0.02, '270, 300, 330
  316. +0.1, -0.06} '最后两位与前两位一致,加是变亮,减是变暗
  317. '计算色调对应的亮度片区
  318. Dim center As Double = sH / 30.0
  319. Dim intCenter As Integer = Math.Floor(center) '亮度片区编号
  320. center = 50 - (
  321. (1 - center + intCenter) * cent(intCenter) + (center - intCenter) * cent(intCenter + 1)
  322. ) * sS
  323. 'center = 50 + (cent(intCenter) + (center - intCenter) * (cent(intCenter + 1) - cent(intCenter))) * sS
  324. sL = If(sL < center, sL / center, 1 + (sL - center) / (100 - center)) * 50
  325. FromHSL(sH, sS, sL)
  326. End If
  327. A = 255
  328. Return Me
  329. End Function
  330. Public Overrides Function ToString() As String
  331. Return "(" & A & "," & R & "," & G & "," & B & ")"
  332. End Function
  333. Public Overrides Function Equals(obj As Object) As Boolean
  334. Return Me = obj
  335. End Function
  336. End Class
  337. ''' <summary>
  338. ''' 支持负数与浮点数的矩形。
  339. ''' </summary>
  340. Public Class MyRect
  341. '属性
  342. Public Property Width As Double = 0
  343. Public Property Height As Double = 0
  344. Public Property Left As Double = 0
  345. Public Property Top As Double = 0
  346. '构造函数
  347. Public Sub New()
  348. End Sub
  349. Public Sub New(left As Double, top As Double, width As Double, height As Double)
  350. Me.Left = left
  351. Me.Top = top
  352. Me.Width = width
  353. Me.Height = height
  354. End Sub
  355. End Class
  356. ''' <summary>
  357. ''' 模块加载状态枚举。
  358. ''' </summary>
  359. Public Enum LoadState
  360. Waiting
  361. Loading
  362. Finished
  363. Failed
  364. Aborted
  365. End Enum
  366. ''' <summary>
  367. ''' 执行返回值。
  368. ''' </summary>
  369. Public Enum Result
  370. ''' <summary>
  371. ''' 执行成功,或进程被中断。
  372. ''' </summary>
  373. Aborted = -1
  374. ''' <summary>
  375. ''' 执行成功。
  376. ''' </summary>
  377. Success = 0
  378. ''' <summary>
  379. ''' 执行失败。
  380. ''' </summary>
  381. Fail
  382. ''' <summary>
  383. ''' 执行时出现未经处理的异常。
  384. ''' </summary>
  385. Exception
  386. ''' <summary>
  387. ''' 执行超时。
  388. ''' </summary>
  389. Timeout
  390. ''' <summary>
  391. ''' 取消执行。可能是由于不满足执行的前置条件。
  392. ''' </summary>
  393. Cancel
  394. End Enum
  395. ''' <summary>
  396. ''' 可以使用 Equals 和等号的 List。
  397. ''' </summary>
  398. Public Class EqualableList(Of T)
  399. Inherits List(Of T)
  400. Public Overrides Function Equals(obj As Object) As Boolean
  401. If TryCast(obj, List(Of T)) Is Nothing Then
  402. '类型不同
  403. Return False
  404. Else
  405. '类型相同
  406. Dim objList As List(Of T) = obj
  407. If objList.Count <> Count Then Return False
  408. For i = 0 To objList.Count - 1
  409. If Not objList(i).Equals(Me(i)) Then Return False
  410. Next
  411. Return True
  412. End If
  413. End Function
  414. Public Shared Operator =(left As EqualableList(Of T), right As EqualableList(Of T)) As Boolean
  415. Return EqualityComparer(Of EqualableList(Of T)).Default.Equals(left, right)
  416. End Operator
  417. Public Shared Operator <>(left As EqualableList(Of T), right As EqualableList(Of T)) As Boolean
  418. Return Not left = right
  419. End Operator
  420. End Class
  421. #End Region
  422. #Region "数学"
  423. ''' <summary>
  424. ''' 计算二阶贝塞尔曲线。
  425. ''' </summary>
  426. Public Function MathBezier(x As Double, x1 As Double, y1 As Double, x2 As Double, y2 As Double, Optional acc As Double = 0.01) As Double
  427. If x <= 0 OrElse Double.IsNaN(x) Then Return 0
  428. If x >= 1 Then Return 1
  429. Dim a, b
  430. a = x
  431. Do
  432. b = 3 * a * ((0.33333333 + x1 - x2) * a * a + (x2 - 2 * x1) * a + x1)
  433. a += (x - b) * 0.5
  434. Loop Until Math.Abs(b - x) < acc '精度
  435. Return 3 * a * ((0.33333333 + y1 - y2) * a * a + (y2 - 2 * y1) * a + y1)
  436. End Function
  437. ''' <summary>
  438. ''' 将一个数字限制为 0~255 的 Byte 值。
  439. ''' </summary>
  440. Public Function MathByte(d As Double) As Byte
  441. If d < 0 Then d = 0
  442. If d > 255 Then d = 255
  443. Return Math.Round(d)
  444. End Function
  445. ''' <summary>
  446. ''' 提供 MyColor 类型支持的 Math.Round。
  447. ''' </summary>
  448. Public Function MathRound(col As MyColor, Optional w As Integer = 0) As MyColor
  449. Return New MyColor With {.A = Math.Round(col.A, w), .R = Math.Round(col.R, w), .G = Math.Round(col.G, w), .B = Math.Round(col.B, w)}
  450. End Function
  451. ''' <summary>
  452. ''' 获取两数间的百分比。小数点精确到 6 位。
  453. ''' </summary>
  454. ''' <returns></returns>
  455. ''' <remarks></remarks>
  456. Public Function MathPercent(ValueA As Double, ValueB As Double, Percent As Double) As Double
  457. Return Math.Round(ValueA * (1 - Percent) + ValueB * Percent, 6) '解决 Double 计算错误
  458. End Function
  459. ''' <summary>
  460. ''' 获取两颜色间的百分比,根据 RGB 计算。小数点精确到 6 位。
  461. ''' </summary>
  462. Public Function MathPercent(ValueA As MyColor, ValueB As MyColor, Percent As Double) As MyColor
  463. Return MathRound(ValueA * (1 - Percent) + ValueB * Percent, 6) '解决Double计算错误
  464. End Function
  465. ''' <summary>
  466. ''' 将数值限定在某个范围内。
  467. ''' </summary>
  468. Public Function MathRange(value As Double, min As Double, max As Double) As Double
  469. Return Math.Max(min, Math.Min(max, value))
  470. End Function
  471. ''' <summary>
  472. ''' 符号函数。
  473. ''' </summary>
  474. Public Function MathSgn(Value As Double) As Integer
  475. If Value = 0 Then
  476. Return 0
  477. ElseIf Value > 0 Then
  478. Return 1
  479. Else
  480. Return -1
  481. End If
  482. End Function
  483. #End Region
  484. #Region "文件"
  485. '注册表
  486. ''' <summary>
  487. ''' 重命名一个注册表子键。不可用于包含子键的子键。
  488. ''' </summary>
  489. Public Sub RegRename(parentKey As Microsoft.Win32.RegistryKey, subKeyName As String, newSubKeyName As String)
  490. If parentKey.GetSubKeyNames().Contains(newSubKeyName) Then parentKey.DeleteSubKeyTree(newSubKeyName, False)
  491. Dim SourceKey As Microsoft.Win32.RegistryKey = parentKey.OpenSubKey(subKeyName)
  492. If IsNothing(SourceKey) Then Exit Sub '没有目标项
  493. Dim NewKey As Microsoft.Win32.RegistryKey = parentKey.CreateSubKey(newSubKeyName)
  494. If SourceKey.GetSubKeyNames().Length > 0 Then Throw New NotSupportedException("不支持对包含子键的子键进行重命名:" & SourceKey.GetSubKeyNames()(0) & "。")
  495. For Each valueName As String In SourceKey.GetValueNames()
  496. Dim objValue As Object = SourceKey.GetValue(valueName)
  497. Dim valKind As Microsoft.Win32.RegistryValueKind = SourceKey.GetValueKind(valueName)
  498. NewKey.SetValue(valueName, objValue, valKind)
  499. Next
  500. parentKey.DeleteSubKeyTree(subKeyName, False)
  501. End Sub
  502. ''' <summary>
  503. ''' 读取程序所属注册表。
  504. ''' </summary>
  505. Public Function ReadReg(Key As String, Optional DefaultValue As String = "") As String
  506. Try
  507. Dim parentKey As Microsoft.Win32.RegistryKey, softKey As Microsoft.Win32.RegistryKey
  508. parentKey = My.Computer.Registry.CurrentUser
  509. softKey = parentKey.OpenSubKey("Software\PCL", True)
  510. If softKey Is Nothing Then
  511. ReadReg = DefaultValue '不存在则返回默认值
  512. Else
  513. Dim readValue As New Text.StringBuilder
  514. readValue.AppendLine(softKey.GetValue(Key))
  515. Dim value = readValue.ToString.Replace(vbCrLf, "") '去除莫名的回车
  516. Return If(value = "", DefaultValue, value) '错误则返回默认值
  517. End If
  518. Catch ex As Exception
  519. Log(ex, "读取注册表出错:" & Key, LogLevel.Hint)
  520. Return DefaultValue
  521. End Try
  522. End Function
  523. ''' <summary>
  524. ''' 写入程序所属注册表。
  525. ''' </summary>
  526. Public Sub WriteReg(Key As String, Value As String, Optional ShowException As Boolean = False)
  527. Try
  528. Dim parentKey As Microsoft.Win32.RegistryKey, softKey As Microsoft.Win32.RegistryKey
  529. parentKey = My.Computer.Registry.CurrentUser
  530. softKey = parentKey.OpenSubKey("Software\PCL", True)
  531. If softKey Is Nothing Then softKey = parentKey.CreateSubKey("Software\PCL") '如果不存在就创建
  532. softKey.SetValue(Key, Value)
  533. Catch ex As Exception
  534. Log(ex, "写入注册表出错:" & Key, If(ShowException, LogLevel.Hint, LogLevel.Developer))
  535. If ShowException Then Throw '如果显示错误就丢一个
  536. End Try
  537. End Sub
  538. 'Ini 文件
  539. Private Class IniCache
  540. Public FileContent As String = ""
  541. Public KVCache As New Dictionary(Of String, String)
  542. End Class
  543. Private ReadOnly IniCacheList As New Dictionary(Of String, IniCache)
  544. ''' <summary>
  545. ''' 清除某 Ini 文件的运行时缓存。
  546. ''' </summary>
  547. ''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
  548. Public Sub IniClearCache(FileName As String)
  549. '还原文件路径
  550. If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
  551. '检索缓存
  552. If IniCacheList.ContainsKey(FileName) Then IniCacheList.Remove(FileName)
  553. End Sub
  554. ''' <summary>
  555. ''' 获取 Ini 文件内容,这可能会使用到缓存。
  556. ''' </summary>
  557. ''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
  558. Private Function IniGetContent(FileName As String) As IniCache
  559. Try
  560. '还原文件路径
  561. If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
  562. '检索缓存
  563. If IniCacheList.ContainsKey(FileName) Then
  564. '返回缓存中的信息
  565. Dim Cache As New IniCache
  566. IniCacheList.TryGetValue(FileName, Cache)
  567. Return Cache '防止ByRef导致缓存变更
  568. Else
  569. Dim Ini As IniCache
  570. If File.Exists(FileName) Then
  571. '返回文件信息并且记入缓存
  572. Dim Cache As String = (vbCrLf & ReadFile(FileName) & vbCrLf).Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr, vbCrLf).Replace(vbCrLf & vbCrLf, vbCrLf).Replace(vbNullChar, "")
  573. Ini = New IniCache With {.FileContent = Cache}
  574. Else
  575. '返回空文件信息
  576. Ini = New IniCache With {.FileContent = ""}
  577. End If
  578. If Not IniCacheList.ContainsKey(FileName) Then IniCacheList.Add(FileName, Ini) '避免多线程异步执行此方法时造成多次添加项
  579. Return Ini
  580. End If
  581. Catch ex As Exception
  582. Log(ex, "读取文件失败:" & FileName, LogLevel.Hint)
  583. Return New IniCache With {.FileContent = ""}
  584. End Try
  585. End Function
  586. ''' <summary>
  587. ''' 读取Ini文件,这可能会使用到缓存。
  588. ''' </summary>
  589. ''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
  590. ''' <param name="Key">键。</param>
  591. ''' <param name="DefaultValue">没有找到键时返回的默认值。</param>
  592. Public Function ReadIni(FileName As String, Key As String, Optional DefaultValue As String = "") As String
  593. Try
  594. '获取目前文件
  595. Dim NowIni As IniCache = IniGetContent(FileName)
  596. If IsNothing(NowIni) Then Return DefaultValue
  597. '使用缓存
  598. If NowIni.KVCache.ContainsKey(Key) Then Return If(NowIni.KVCache(Key), DefaultValue)
  599. '没有缓存,读取文件
  600. If NowIni.FileContent.Contains(vbCrLf & Key & ":") Then
  601. Dim Ret As String = Mid(NowIni.FileContent, NowIni.FileContent.IndexOf(vbCrLf & Key & ":") + 3)
  602. Ret = If(Ret.Contains(vbCrLf), Mid(Ret, 1, Ret.IndexOf(vbCrLf)), Ret).Replace(Key & ":", "")
  603. NowIni.KVCache.Add(Key, If(Ret = vbLf, "", Ret))
  604. Return If(Ret = vbLf, "", Ret)
  605. Else
  606. Return DefaultValue
  607. End If
  608. Catch ex As Exception
  609. '读取失败
  610. Return DefaultValue
  611. End Try
  612. End Function
  613. ''' <summary>
  614. ''' 写入ini文件,这会更新缓存。
  615. ''' </summary>
  616. ''' <param name="FileName">文件完整路径或简写文件名。简写将会使用“ApplicationName\文件名.ini”作为路径。</param>
  617. ''' <param name="Key">键。</param>
  618. ''' <param name="Value">值。</param>
  619. ''' <remarks></remarks>
  620. Public Sub WriteIni(FileName As String, Key As String, Value As String)
  621. Try
  622. '还原文件路径
  623. If Not FileName.Contains(":\") Then FileName = Path & "PCL\" & FileName & ".ini"
  624. If IsNothing(Value) Then Value = ""
  625. Value = Value.Replace(vbCrLf, "")
  626. '创建文件夹
  627. If Not Directory.Exists(GetPathFromFullPath(FileName)) Then Directory.CreateDirectory(GetPathFromFullPath(FileName))
  628. '获取目前文件
  629. Dim NowFile As String = IniGetContent(FileName).FileContent
  630. If Not NowFile.EndsWith(vbCrLf) Then NowFile += vbCrLf
  631. '如果值一样就不处理
  632. If NowFile.Contains(vbCrLf & Key & ":" & Value & vbCrLf) Then Exit Sub
  633. '处理文件
  634. Dim FindResult As String = ReadIni(FileName, Key)
  635. If FindResult = "" AndAlso Not NowFile.Contains(vbCrLf & Key & ":") Then
  636. '不存在这个键
  637. NowFile = NowFile & vbCrLf & Key & ":" & Value & vbCrLf
  638. Else
  639. '存在这个键
  640. NowFile = NowFile.Replace(vbCrLf & Key & ":" & FindResult & vbCrLf, vbCrLf & Key & ":" & Value & vbCrLf)
  641. End If
  642. WriteFile(FileName, NowFile)
  643. '刷新目前缓存
  644. IniCacheList(FileName).FileContent = NowFile
  645. IniCacheList(FileName).KVCache.Remove(Key)
  646. IniCacheList(FileName).KVCache.Add(Key, Value)
  647. Catch ex As Exception
  648. Log(ex, "写入文件失败:" & FileName & "/" & Key & ": " & Value)
  649. End Try
  650. End Sub
  651. '路径处理
  652. ''' <summary>
  653. ''' 从文件路径或者 Url 获取不包含文件名的路径,或获取文件夹的父文件夹路径。不包含路径将会抛出异常。
  654. ''' </summary>
  655. Public Function GetPathFromFullPath(FilePath As String) As String
  656. If Not (FilePath.Contains("\") OrElse FilePath.Contains("/")) Then Throw New Exception("不包含路径:" & FilePath)
  657. If FilePath.EndsWith("\") OrElse FilePath.EndsWith("/") Then
  658. '是文件夹路径
  659. Dim IsRight As Boolean = FilePath.EndsWith("\")
  660. FilePath = Left(FilePath, Len(FilePath) - 1)
  661. GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"})) & If(IsRight, "\", "/")
  662. If GetPathFromFullPath = "" Then Throw New Exception("不包含路径:" & FilePath)
  663. Else
  664. '是文件路径
  665. GetPathFromFullPath = Left(FilePath, FilePath.LastIndexOfAny({"\", "/"}) + 1)
  666. If GetPathFromFullPath = "" Then Throw New Exception("不包含路径:" & FilePath)
  667. End If
  668. End Function
  669. ''' <summary>
  670. ''' 从文件路径或者 Url 获取不包含路径的文件名。不包含文件名将会抛出异常。
  671. ''' </summary>
  672. Public Function GetFileNameFromPath(FilePath As String) As String
  673. If FilePath.EndsWith("\") OrElse FilePath.EndsWith("/") Then Throw New Exception("不包含文件名:" & FilePath)
  674. If Not (FilePath.Contains("\") OrElse FilePath.Contains("/")) Then Return FilePath
  675. If FilePath.Contains("?") Then FilePath = Left(FilePath, FilePath.LastIndexOf("?")) '去掉网络参数后的 ?
  676. GetFileNameFromPath = Mid(FilePath, FilePath.LastIndexOfAny({"\", "/"}) + 2)
  677. If GetFileNameFromPath = "" Then Throw New Exception("不包含文件名:" & FilePath)
  678. End Function
  679. ''' <summary>
  680. ''' 从文件路径或者 Url 获取不包含路径与扩展名的文件名。不包含文件名将会抛出异常。
  681. ''' </summary>
  682. Public Function GetFileNameWithoutExtentionFromPath(FilePath As String) As String
  683. Dim Name As String = GetFileNameFromPath(FilePath)
  684. If Name.Contains(".") Then
  685. Return Name.Substring(0, Name.LastIndexOf("."))
  686. Else
  687. Return Name
  688. End If
  689. End Function
  690. ''' <summary>
  691. ''' 从文件夹路径获取文件夹名。
  692. ''' </summary>
  693. Public Function GetFolderNameFromPath(FolderPath As String) As String
  694. If FolderPath.EndsWith(":\") OrElse FolderPath.EndsWith(":\\") Then Return FolderPath.Substring(0, 1)
  695. If FolderPath.EndsWith("\") OrElse FolderPath.EndsWith("/") Then FolderPath = Left(FolderPath, FolderPath.Length - 1)
  696. Return GetFileNameFromPath(FolderPath)
  697. End Function
  698. '读取、写入文件
  699. ''' <summary>
  700. ''' 读取文件,如果失败则返回空字符串。
  701. ''' </summary>
  702. ''' <param name="FilePath">文件完整或相对路径。</param>
  703. Public Function ReadFile(FilePath As String) As String
  704. Try
  705. '还原文件路径
  706. If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
  707. If File.Exists(FilePath) Then
  708. ReadFile = DecodeBytes(File.ReadAllBytes(FilePath))
  709. Else
  710. Log("[System] 欲读取的文件不存在,已返回空字符串:" & FilePath)
  711. Return ""
  712. End If
  713. Catch ex As Exception
  714. Log(ex, "读取文件出错:" & FilePath)
  715. Return ""
  716. End Try
  717. End Function
  718. ''' <summary>
  719. ''' 读取流中的所有文本。
  720. ''' </summary>
  721. Public Function ReadFile(Stream As Stream, Optional Encoding As Encoding = Nothing) As String
  722. Try
  723. Dim srcBuf As Byte() = New Byte(16384) {}
  724. Dim DataCount As Integer = Stream.Read(srcBuf, 0, 16384)
  725. Dim Result As New List(Of Byte)
  726. While DataCount > 0
  727. If DataCount > 0 Then Result.AddRange(srcBuf.ToList.GetRange(0, DataCount))
  728. DataCount = Stream.Read(srcBuf, 0, 16384)
  729. End While
  730. Dim Bts = Result.ToArray
  731. Return If(Encoding, GetEncoding(Bts)).GetString(Bts)
  732. Catch ex As Exception
  733. Log(ex, "读取流出错")
  734. Return ""
  735. End Try
  736. End Function
  737. ''' <summary>
  738. ''' 写入文件。
  739. ''' </summary>
  740. ''' <param name="FilePath">文件完整或相对路径。</param>
  741. ''' <param name="Text">文件内容。</param>
  742. ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
  743. Public Function WriteFile(FilePath As String, Text As String, Optional Append As Boolean = False, Optional Encoding As Encoding = Nothing) As Boolean
  744. Try
  745. '还原文件路径
  746. If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
  747. '确保目录存在
  748. Directory.CreateDirectory(GetPathFromFullPath(FilePath))
  749. '写入文件
  750. If File.Exists(FilePath) Then
  751. '如果文件存在,刷新目前文件
  752. Using writer As New StreamWriter(FilePath, Append, If(Encoding, GetEncoding(FilePath)))
  753. writer.Write(Text)
  754. writer.Flush()
  755. writer.Close()
  756. End Using
  757. Else
  758. '如果文件不存在,则新建并写入
  759. File.WriteAllText(FilePath, Text, If(Encoding, New UTF8Encoding(False)))
  760. End If
  761. Return True
  762. Catch ex As Exception
  763. Log(ex, "写入文件时出错:" & FilePath)
  764. Return False
  765. End Try
  766. End Function
  767. ''' <summary>
  768. ''' 写入文件。
  769. ''' </summary>
  770. ''' <param name="FilePath">文件完整或相对路径。</param>
  771. ''' <param name="Content">文件内容。</param>
  772. ''' <param name="Append">是否将文件内容追加到当前文件,而不是覆盖它。</param>
  773. Public Function WriteFile(FilePath As String, Content As Byte(), Optional Append As Boolean = False) As Boolean
  774. Try
  775. '还原文件路径
  776. If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
  777. '确保目录存在
  778. Directory.CreateDirectory(GetPathFromFullPath(FilePath))
  779. '写入文件
  780. File.WriteAllBytes(FilePath, Content)
  781. 'File.Exists 的写法只会写入 System.Byte[](无法进行转码,Write 不支持写入 Byte[])
  782. 'If File.Exists(FilePath) Then
  783. ' '如果文件存在,刷新目前文件
  784. ' Using writer As New StreamWriter(FilePath, Append, GetEncoding(FilePath))
  785. ' writer.Write(Content)
  786. ' writer.Flush()
  787. ' writer.Close()
  788. ' End Using
  789. 'Else
  790. ' '如果文件不存在,则新建并写入
  791. ' File.WriteAllBytes(FilePath, Content)
  792. 'End If
  793. Return True
  794. Catch ex As Exception
  795. Log(ex, "写入文件时出错:" & FilePath)
  796. Return False
  797. End Try
  798. End Function
  799. ''' <summary>
  800. ''' 将流写入文件。
  801. ''' </summary>
  802. ''' <param name="FilePath">文件完整或相对路径。</param>
  803. Public Function WriteFile(FilePath As String, Stream As Stream) As Boolean
  804. Try
  805. '还原文件路径
  806. If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
  807. '确保目录存在
  808. Directory.CreateDirectory(GetPathFromFullPath(FilePath))
  809. '读取流
  810. Using fs As New FileStream(FilePath, FileMode.Create, FileAccess.Write)
  811. Dim srcBuf As Byte() = New Byte(16384) {}
  812. Dim DataCount As Integer = Stream.Read(srcBuf, 0, 16384)
  813. While DataCount > 0
  814. If DataCount > 0 Then fs.Write(srcBuf, 0, DataCount)
  815. DataCount = Stream.Read(srcBuf, 0, 16384)
  816. End While
  817. fs.Close()
  818. End Using
  819. Return True
  820. Catch ex As Exception
  821. Log(ex, "保存流出错")
  822. Return False
  823. End Try
  824. End Function
  825. '文件编码
  826. ''' <summary>
  827. ''' 获取文件编码。
  828. ''' </summary>
  829. ''' <param name="FilePath">文件完整或相对路径。</param>
  830. Public Function GetEncoding(FilePath As String) As Encoding
  831. '还原文件路径
  832. If Not FilePath.Contains(":\") Then FilePath = Path & FilePath
  833. '获取编码
  834. GetEncoding = GetEncoding(File.ReadAllBytes(FilePath))
  835. End Function
  836. ''' <summary>
  837. ''' 获取 Bytes 的编码。
  838. ''' </summary>
  839. Public Function GetEncoding(Bytes As Byte()) As Encoding
  840. Dim Length As Integer = Bytes.Count
  841. If Length <= 2 Then Return New UTF8Encoding(False) '不带 BOM 的 UTF8
  842. '根据 BOM 判断编码
  843. If Bytes(0) >= &HEF Then
  844. '有 BOM 类型
  845. If Bytes(0) = &HEF AndAlso Bytes(1) = &HBB Then
  846. Return New UTF8Encoding(True) '带 BOM 的 UTF8
  847. ElseIf Bytes(0) = &HFE AndAlso Bytes(1) = &HFF Then
  848. Return Encoding.BigEndianUnicode
  849. ElseIf Bytes(0) = &HFF AndAlso Bytes(1) = &HFE Then
  850. Return Encoding.Unicode
  851. Else
  852. Return Encoding.GetEncoding("GB18030")
  853. End If
  854. End If
  855. '无 BOM 文件:GB18030(ANSI)或 UTF8
  856. Dim UTF8 = Encoding.UTF8.GetString(Bytes)
  857. Dim ErrorChar As Char = Encoding.UTF8.GetString({239, 191, 189}).ToCharArray()(0)
  858. If UTF8.Contains(ErrorChar) Then
  859. Return Encoding.GetEncoding("GB18030")
  860. Else
  861. Return New UTF8Encoding(False) '不带 BOM 的 UTF8
  862. End If
  863. End Function
  864. ''' <summary>
  865. ''' 解码 Bytes。
  866. ''' </summary>
  867. Public Function DecodeBytes(Bytes As Byte()) As String
  868. Dim Length As Integer = Bytes.Length
  869. If Length < 3 Then Return Encoding.UTF8.GetString(Bytes)
  870. '根据 BOM 判断编码
  871. If Bytes(0) >= &HEF Then
  872. '有 BOM 类型
  873. If Bytes(0) = &HEF AndAlso Bytes(1) = &HBB Then
  874. Return Encoding.UTF8.GetString(Bytes, 3, Length - 3)
  875. ElseIf Bytes(0) = &HFE AndAlso Bytes(1) = &HFF Then
  876. Return Encoding.BigEndianUnicode.GetString(Bytes, 3, Length - 3)
  877. ElseIf Bytes(0) = &HFF AndAlso Bytes(1) = &HFE Then
  878. Return Encoding.Unicode.GetString(Bytes, 3, Length - 3)
  879. Else
  880. Return Encoding.GetEncoding("GB18030").GetString(Bytes, 3, Length - 3)
  881. End If
  882. End If
  883. '无 BOM 文件:GB18030(ANSI)或 UTF8
  884. Dim UTF8 = Encoding.UTF8.GetString(Bytes)
  885. Dim ErrorChar As Char = Encoding.UTF8.GetString({239, 191, 189}).ToCharArray()(0)
  886. If UTF8.Contains(ErrorChar) Then
  887. Return Encoding.GetEncoding("GB18030").GetString(Bytes)
  888. Else
  889. Return UTF8
  890. End If
  891. End Function
  892. '对话框
  893. ''' <summary>
  894. ''' 弹出保存对话框并且要求保存位置,返回用户输入的完整路径。
  895. ''' </summary>
  896. ''' <param name="FileFilter">要求的格式。如:“常用图片文件(*.png;*.jpg)|*.png;*.jpg”。</param>
  897. ''' <param name="Title">弹窗的标题。</param>
  898. ''' <param name="FileName">默认的文件名。</param>
  899. Public Function SelectAs(Title As String, FileName As String, Optional FileFilter As String = Nothing, Optional DefaultDir As String = Nothing) As String
  900. Using fileDialog As New Forms.SaveFileDialog
  901. fileDialog.AddExtension = True
  902. fileDialog.AutoUpgradeEnabled = True
  903. fileDialog.Title = Title
  904. fileDialog.FileName = FileName
  905. If FileFilter IsNot Nothing Then fileDialog.Filter = FileFilter
  906. If DefaultDir IsNot Nothing Then fileDialog.InitialDirectory = DefaultDir
  907. fileDialog.ShowDialog()
  908. SelectAs = If(fileDialog.FileName.Contains(":\"), fileDialog.FileName, "")
  909. Log("[UI] 选择文件返回:" & SelectAs)
  910. End Using
  911. End Function
  912. ''' <summary>
  913. ''' 弹出选取文件对话框并且要求选取文件。
  914. ''' </summary>
  915. ''' <param name="FileFilter">要求的格式。如:“常用图片文件(*.png;*.jpg)|*.png;*.jpg”。</param>
  916. ''' <param name="Title">弹窗的标题。</param>
  917. Public Function SelectFile(FileFilter As String, Title As String) As String
  918. Using fileDialog As New Forms.OpenFileDialog
  919. fileDialog.AddExtension = True
  920. fileDialog.AutoUpgradeEnabled = True
  921. fileDialog.CheckFileExists = True
  922. fileDialog.Filter = FileFilter
  923. fileDialog.Multiselect = False
  924. fileDialog.Title = Title
  925. fileDialog.ValidateNames = True
  926. fileDialog.ShowDialog()
  927. SelectFile = fileDialog.FileName
  928. Log("[UI] 选择文件返回:" & SelectFile)
  929. End Using
  930. End Function
  931. ''' <summary>
  932. ''' 弹出选取文件夹对话框并且要求选取文件夹。如果没有选择就返回空字符串。
  933. ''' </summary>
  934. Public Function SelectFolder(Optional Title As String = "选择文件夹") As String
  935. Dim folderDialog As New Ookii.Dialogs.Wpf.VistaFolderBrowserDialog With {.ShowNewFolderButton = True, .RootFolder = Environment.SpecialFolder.Desktop, .Description = Title, .UseDescriptionForTitle = True}
  936. folderDialog.ShowDialog()
  937. SelectFolder = If(String.IsNullOrEmpty(folderDialog.SelectedPath), "", folderDialog.SelectedPath & If(folderDialog.SelectedPath.EndsWith("\"), "", "\"))
  938. Log("[UI] 选择文件夹返回:" & SelectFolder)
  939. End Function
  940. '文件校验
  941. ''' <summary>
  942. ''' 检查是否拥有某一文件夹的 I/O 权限。如果文件夹不存在,会返回 False。
  943. ''' </summary>
  944. Public Function CheckPermission(Path As String) As Boolean
  945. Try
  946. If Path = "" Then Return False
  947. If Not Path.EndsWith("\") Then Path += "\"
  948. If Path.EndsWith(":\System Volume Information\") OrElse Path.EndsWith(":\$RECYCLE.BIN\") Then Return False
  949. If Not Directory.Exists(Path) Then Return False
  950. Dim FileName As String = "CheckPermission" & GetUuid()
  951. If File.Exists(Path & FileName) Then File.Delete(Path & FileName)
  952. File.Create(Path & FileName).Dispose()
  953. File.Delete(Path & FileName)
  954. Return True
  955. Catch ex As Exception
  956. Log(ex, "没有对文件夹 " & Path & " 的权限,请尝试以管理员权限运行 PCL")
  957. Return False
  958. End Try
  959. End Function
  960. ''' <summary>
  961. ''' 检查是否拥有某一文件夹的 I/O 权限。如果出错,则抛出异常。
  962. ''' </summary>
  963. Public Sub CheckPermissionWithException(Path As String)
  964. If String.IsNullOrWhiteSpace(Path) Then Throw New ArgumentNullException("文件夹名不能为空!")
  965. If Not Path.EndsWith("\") Then Path += "\"
  966. If Not Directory.Exists(Path) Then Throw New DirectoryNotFoundException("文件夹不存在!")
  967. If File.Exists(Path & "CheckPermission") Then File.Delete(Path & "CheckPermission")
  968. File.Create(Path & "CheckPermission").Dispose()
  969. File.Delete(Path & "CheckPermission")
  970. End Sub
  971. ''' <summary>
  972. ''' 获取文件 MD5,若失败则返回空字符串。
  973. ''' </summary>
  974. Public Function GetAuthMD5(FilePath As String) As String
  975. Dim Retry As Boolean = False
  976. Re:
  977. Try
  978. '获取 MD5
  979. Dim Result As New StringBuilder()
  980. Dim File As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
  981. Dim MD5 As MD5 = New MD5CryptoServiceProvider()
  982. Dim Retval As Byte() = MD5.ComputeHash(File)
  983. File.Close()
  984. For i = 0 To Retval.Length - 1
  985. Result.Append(Retval(i).ToString("x2"))
  986. Next
  987. Return Result.ToString
  988. Catch ex As Exception
  989. If Not Retry Then
  990. Retry = True
  991. Log(ex, "获取文件 MD5 可重试失败:" & FilePath, LogLevel.Normal)
  992. Thread.Sleep(RandomInteger(200, 500))
  993. GoTo Re
  994. Else
  995. Log(ex, "获取文件 MD5 失败:" & FilePath)
  996. Return ""
  997. End If
  998. End Try
  999. End Function
  1000. ''' <summary>
  1001. ''' 获取文件 SHA256,若失败则返回空字符串。
  1002. ''' </summary>
  1003. Public Function GetAuthSHA256(FilePath As String) As String
  1004. Dim Retry As Boolean = False
  1005. Re:
  1006. Try
  1007. ''检测该文件是否在下载中,若在下载则放弃检测
  1008. 'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return ""
  1009. '获取 SHA256
  1010. Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
  1011. Dim sha1 As SHA256 = New SHA256CryptoServiceProvider()
  1012. Dim retval As Byte() = sha1.ComputeHash(file)
  1013. file.Close()
  1014. Dim Result As New StringBuilder()
  1015. For i As Integer = 0 To retval.Length - 1
  1016. Result.Append(retval(i).ToString("x2"))
  1017. Next
  1018. Return Result.ToString
  1019. Catch ex As Exception
  1020. If Not Retry Then
  1021. Retry = True
  1022. Log(ex, "获取文件 SHA256 可重试失败:" & FilePath, LogLevel.Normal)
  1023. Thread.Sleep(RandomInteger(200, 500))
  1024. GoTo Re
  1025. Else
  1026. Log(ex, "获取文件 SHA256 失败:" & FilePath)
  1027. Return ""
  1028. End If
  1029. End Try
  1030. End Function
  1031. ''' <summary>
  1032. ''' 获取文件 SHA1,若失败则返回空字符串。
  1033. ''' </summary>
  1034. Public Function GetAuthSHA1(FilePath As String) As String
  1035. Dim Retry As Boolean = False
  1036. Re:
  1037. Try
  1038. ''检测该文件是否在下载中,若在下载则放弃检测
  1039. 'If IgnoreOnDownloading AndAlso NetManage.Files.ContainsKey(FilePath) AndAlso NetManage.Files(FilePath).State <= NetState.Merge Then Return ""
  1040. '获取 SHA1
  1041. Dim file As New FileStream(FilePath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
  1042. Dim sha1 As SHA1 = New SHA1CryptoServiceProvider()
  1043. Dim retval As Byte() = sha1.ComputeHash(file)
  1044. file.Close()
  1045. Dim Result As New StringBuilder()
  1046. For i As Integer = 0 To retval.Length - 1
  1047. Result.Append(retval(i).ToString("x2"))
  1048. Next
  1049. Return Result.ToString
  1050. Catch ex As Exception
  1051. If Not Retry Then
  1052. Retry = True
  1053. Log(ex, "获取文件 SHA1 可重试失败:" & FilePath, LogLevel.Normal)
  1054. Thread.Sleep(RandomInteger(200, 500))
  1055. GoTo Re
  1056. Else
  1057. Log(ex, "获取文件 SHA1 失败:" & FilePath)
  1058. Return ""
  1059. End If
  1060. End Try
  1061. End Function
  1062. ''' <summary>
  1063. ''' 获取流 SHA1,若失败则返回空字符串。
  1064. ''' </summary>
  1065. Public Function GetAuthSHA1(Stream As Stream) As String
  1066. Try
  1067. Dim sha1 As SHA1 = New SHA1CryptoServiceProvider()
  1068. Dim retval As Byte() = sha1.ComputeHash(Stream)
  1069. Dim Result As New StringBuilder()
  1070. For i As Integer = 0 To retval.Length - 1
  1071. Result.Append(retval(i).ToString("x2"))
  1072. Next
  1073. Return Result.ToString
  1074. Catch ex As Exception
  1075. Log(ex, "获取流 SHA1 失败")
  1076. Return ""
  1077. End Try
  1078. End Function
  1079. ''' <summary>
  1080. ''' 文件的校验规则。
  1081. ''' </summary>
  1082. Public Class FileChecker
  1083. ''' <summary>
  1084. ''' 文件的准确大小。
  1085. ''' </summary>
  1086. Public ActualSize As Long = -1
  1087. ''' <summary>
  1088. ''' 文件的最小大小。
  1089. ''' </summary>
  1090. Public MinSize As Long = -1
  1091. ''' <summary>
  1092. ''' 文件的 MD5、SHA1 或 SHA256。会根据输入字符串的长度自动判断种类。
  1093. ''' </summary>
  1094. Public Hash As String = Nothing
  1095. ''' <summary>
  1096. ''' 是否可以使用已经存在的文件。
  1097. ''' </summary>
  1098. Public CanUseExistsFile As Boolean = True
  1099. ''' <summary>
  1100. ''' 是否为 Json 文件。
  1101. ''' </summary>
  1102. Public IsJson As Boolean = False
  1103. Public Sub New(Optional MinSize As Long = -1, Optional ActualSize As Long = -1, Optional Hash As String = Nothing, Optional CanUseExistsFile As Boolean = True, Optional IsJson As Boolean = False)
  1104. Me.ActualSize = ActualSize
  1105. Me.MinSize = MinSize
  1106. Me.Hash = Hash
  1107. Me.CanUseExistsFile = CanUseExistsFile
  1108. Me.IsJson = IsJson
  1109. End Sub
  1110. ''' <summary>
  1111. ''' 检查文件。若成功则返回 Nothing,失败则返回错误的描述文本,描述文本不以句号结尾。不会抛出错误。
  1112. ''' </summary>
  1113. Public Function Check(LocalPath As String) As String
  1114. Try
  1115. Dim Info As New FileInfo(LocalPath)
  1116. If Not Info.Exists Then Return "文件不存在:" & LocalPath
  1117. Dim FileSize As Long = Info.Length
  1118. If ActualSize >= 0 AndAlso ActualSize <> FileSize Then Return "文件大小应为 " & ActualSize & " B,实际为 " & FileSize & " B"
  1119. If MinSize >= 0 AndAlso MinSize > FileSize Then Return "文件大小应大于 " & MinSize & " B,实际为 " & FileSize & " B"
  1120. If Not String.IsNullOrEmpty(Hash) Then
  1121. If Hash.Length < 35 Then 'MD5
  1122. If Hash <> GetAuthMD5(LocalPath) Then Return "文件 MD5 应为 " & Hash & ",实际为 " & GetAuthMD5(LocalPath)
  1123. ElseIf Hash.Length = 64 Then 'SHA256
  1124. If Hash <> GetAuthSHA256(LocalPath) Then Return "文件 SHA256 应为 " & Hash & ",实际为 " & GetAuthSHA256(LocalPath)
  1125. Else 'SHA1
  1126. If Hash <> GetAuthSHA1(LocalPath) Then Return "文件 SHA1 应为 " & Hash & ",实际为 " & GetAuthSHA1(LocalPath)
  1127. End If
  1128. End If
  1129. If IsJson Then
  1130. Dim Content As String = ReadFile(LocalPath)
  1131. If Content = "" Then Throw New Exception("读取到的文件为空")
  1132. Try
  1133. GetJson(Content)
  1134. Catch ex As Exception
  1135. Throw New Exception("不是有效的 Json 文件", ex)
  1136. End Try
  1137. End If
  1138. Return Nothing
  1139. Catch ex As Exception
  1140. Log(ex, "检查文件出错")
  1141. Return GetString(ex)
  1142. End Try
  1143. End Function
  1144. End Class
  1145. ''' <summary>
  1146. ''' 尝试根据后缀名判断文件种类并解压文件,支持 gz 与 zip,会尝试将 jar 以 zip 方式解压。
  1147. ''' 会尝试创建,但不会清空目标文件夹。
  1148. ''' 成功返回 True,并非压缩文件或失败返回 False。
  1149. ''' </summary>
  1150. Public Function ExtractFile(CompressFilePath As String, DestDirectory As String, Optional Encode As Encoding = Nothing) As Boolean
  1151. Try
  1152. Directory.CreateDirectory(DestDirectory)
  1153. If CompressFilePath.EndsWith(".zip") OrElse CompressFilePath.EndsWith(".jar") Then
  1154. '以 zip 方式解压
  1155. ZipFile.ExtractToDirectory(CompressFilePath, DestDirectory, If(Encode, Encoding.Default))
  1156. Return True
  1157. ElseIf CompressFilePath.EndsWith(".gz") Then
  1158. '以 gz 方式解压
  1159. Dim stream As New GZipStream(New FileStream(CompressFilePath, FileMode.Open, FileAccess.ReadWrite), CompressionMode.Decompress)
  1160. Dim decompressedFile As New FileStream(DestDirectory & GetFileNameFromPath(CompressFilePath).ToLower.Replace(".tar", "").Replace(".gz", ""), FileMode.OpenOrCreate, FileAccess.Write)
  1161. Dim data As Integer = stream.ReadByte()
  1162. While data <> -1
  1163. decompressedFile.WriteByte(data)
  1164. data = stream.ReadByte()
  1165. End While
  1166. decompressedFile.Close()
  1167. stream.Close()
  1168. Return True
  1169. Else
  1170. Return False
  1171. End If
  1172. Catch ex As Exception
  1173. Log(ex, "尝试解压文件失败")
  1174. Return False
  1175. End Try
  1176. End Function
  1177. ''' <summary>
  1178. ''' 删除文件夹。失败会抛出异常。
  1179. ''' </summary>
  1180. Public Sub DeleteDirectory(Path As String, Optional IgnoreIssue As Boolean = False)
  1181. If Not Directory.Exists(Path) Then Exit Sub
  1182. Dim Temp As String()
  1183. Temp = Directory.GetFiles(Path)
  1184. For Each str As String In Temp
  1185. Try
  1186. File.Delete(str)
  1187. Catch ex As Exception
  1188. If IgnoreIssue Then
  1189. Log(ex, "删除单个文件可忽略地失败")
  1190. Else
  1191. Throw
  1192. End If
  1193. End Try
  1194. Next
  1195. Temp = Directory.GetDirectories(Path)
  1196. For Each str As String In Temp
  1197. DeleteDirectory(str)
  1198. Next
  1199. Try
  1200. Directory.Delete(Path, True)
  1201. Catch ex As Exception
  1202. If IgnoreIssue Then
  1203. Log(ex, "删除单个文件夹可忽略地失败")
  1204. Else
  1205. Throw
  1206. End If
  1207. End Try
  1208. '这个也不靠谱,目录不是空的警告
  1209. 'My.Computer.FileSystem.DeleteDirectory(Path, FileIO.DeleteDirectoryOption.DeleteAllContents)
  1210. End Sub
  1211. ''' <summary>
  1212. ''' 遍历文件夹中的所有文件。
  1213. ''' </summary>
  1214. Public Function EnumerateFiles(Directory As String) As List(Of FileInfo)
  1215. Dim Dir As New DirectoryInfo(Directory)
  1216. Dim ResultList As New List(Of FileInfo)
  1217. '添加文件
  1218. ResultList.AddRange(Dir.EnumerateFiles)
  1219. '添加文件夹中的文件
  1220. For Each SubDir In Dir.EnumerateDirectories
  1221. ResultList.AddRange(EnumerateFiles(SubDir.FullName))
  1222. Next
  1223. Return ResultList
  1224. End Function
  1225. #End Region
  1226. #Region "文本"
  1227. Public vbLQ As Char = Convert.ToChar(8220)
  1228. Public vbRQ As Char = Convert.ToChar(8221)
  1229. ''' <summary>
  1230. ''' 提取 Exception 摘要。
  1231. ''' </summary>
  1232. ''' <param name="IsLine">输出是否强制为单行,单行模型下不会输出调用堆栈。</param>
  1233. Public Function GetString(Ex As Exception, Optional IsLine As Boolean = True, Optional ShowAllTrace As Boolean = False) As String
  1234. If Ex Is Nothing Then Return "无可用错误信息!"
  1235. Dim Desc As New List(Of String)
  1236. '自动错误判断
  1237. Dim RealEx = Ex
  1238. Do Until RealEx.InnerException Is Nothing
  1239. RealEx = RealEx.InnerException
  1240. Loop
  1241. If TypeOf RealEx Is TypeLoadException OrElse TypeOf RealEx Is MissingMethodException OrElse TypeOf RealEx Is NotImplementedException OrElse TypeOf RealEx Is TypeInitializationException Then
  1242. Desc.Add("系统环境存在问题,请尝试重装 .Net Framework 4.6.2 后再试")
  1243. ElseIf TypeOf RealEx Is UnauthorizedAccessException Then
  1244. Desc.Add("PCL2 权限不足,请尝试右键 PCL2,选择以管理员身份运行")
  1245. ElseIf TypeOf RealEx Is OutOfMemoryException Then
  1246. Desc.Add("电脑运行内存不足,PCL2 无法继续运行")
  1247. End If
  1248. If IsLine Then
  1249. '无内部错误的快速处理
  1250. If Ex.InnerException Is Nothing Then
  1251. If Desc.Count = 0 Then
  1252. Return Ex.Message.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr & vbCr, vbCr).Replace(vbCr, " ")
  1253. Else
  1254. Return Desc.First
  1255. End If
  1256. End If
  1257. '构造输出信息
  1258. Do Until Ex Is Nothing
  1259. Desc.Add(Ex.Message.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr & vbCr, vbCr).Replace(vbCr, " "))
  1260. Ex = Ex.InnerException
  1261. Loop
  1262. Desc.Reverse() '让最深层错误在最左边
  1263. GetString = Join(Desc, " → ")
  1264. Else
  1265. Dim Stack As New List(Of String)
  1266. '逐级追加描述与堆栈
  1267. Do Until Ex Is Nothing
  1268. Desc.Add(Ex.Message.Replace(vbCrLf, vbCr).Replace(vbLf, vbCr).Replace(vbCr & vbCr, vbCr).Replace(vbCr, vbCrLf))
  1269. If Ex.StackTrace IsNot Nothing Then
  1270. For Each St As String In Ex.StackTrace.Split(vbCrLf)
  1271. If ShowAllTrace OrElse St.ToLower.Contains("pcl") Then Stack.Add(St.Replace(vbCr, String.Empty).Replace(vbLf, String.Empty))
  1272. Next
  1273. End If
  1274. Ex = Ex.InnerException
  1275. Loop
  1276. '构造输出信息
  1277. Dim TypeName As String = RealEx.GetType.FullName
  1278. GetString = Join(Desc, vbCrLf & "Caused By: ") & If(Stack.Count > 0, vbCrLf & Join(Stack, vbCrLf), "") & If(TypeName = "System.Exception", "", vbCrLf & "错误类型:" & TypeName)
  1279. End If
  1280. End Function
  1281. ''' <summary>
  1282. ''' 返回一个枚举对应的字符串。
  1283. ''' </summary>
  1284. ''' <param name="EnumData">一个已经实例化的枚举类型。</param>
  1285. Public Function GetStringFromEnum(EnumData As [Enum]) As String
  1286. Return [Enum].GetName(EnumData.GetType, EnumData)
  1287. End Function
  1288. ''' <summary>
  1289. ''' 将文件大小转化为适合的文本形式,如“1.28 M”。
  1290. ''' </summary>
  1291. ''' <param name="FileSize">以字节为单位的大小表示。</param>
  1292. Public Function GetString(FileSize As Long) As String
  1293. If FileSize < 1000 Then
  1294. 'B 级
  1295. Return FileSize & " B"
  1296. ElseIf FileSize < 1024 * 1000 Then
  1297. 'K 级
  1298. Dim RoundResult As String = Math.Round(FileSize / 1024)
  1299. Return Math.Round(FileSize / 1024, CInt(MathRange(3 - RoundResult.Length, 0, 2))) & " K"
  1300. ElseIf FileSize < 1024 * 1024 * 1000 Then
  1301. 'M 级
  1302. Dim RoundResult As String = Math.Round(FileSize / 1024 / 1024)
  1303. Return Math.Round(FileSize / 1024 / 1024, CInt(MathRange(3 - RoundResult.Length, 0, 2))) & " M"
  1304. Else
  1305. 'G 级
  1306. Dim RoundResult As String = Math.Round(FileSize / 1024 / 1024 / 1024)
  1307. Return Math.Round(FileSize / 1024 / 1024 / 1024, CInt(MathRange(3 - RoundResult.Length, 0, 2))) & " G"
  1308. End If
  1309. End Function
  1310. ''' <summary>
  1311. ''' 获取 Json 对象。
  1312. ''' </summary>
  1313. Public Function GetJson(Data As String)
  1314. Try
  1315. Return JsonConvert.DeserializeObject(Data, New JsonSerializerSettings With {.DateTimeZoneHandling = DateTimeZoneHandling.Local})
  1316. Catch ex As Exception
  1317. Throw New Exception("格式化 Json 对象失败:" & If(If(Data, "").Length > 10000, Data.Substring(0, 100) & "...", Data))
  1318. End Try
  1319. End Function
  1320. ''' <summary>
  1321. ''' 将字符串统一至某个长度,过短则以 Code 将其右侧填充,过长则截取靠左的指定长度。
  1322. ''' </summary>
  1323. Public Function StrFill(Str As String, Code As String, Length As Byte) As String
  1324. If Str.Length > Length Then Return Mid(Str, 1, Length)
  1325. Return Mid(Str.PadRight(Length, Code), Str.Length + 1) & Str
  1326. End Function
  1327. ''' <summary>
  1328. ''' 将一个小数显示为固定的小数点后位数形式,将向零取整。
  1329. ''' 如 12 保留 2 位则输出 12.00,而 95.678 保留 2 位则输出 95.67。
  1330. ''' </summary>
  1331. Public Function StrFillNum(Num As Double, Length As Integer) As String
  1332. Num = Math.Round(Num, Length, MidpointRounding.AwayFromZero)
  1333. StrFillNum = Num
  1334. If Not StrFillNum.Contains(".") Then Return (StrFillNum & ".").PadRight(StrFillNum.Length + 1 + Length, "0")
  1335. Return StrFillNum.PadRight(StrFillNum.Split(".")(0).Length + 1 + Length, "0")
  1336. End Function
  1337. ''' <summary>
  1338. ''' 移除字符串首尾的标点符号、回车,以及括号中、冒号后的补充说明内容。
  1339. ''' </summary>
  1340. Public Function StrTrim(Str As String, Optional RemoveQuote As Boolean = True)
  1341. If RemoveQuote Then Str = Str.Split("(")(0).Split(":")(0).Split("(")(0).Split(":")(0)
  1342. Return Str.Trim(".", "。", "!", " ", "!", "?", "?", vbCr, vbLf)
  1343. End Function
  1344. ''' <summary>
  1345. ''' 连接字符串。
  1346. ''' </summary>
  1347. Public Function Join(List As ICollection, Split As String) As String
  1348. Dim Builder As New StringBuilder
  1349. Dim LastCount As Integer = List.Count - 1
  1350. For i = 0 To LastCount
  1351. If List(i) IsNot Nothing Then Builder.Append(List(i))
  1352. If i <> LastCount Then Builder.Append(Split)
  1353. Next
  1354. Return Builder.ToString
  1355. End Function
  1356. ''' <summary>
  1357. ''' 获取字符串哈希值。
  1358. ''' </summary>
  1359. Public Function GetHash(Str As String) As ULong
  1360. GetHash = 5381
  1361. For i = 0 To Str.Length - 1
  1362. GetHash = (GetHash << 5) Xor GetHash Xor CType(AscW(Str(i)), ULong)
  1363. Next
  1364. Return GetHash Xor &HA98F501BC684032FUL
  1365. End Function
  1366. ''' <summary>
  1367. ''' 获取字符串 MD5。
  1368. ''' </summary>
  1369. Public Function GetStringMD5(Str As String) As String
  1370. Dim md5Hasher As New MD5CryptoServiceProvider
  1371. Dim hashedDataBytes As Byte()
  1372. hashedDataBytes = md5Hasher.ComputeHash(Encoding.GetEncoding("gb2312").GetBytes(Str))
  1373. Dim tmp As New StringBuilder()
  1374. For Each i As Byte In hashedDataBytes
  1375. tmp.Append(i.ToString("x2"))
  1376. Next
  1377. Return tmp.ToString()
  1378. End Function
  1379. ''' <summary>
  1380. ''' 输入 And 字符不会报错的 Val。
  1381. ''' </summary>
  1382. Public Function Val(Str As Object) As Double
  1383. Return If(TypeOf Str Is String AndAlso Str = "&", 0, Conversion.Val(Str))
  1384. End Function
  1385. '转义
  1386. ''' <summary>
  1387. ''' 为字符串进行 XML 转义。
  1388. ''' </summary>
  1389. Public Function EscapeXML(Str As String) As String
  1390. Return Str.Replace("&", "&amp;").Replace("<", "&lt;").Replace(">", "&gt;").Replace("'", "&apos;").Replace("""", "&quot;")
  1391. End Function
  1392. '正则
  1393. ''' <summary>
  1394. ''' 搜索字符串中的所有正则匹配项。
  1395. ''' </summary>
  1396. Public Function RegexSearch(str As String, regex As String, Optional options As RegularExpressions.RegexOptions = RegularExpressions.RegexOptions.None) As List(Of String)
  1397. Try
  1398. RegexSearch = New List(Of String)
  1399. Dim RegexSearchRes = New RegularExpressions.Regex(regex, options).Matches(str)
  1400. If RegexSearchRes Is Nothing Then Return RegexSearch
  1401. For Each item As RegularExpressions.Match In RegexSearchRes
  1402. RegexSearch.Add(item.Value)
  1403. Next
  1404. Catch ex As Exception
  1405. Log(ex, "正则匹配全部项出错")
  1406. Return New List(Of String)
  1407. End Try
  1408. End Function
  1409. ''' <summary>
  1410. ''' 获取字符串中的第一个正则匹配项,若无匹配则返回 Nothing。
  1411. ''' </summary>
  1412. Public Function RegexSeek(str As String, regex As String, Optional options As RegularExpressions.RegexOptions = RegularExpressions.RegexOptions.None) As String
  1413. Try
  1414. Dim Result = RegularExpressions.Regex.Match(str, regex, options).Value
  1415. Return If(Result = "", Nothing, Result)
  1416. Catch ex As Exception
  1417. Log(ex, "正则匹配第一项出错")
  1418. Return Nothing
  1419. End Try
  1420. End Function
  1421. ''' <summary>
  1422. ''' 检查字符串是否匹配某正则模式。
  1423. ''' </summary>
  1424. Public Function RegexCheck(str As String, regex As String, Optional options As RegularExpressions.RegexOptions = RegularExpressions.RegexOptions.None) As Boolean
  1425. Try
  1426. Return RegularExpressions.Regex.IsMatch(str, regex, options)
  1427. Catch ex As Exception
  1428. Log(ex, "正则检查出错")
  1429. Return False
  1430. End Try
  1431. End Function
  1432. ''' <summary>
  1433. ''' 进行正则替换,会抛出错误。
  1434. ''' </summary>
  1435. Public Function RegexReplace(Input As String, Replacement As String, Regex As String, Optional options As RegularExpressions.RegexOptions = RegularExpressions.RegexOptions.None) As String
  1436. Return RegularExpressions.Regex.Replace(Input, Regex, Replacement, options)
  1437. End Function
  1438. #End Region
  1439. #Region "搜索"
  1440. ''' <summary>
  1441. ''' 获取搜索文本的相似度。
  1442. ''' </summary>
  1443. ''' <param name="Source">被搜索的长内容。</param>
  1444. ''' <param name="Query">用户输入的搜索文本。</param>
  1445. Private Function SearchSimilarity(Source As String, Query As String) As Double
  1446. Dim qp As Integer = 0, lenSum As Double = 0
  1447. Source = Source.ToLower.Replace(" ", "")
  1448. Query = Query.ToLower.Replace(" ", "")
  1449. Dim sourceLength As Integer = Source.Length, queryLength As Integer = Query.Length '用于计算最后因数的长度缓存
  1450. Do While qp < Query.Length
  1451. '对 qp 作为开始位置计算
  1452. Dim sp As Integer = 0, lenMax As Integer = 0, spMax As Integer = 0
  1453. '查找以 qp 为头的最大子串
  1454. Do While sp < Source.Length
  1455. '对每个 sp 作为开始位置计算最大子串
  1456. Dim len As Integer = 0
  1457. Do While (qp + len) < Query.Length AndAlso (sp + len) < Source.Length AndAlso Source(sp + len) = Query(qp + len)
  1458. len += 1
  1459. Loop
  1460. '存储 len
  1461. If len > lenMax Then
  1462. lenMax = len
  1463. spMax = sp
  1464. End If
  1465. '根据结果增加 sp
  1466. sp += Math.Max(1, len)
  1467. Loop
  1468. If lenMax > 0 Then
  1469. Source = Source.Substring(0, spMax) & If(Source.Count > spMax + lenMax, Source.Substring(spMax + lenMax), String.Empty) '将源中的对应字段替换空
  1470. '存储 lenSum
  1471. Dim IncWeight = (Math.Pow(1.4, 3 + lenMax) - 3.6) '根据长度加成
  1472. IncWeight *= (1 + 0.3 * Math.Max(0, 3 - Math.Abs(qp - spMax))) '根据位置加成
  1473. lenSum += IncWeight
  1474. End If
  1475. '根据结果增加 qp
  1476. qp += Math.Max(1, lenMax)
  1477. Loop
  1478. '计算结果:重复字段量 × 源长度影响比例
  1479. Return (lenSum / queryLength) * (3 / Math.Pow(sourceLength + 15, 0.5)) * If(queryLength <= 2, 3 - queryLength, 1)
  1480. End Function
  1481. ''' <summary>
  1482. ''' 获取多段文本加权后的相似度。
  1483. ''' </summary>
  1484. Private Function SearchSimilarityWeighted(Source As List(Of KeyValuePair(Of String, Double)), Query As String) As Double
  1485. Dim TotalWeight As Double = 0
  1486. Dim Sum As Double = 0
  1487. For Each Pair In Source
  1488. Sum += SearchSimilarity(Pair.Key, Query) * Pair.Value
  1489. TotalWeight += Pair.Value
  1490. Next
  1491. Return Sum / TotalWeight
  1492. End Function
  1493. ''' <summary>
  1494. ''' 用于搜索的项目。
  1495. ''' </summary>
  1496. Public Class SearchEntry(Of T)
  1497. ''' <summary>
  1498. ''' 该项目对应的源数据。
  1499. ''' </summary>
  1500. Public Item As T
  1501. ''' <summary>
  1502. ''' 该项目用于搜索的源。
  1503. ''' </summary>
  1504. Public SearchSource As List(Of KeyValuePair(Of String, Double))
  1505. ''' <summary>
  1506. ''' 相似度。
  1507. ''' </summary>
  1508. Public Similarity As Double
  1509. ''' <summary>
  1510. ''' 是否完全匹配。
  1511. ''' </summary>
  1512. Public AbsoluteRight As Boolean
  1513. End Class
  1514. ''' <summary>
  1515. ''' 进行多段文本加权搜索,获取相似度较高的数项结果。
  1516. ''' </summary>
  1517. ''' <param name="MaxBlurCount">返回的最大模糊结果数。</param>
  1518. ''' <param name="MinBlurSimilarity">返回结果要求的最低相似度。</param>
  1519. Public Function Search(Of T)(Entries As List(Of SearchEntry(Of T)), Query As String, Optional MaxBlurCount As Integer = 5, Optional MinBlurSimilarity As Double = 0.1) As List(Of SearchEntry(Of T))
  1520. '初始化
  1521. Dim ResultList As New List(Of SearchEntry(Of T))
  1522. If Entries.Count = 0 Then Return ResultList
  1523. '进行搜索,获取相似信息
  1524. For Each Entry In Entries
  1525. Entry.Similarity = SearchSimilarityWeighted(Entry.SearchSource, Query)
  1526. Entry.AbsoluteRight = False
  1527. For Each Pair In Entry.SearchSource
  1528. If Pair.Key.ToLower.Replace(" ", "").Contains(Query.ToLower.Replace(" ", "")) Then Entry.AbsoluteRight = True
  1529. Next
  1530. Next
  1531. '按照相似度进行排序
  1532. Entries = Sort(Entries, Function(Left As SearchEntry(Of T), Right As SearchEntry(Of T)) As Boolean
  1533. If Left.AbsoluteRight Xor Right.AbsoluteRight Then
  1534. Return Left.AbsoluteRight
  1535. Else
  1536. Return Left.Similarity > Right.Similarity
  1537. End If
  1538. End Function)
  1539. '返回结果
  1540. Dim BlurCount As Integer = 0
  1541. For Each Entry In Entries
  1542. If Entry.AbsoluteRight Then
  1543. ResultList.Add(Entry) '完全匹配,直接加入
  1544. Else
  1545. If Entry.Similarity < MinBlurSimilarity OrElse BlurCount = MaxBlurCount Then Exit For '模糊结果边界条件
  1546. ResultList.Add(Entry)
  1547. BlurCount += 1 '模糊结果计数
  1548. End If
  1549. Next
  1550. Return ResultList
  1551. End Function
  1552. #End Region
  1553. #Region "系统"
  1554. ''' <summary>
  1555. ''' 当前程序是否拥有管理员权限。
  1556. ''' </summary>
  1557. Public Function IsAdmin() As Boolean
  1558. Dim id As WindowsIdentity = WindowsIdentity.GetCurrent()
  1559. Dim principal As New WindowsPrincipal(id)
  1560. Return principal.IsInRole(WindowsBuiltInRole.Administrator)
  1561. End Function
  1562. ''' <summary>
  1563. ''' 以管理员权限重新运行当前程序。返回是否成功。
  1564. ''' </summary>
  1565. Public Function RerunAsAdmin(Argument As String) As Boolean
  1566. Try
  1567. Process.Start(New ProcessStartInfo(PathWithName) With {.Verb = "runas", .Arguments = Argument})
  1568. Return True
  1569. Catch ex As Exception
  1570. Log(ex, "以管理员权限运行程序失败")
  1571. Return False
  1572. End Try
  1573. End Function
  1574. Private Uuid As Integer = 1
  1575. Private UuidLock As Object
  1576. ''' <summary>
  1577. ''' 获取一个全程序内不会重复的数字(伪 Uuid)。
  1578. ''' </summary>
  1579. Public Function GetUuid() As Integer
  1580. If UuidLock Is Nothing Then UuidLock = New Object
  1581. SyncLock UuidLock
  1582. Uuid += 1
  1583. Return Uuid
  1584. End SyncLock
  1585. End Function
  1586. ''' <summary>
  1587. ''' 将元素与 List 的混合体拆分为元素组。
  1588. ''' </summary>
  1589. Public Function GetFullList(Of T)(data As IList) As List(Of T)
  1590. GetFullList = New List(Of T)
  1591. For i = 0 To data.Count - 1
  1592. If TypeOf data(i) Is ICollection Then
  1593. GetFullList.AddRange(data(i))
  1594. Else
  1595. GetFullList.Add(data(i))
  1596. End If
  1597. Next i
  1598. End Function
  1599. ''' <summary>
  1600. ''' 数组去重。
  1601. ''' </summary>
  1602. Public Function ArrayNoDouble(Of T)(Arr As T(), Optional IsEqual As CompareThreadStart = Nothing) As T()
  1603. Dim ResultArray As New List(Of T)
  1604. For i = 0 To UBound(Arr)
  1605. For ii = i + 1 To UBound(Arr)
  1606. If IsEqual Is Nothing Then
  1607. If Arr(i).Equals(Arr(ii)) Then GoTo NextElement
  1608. Else
  1609. If IsEqual(Arr(i), Arr(ii)) Then GoTo NextElement
  1610. End If
  1611. Next
  1612. ResultArray.Add(Arr(i))
  1613. NextElement:
  1614. Next i
  1615. Return ResultArray.ToArray
  1616. End Function
  1617. ''' <summary>
  1618. ''' 数组去重。
  1619. ''' </summary>
  1620. Public Function ArrayNoDouble(Of T)(Arr As List(Of T), Optional IsEqual As CompareThreadStart = Nothing) As List(Of T)
  1621. Dim ResultArray As New List(Of T)
  1622. For i = 0 To Arr.Count - 1
  1623. For ii = i + 1 To Arr.Count - 1
  1624. If IsEqual Is Nothing Then
  1625. If Arr(i).Equals(Arr(ii)) Then GoTo NextElement
  1626. Else
  1627. If IsEqual(Arr(i), Arr(ii)) Then GoTo NextElement
  1628. End If
  1629. Next
  1630. ResultArray.Add(Arr(i))
  1631. NextElement:
  1632. Next i
  1633. Return ResultArray
  1634. End Function
  1635. ''' <summary>
  1636. ''' 若 Key 不存在于辞典,则加入辞典。
  1637. ''' 若 Key 已存在于辞典,则更新 Value。
  1638. ''' </summary>
  1639. Public Sub DictionaryAdd(Of TKey, TValue)(ByRef Dict As Dictionary(Of TKey, TValue), Key As TKey, Value As TValue)
  1640. If Dict.ContainsKey(Key) Then
  1641. Dict(Key) = Value
  1642. Else
  1643. Dict.Add(Key, Value)
  1644. End If
  1645. End Sub
  1646. ''' <summary>
  1647. ''' 获取格式类似于“11:08:52.037”的当前时间的字符串。
  1648. ''' </summary>
  1649. Public Function GetTimeNow() As String
  1650. Return Date.Now.ToString("HH:mm:ss.fff")
  1651. End Function
  1652. ''' <summary>
  1653. ''' 获取系统运行时间(毫秒),保证为正 Long 且大于 1,但可能突变减小。
  1654. ''' </summary>
  1655. Public Function GetTimeTick() As Long
  1656. Return My.Computer.Clock.TickCount + 2147483651L
  1657. End Function
  1658. ''' <summary>
  1659. ''' 将时间间隔转换为类似“5 分 10 秒前”的易于阅读的形式。
  1660. ''' </summary>
  1661. Public Function GetTimeSpanString(Span As TimeSpan) As String
  1662. Dim EndFix = If(Span.TotalMilliseconds > 0, "后", "前")
  1663. If Span.TotalMilliseconds < 0 Then Span = -Span
  1664. Dim TotalMonthes = Math.Floor(Span.Days / 30)
  1665. If TotalMonthes >= 61 Then
  1666. '5+ 年,“5 年”
  1667. GetTimeSpanString = Math.Floor(TotalMonthes / 12) & " 年"
  1668. ElseIf TotalMonthes >= 12 Then
  1669. '12~60 月,“1 年 2 个月”
  1670. GetTimeSpanString = Math.Floor(TotalMonthes / 12) & " 年" & If((TotalMonthes Mod 12) > 0, " " & (TotalMonthes Mod 12) & " 个月", "")
  1671. ElseIf TotalMonthes >= 4 Then
  1672. '4~11 月,“5 月”
  1673. GetTimeSpanString = TotalMonthes & " 月"
  1674. ElseIf TotalMonthes >= 1 Then
  1675. '1~4 月,“2 月 13 天”
  1676. GetTimeSpanString = TotalMonthes & " 月" & If((Span.Days Mod 30) > 0, " " & (Span.Days Mod 30) & " 天", "")
  1677. ElseIf Span.TotalDays >= 4 Then
  1678. '4~30 天,“23 天”
  1679. GetTimeSpanString = Span.Days & " 天"
  1680. ElseIf Span.TotalDays >= 1 Then
  1681. '1~3 天,“2 天 20 小时”
  1682. GetTimeSpanString = Span.Days & " 天" & If(Span.Hours > 0, " " & Span.Hours & " 小时", "")
  1683. ElseIf Span.TotalHours >= 10 Then
  1684. '10 小时 ~ 1 天,“15 小时”
  1685. GetTimeSpanString = Span.Hours & " 小时"
  1686. ElseIf Span.TotalHours >= 1 Then
  1687. '1~10 小时,“1 小时 20 分钟”
  1688. GetTimeSpanString = Span.Hours & " 小时" & If(Span.Minutes > 0, " " & Span.Minutes & " 分钟", "")
  1689. ElseIf Span.TotalMinutes >= 10 Then
  1690. '10 分钟 ~ 1 小时,“49 分钟”
  1691. GetTimeSpanString = Span.Minutes & " 分钟"
  1692. ElseIf Span.TotalMinutes >= 1 Then
  1693. '1~10 分钟,“9 分 23 秒”
  1694. GetTimeSpanString = Span.Minutes & " 分" & If(Span.Seconds > 0, " " & Span.Seconds & " 秒", "")
  1695. ElseIf Span.TotalSeconds >= 1 Then
  1696. '1 秒 ~ 1 分钟,“23 秒”
  1697. GetTimeSpanString = Span.Seconds & " 秒"
  1698. Else
  1699. '不到 1 秒
  1700. GetTimeSpanString = "1 秒"
  1701. End If
  1702. GetTimeSpanString += EndFix
  1703. End Function
  1704. ''' <summary>
  1705. ''' 获取十进制 Unix 时间戳。
  1706. ''' </summary>
  1707. Public Function GetUnixTimestamp() As Long
  1708. Return (Now.ToUniversalTime().Ticks - 621355968000000000) / 10000000
  1709. End Function
  1710. ''' <summary>
  1711. ''' 用于储存 RaiseByMouse 的 EventArgs。
  1712. ''' </summary>
  1713. Public NotInheritable Class RouteEventArgs
  1714. Inherits EventArgs
  1715. Public RaiseByMouse As Boolean
  1716. Public Handled As Boolean = False
  1717. Public Sub New(Optional RaiseByMouse As Boolean = False)
  1718. Me.RaiseByMouse = RaiseByMouse
  1719. End Sub
  1720. End Class
  1721. ''' <summary>
  1722. ''' 前台运行文件并返回返回值。
  1723. ''' </summary>
  1724. ''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
  1725. ''' <param name="Arguments">运行参数。</param>
  1726. ''' <param name="WaitForExit">是否等待该程序结束。默认为 False。</param>
  1727. ''' <param name="Timeout">等待该程序结束的最长时间(毫秒)。超时会返回 Result.Timeout。</param>
  1728. Public Function ShellAndGetExitCode(FileName As String, Optional Arguments As String = "", Optional WaitForExit As Boolean = False, Optional Timeout As Integer = 1000000) As Result
  1729. Try
  1730. Using Program As New Process
  1731. Program.StartInfo.Arguments = Arguments
  1732. Program.StartInfo.FileName = FileName
  1733. Log("[System] 执行外部命令并等待返回码:" & FileName & " " & Arguments)
  1734. Program.Start()
  1735. If WaitForExit Then
  1736. If Program.WaitForExit(Timeout) Then
  1737. Return Program.ExitCode
  1738. Else
  1739. Return Result.Timeout
  1740. End If
  1741. Else
  1742. Return Result.Success
  1743. End If
  1744. End Using
  1745. Catch ex As Exception
  1746. Log(ex, "执行命令失败:" & FileName, LogLevel.Msgbox)
  1747. Return Result.Fail
  1748. End Try
  1749. End Function
  1750. ''' <summary>
  1751. ''' 静默运行文件并返回输出流字符串。执行失败会抛出异常。
  1752. ''' </summary>
  1753. ''' <param name="FileName">文件名。可以为“notepad”等缩写。</param>
  1754. ''' <param name="Arguments">运行参数。</param>
  1755. ''' <param name="Timeout">等待该程序结束的最长时间(毫秒)。超时会抛出错误。</param>
  1756. Public Function ShellAndGetOutput(FileName As String, Optional Arguments As String = "", Optional Timeout As Integer = 1000000, Optional WorkingDirectory As String = Nothing) As String
  1757. Dim Info = New ProcessStartInfo With {
  1758. .Arguments = Arguments,
  1759. .FileName = FileName,
  1760. .UseShellExecute = False,
  1761. .CreateNoWindow = True,
  1762. .RedirectStandardError = True,
  1763. .RedirectStandardOutput = True,
  1764. .WorkingDirectory = If(WorkingDirectory, Path.TrimEnd("\"c))
  1765. }
  1766. If WorkingDirectory IsNot Nothing Then
  1767. If Info.EnvironmentVariables.ContainsKey("appdata") Then
  1768. Info.EnvironmentVariables("appdata") = WorkingDirectory
  1769. Else
  1770. Info.EnvironmentVariables.Add("appdata", WorkingDirectory)
  1771. End If
  1772. End If
  1773. Log("[System] 执行外部命令并等待返回结果:" & FileName & " " & Arguments)
  1774. Using Program As New Process() With {.StartInfo = Info}
  1775. Program.Start()
  1776. Program.WaitForExit(Timeout)
  1777. Return Program.StandardOutput.ReadToEnd & Program.StandardError.ReadToEnd
  1778. ' Dim Result As New StringBuilder()
  1779. ' AddHandler process.OutputDataReceived, Function(sender As Object, e As DataReceivedEventArgs)
  1780. ' Try
  1781. ' If e.Data IsNot Nothing Then Result.AppendLine(e.Data)
  1782. ' Finally
  1783. ' End Try
  1784. ' Return Nothing
  1785. ' End Function
  1786. ' AddHandler process.ErrorDataReceived, Function(sender As Object, e As DataReceivedEventArgs)
  1787. ' Try
  1788. ' If e.Data IsNot Nothing Then Result.AppendLine(e.Data)
  1789. ' Finally
  1790. ' End Try
  1791. ' Return Nothing
  1792. ' End Function
  1793. ' process.Start()
  1794. ' process.BeginOutputReadLine()
  1795. ' process.BeginErrorReadLine()
  1796. ' If process.WaitForExit(Timeout) Then
  1797. ' process.Close()
  1798. ' Return Result.ToString
  1799. ' Else
  1800. ' process.Close()
  1801. ' Throw New TimeoutException("程序执行超时,已有返回值:" & Result.ToString)
  1802. ' End If
  1803. End Using
  1804. End Function
  1805. ''' <summary>
  1806. ''' 在新的工作线程中执行代码。
  1807. ''' </summary>
  1808. Public Function RunInNewThread(Action As Action, Name As String, Optional Priority As ThreadPriority = ThreadPriority.Normal) As Thread
  1809. Dim th As New Thread(Sub()
  1810. Try
  1811. Action()
  1812. Catch ex As ThreadInterruptedException
  1813. Log(Name & ":线程已中止")
  1814. Catch ex As Exception
  1815. Log(ex, Name & ":线程执行失败", LogLevel.Feedback)
  1816. End Try
  1817. End Sub) With {.Name = Name, .Priority = Priority}
  1818. th.Start()
  1819. Return th
  1820. End Function
  1821. ''' <summary>
  1822. ''' 确保在 UI 线程中执行代码。
  1823. ''' 如果当前并非 UI 线程,则会阻断当前线程,直至 UI 线程执行完毕。
  1824. ''' 为防止线程互锁,请仅在开始加载动画、从 UI 获取输入时使用!
  1825. ''' </summary>
  1826. Public Sub RunInUiWait(Action As Action)
  1827. If RunInUi() Then
  1828. Action()
  1829. Else
  1830. Application.Current.Dispatcher.Invoke(Action)
  1831. End If
  1832. End Sub
  1833. ''' <summary>
  1834. ''' 确保在 UI 线程中执行代码,代码按触发顺序执行。
  1835. ''' 如果当前并非 UI 线程,也不阻断当前线程的执行。
  1836. ''' </summary>
  1837. Public Sub RunInUi(Action As Action, Optional ForceWaitUntilLoaded As Boolean = False)
  1838. If ForceWaitUntilLoaded Then
  1839. Application.Current.Dispatcher.InvokeAsync(Action, Threading.DispatcherPriority.Loaded)
  1840. ElseIf RunInUi() Then
  1841. Action()
  1842. Else
  1843. Application.Current.Dispatcher.InvokeAsync(Action)
  1844. End If
  1845. End Sub
  1846. ''' <summary>
  1847. ''' 确保在工作线程中执行代码。
  1848. ''' </summary>
  1849. Public Sub RunInThread(Action As Action)
  1850. If RunInUi() Then
  1851. RunInNewThread(Action, "Runtime Invoke " & GetUuid() & "#")
  1852. Else
  1853. Action()
  1854. End If
  1855. End Sub
  1856. ''' <summary>
  1857. ''' 按照既定的函数进行选择排序。
  1858. ''' </summary>
  1859. ''' <param name="SortRule">传入两个对象,若第一个对象应该排在前面,则返回 True。</param>
  1860. Public Function Sort(Of T)(List As IList(Of T), SortRule As CompareThreadStart) As List(Of T)
  1861. Dim NewList As New List(Of T)
  1862. While List.Count > 0
  1863. Dim Highest = List(0)
  1864. For i = 1 To List.Count - 1
  1865. If SortRule(List(i), Highest) Then Highest = List(i)
  1866. Next
  1867. List.Remove(Highest)
  1868. NewList.Add(Highest)
  1869. End While
  1870. Return NewList
  1871. End Function
  1872. Public Delegate Function CompareThreadStart(Left, Right) As Boolean
  1873. ''' <summary>
  1874. ''' 获取程序启动参数。
  1875. ''' </summary>
  1876. ''' <param name="Name">参数名。</param>
  1877. ''' <param name="DefaultValue">默认值。</param>
  1878. Public Function GetProgramArgument(Name As String, Optional DefaultValue As Object = "")
  1879. Dim AllArguments() As String = Command.Split(" ")
  1880. For i = 0 To AllArguments.Length - 1
  1881. If AllArguments(i) = "-" & Name Then
  1882. If AllArguments.Length = i + 1 OrElse AllArguments(i + 1).StartsWith("-") Then Return True
  1883. Return AllArguments(i + 1)
  1884. End If
  1885. Next
  1886. Return DefaultValue
  1887. End Function
  1888. ''' <summary>
  1889. ''' 时间戳转化为日期。
  1890. ''' </summary>
  1891. Public Function GetDate(timeStamp As Integer) As Date
  1892. Dim dtStart As Date = TimeZone.CurrentTimeZone.ToLocalTime(New Date(1970, 1, 1, 0, 0, 0, DateTimeKind.Utc))
  1893. Dim lTime As Long = (CLng(timeStamp) * 10000000)
  1894. Return dtStart.Add(New TimeSpan(lTime))
  1895. End Function
  1896. ''' <summary>
  1897. ''' 将 UTC 时间转化为当前时区的时间。
  1898. ''' </summary>
  1899. Public Function GetLocalTime(UtcDate As Date) As Date
  1900. Return DateTime.SpecifyKind(UtcDate, DateTimeKind.Utc).ToLocalTime
  1901. End Function
  1902. ''' <summary>
  1903. ''' 打开网页。
  1904. ''' </summary>
  1905. Public Sub OpenWebsite(Url As String)
  1906. Try
  1907. Log("[System] 正在打开网页:" & Url)
  1908. Process.Start(Url)
  1909. Catch ex As Exception
  1910. Log(ex, "无法打开网页(" & Url & ")")
  1911. ClipboardSet(Url, False)
  1912. MyMsgBox("可能由于浏览器未正确配置,PCL2 无法为你打开网页。" & vbCrLf & "网址已经复制到剪贴板,若有需要可以手动粘贴访问。", "无法打开网页")
  1913. End Try
  1914. End Sub
  1915. ''' <summary>
  1916. ''' 打开 explorer。
  1917. ''' </summary>
  1918. Public Sub OpenExplorer(Argument As String)
  1919. Try
  1920. Process.Start("explorer.exe", Argument)
  1921. Catch ex As Exception
  1922. Log(ex, "打开资源管理器失败,请尝试关闭安全软件(如 360 安全卫士)", LogLevel.Msgbox)
  1923. End Try
  1924. End Sub
  1925. ''' <summary>
  1926. ''' 设置剪贴板。将在另一线程运行,且不会抛出异常。
  1927. ''' </summary>
  1928. Public Sub ClipboardSet(Text As String, Optional ShowSuccessHint As Boolean = True)
  1929. RunInThread(Sub()
  1930. Dim RetryCount As Integer = 0
  1931. Retry:
  1932. Try
  1933. RunInUi(Sub()
  1934. My.Computer.Clipboard.Clear()
  1935. My.Computer.Clipboard.SetText(Text)
  1936. End Sub)
  1937. Catch ex As Exception
  1938. RetryCount += 1
  1939. If RetryCount <= 5 Then
  1940. Thread.Sleep(20)
  1941. GoTo Retry
  1942. Else
  1943. Log(ex, "可能由于剪贴板被其他程序占用,文本复制失败", LogLevel.Hint)
  1944. End If
  1945. End Try
  1946. If ShowSuccessHint Then Hint("已成功复制!", HintType.Finish)
  1947. End Sub)
  1948. End Sub
  1949. ''' <summary>
  1950. ''' 以 Byte() 形式获取程序中的资源。
  1951. ''' </summary>
  1952. Public Function GetResources(ResourceName As String) As Byte()
  1953. Log("[System] 获取资源:" & ResourceName)
  1954. Dim Raw As Byte() = My.Resources.ResourceManager.GetObject(ResourceName)
  1955. Return Raw
  1956. End Function
  1957. #End Region
  1958. #Region "UI"
  1959. '边距改变
  1960. ''' <summary>
  1961. ''' 相对增减控件的左边距。
  1962. ''' </summary>
  1963. Public Sub DeltaLeft(control As FrameworkElement, newValue As Double)
  1964. '安全性检查
  1965. DebugAssert(Not Double.IsNaN(newValue))
  1966. DebugAssert(Not Double.IsInfinity(newValue))
  1967. If TypeOf control Is Window Then
  1968. '窗口改变
  1969. CType(control, Window).Left += newValue
  1970. Else
  1971. '根据 HorizontalAlignment 改变数值
  1972. Select Case control.HorizontalAlignment
  1973. Case HorizontalAlignment.Left, HorizontalAlignment.Stretch
  1974. control.Margin = New Thickness(control.Margin.Left + newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom)
  1975. Case HorizontalAlignment.Right
  1976. control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right - newValue, control.Margin.Bottom)
  1977. 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom)
  1978. Case Else
  1979. DebugAssert(False)
  1980. End Select
  1981. End If
  1982. End Sub
  1983. ''' <summary>
  1984. ''' 设置控件的左边距。(仅针对置左控件)
  1985. ''' </summary>
  1986. Public Sub SetLeft(control As FrameworkElement, newValue As Double)
  1987. DebugAssert(control.HorizontalAlignment = HorizontalAlignment.Left)
  1988. control.Margin = New Thickness(newValue, control.Margin.Top, control.Margin.Right, control.Margin.Bottom)
  1989. End Sub
  1990. ''' <summary>
  1991. ''' 相对增减控件的上边距。
  1992. ''' </summary>
  1993. Public Sub DeltaTop(control As FrameworkElement, newValue As Double)
  1994. '安全性检查
  1995. DebugAssert(Not Double.IsNaN(newValue))
  1996. DebugAssert(Not Double.IsInfinity(newValue))
  1997. If TypeOf control Is Window Then
  1998. '窗口改变
  1999. CType(control, Window).Top += newValue
  2000. Else
  2001. '根据 VerticalAlignment 改变数值
  2002. Select Case control.VerticalAlignment
  2003. Case VerticalAlignment.Top
  2004. control.Margin = New Thickness(control.Margin.Left, control.Margin.Top + newValue, control.Margin.Right, control.Margin.Bottom)
  2005. Case VerticalAlignment.Bottom
  2006. control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, control.Margin.Bottom - newValue)
  2007. 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, CType(control.Parent, Object).ActualWidth - control.ActualWidth - newValue, control.Margin.Bottom)
  2008. Case Else
  2009. DebugAssert(False)
  2010. End Select
  2011. End If
  2012. 'If Double.IsNaN(newValue) OrElse Double.IsInfinity(newValue) Then Exit Sub '安全性检查
  2013. 'Select Case control.VerticalAlignment
  2014. ' Case VerticalAlignment.Top, VerticalAlignment.Stretch, VerticalAlignment.Center
  2015. ' control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
  2016. ' Case VerticalAlignment.Bottom
  2017. ' control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, -newValue)
  2018. ' 'control.Margin = New Thickness(control.Margin.Left, control.Margin.Top, control.Margin.Right, CType(control.Parent, Object).ActualHeight - control.ActualHeight - newValue)
  2019. 'End Select
  2020. End Sub
  2021. ''' <summary>
  2022. ''' 设置控件的顶边距。(仅针对置上控件)
  2023. ''' </summary>
  2024. Public Sub SetTop(control As FrameworkElement, newValue As Double)
  2025. DebugAssert(control.VerticalAlignment = VerticalAlignment.Top)
  2026. control.Margin = New Thickness(control.Margin.Left, newValue, control.Margin.Right, control.Margin.Bottom)
  2027. End Sub
  2028. 'DPI 转换
  2029. Public ReadOnly DPI As Integer = System.Drawing.Graphics.FromHwnd(IntPtr.Zero).DpiX
  2030. ''' <summary>
  2031. ''' 将经过 DPI 缩放的 WPF 尺寸转化为实际的像素尺寸。
  2032. ''' </summary>
  2033. Public Function GetPixelSize(WPFSize As Double) As Double
  2034. Return WPFSize / 96 * DPI
  2035. End Function
  2036. ''' <summary>
  2037. ''' 将实际的像素尺寸转化为经过 DPI 缩放的 WPF 尺寸。
  2038. ''' </summary>
  2039. Public Function GetWPFSize(PixelSize As Double) As Double
  2040. Return PixelSize * 96 / DPI
  2041. End Function
  2042. 'UI 截图
  2043. ''' <summary>
  2044. ''' 将某个控件的呈现转换为图片。
  2045. ''' </summary>
  2046. Public Function ControlBrush(UI As FrameworkElement) As ImageBrush
  2047. Dim Width = UI.ActualWidth, Height = UI.ActualHeight
  2048. If Width < 1 OrElse Height < 1 Then Return New ImageBrush
  2049. Dim bmp As New RenderTargetBitmap(GetPixelSize(Width), GetPixelSize(Height), DPI, DPI, PixelFormats.Pbgra32)
  2050. bmp.Render(UI)
  2051. Return New ImageBrush(bmp)
  2052. End Function
  2053. ''' <summary>
  2054. ''' 将某个控件的模拟呈现转换为图片。
  2055. ''' </summary>
  2056. Public Function ControlBrush(UI As FrameworkElement, Width As Double, Height As Double, Optional Left As Double = 0, Optional Top As Double = 0) As ImageBrush
  2057. UI.Measure(New Size(Width, Height))
  2058. UI.Arrange(New Rect(0, 0, Width, Height))
  2059. Dim bmp As New RenderTargetBitmap(GetPixelSize(Width), GetPixelSize(Height), DPI, DPI, PixelFormats.Default)
  2060. bmp.Render(UI)
  2061. If Not (Left = 0 AndAlso Top = 0) Then UI.Arrange(New Rect(Left, Top, Width, Height))
  2062. Return New ImageBrush(bmp)
  2063. End Function
  2064. ''' <summary>
  2065. ''' 将 UI 内容固定为图片并进行 Clear。
  2066. ''' </summary>
  2067. Public Sub ControlFreeze(UI As Panel)
  2068. UI.Background = ControlBrush(UI)
  2069. UI.Children.Clear()
  2070. End Sub
  2071. ''' <summary>
  2072. ''' 将 UI 内容固定为图片并进行 Clear。
  2073. ''' </summary>
  2074. Public Sub ControlFreeze(UI As Border)
  2075. UI.Background = ControlBrush(UI)
  2076. UI.Child = Nothing
  2077. End Sub
  2078. ''' <summary>
  2079. ''' 将 XML 转换为对应 UI 对象。
  2080. ''' </summary>
  2081. Public Function GetObjectFromXML(Str As XElement)
  2082. Return GetObjectFromXML(Str.ToString)
  2083. End Function
  2084. ''' <summary>
  2085. ''' 将 XML 转换为对应 UI 对象。
  2086. ''' </summary>
  2087. Public Function GetObjectFromXML(Str As String)
  2088. Using Stream As New MemoryStream
  2089. Using Writer As New StreamWriter(Stream)
  2090. Writer.Write(Str)
  2091. Writer.Flush()
  2092. Stream.Position = 0
  2093. Return XamlReader.Load(Stream)
  2094. End Using
  2095. End Using
  2096. End Function
  2097. Private ReadOnly UiThreadId As Integer = Thread.CurrentThread.ManagedThreadId
  2098. ''' <summary>
  2099. ''' 当前线程是否为主线程。
  2100. ''' </summary>
  2101. Public Function RunInUi() As Boolean
  2102. Return Thread.CurrentThread.ManagedThreadId = UiThreadId
  2103. End Function
  2104. #End Region
  2105. #Region "Debug"
  2106. Public ModeDebug As Boolean = False
  2107. 'Log
  2108. Public Enum LogLevel
  2109. ''' <summary>
  2110. ''' 不提示,只记录日志。
  2111. ''' </summary>
  2112. Normal = 0
  2113. ''' <summary>
  2114. ''' 只提示开发者。
  2115. ''' </summary>
  2116. Developer = 1
  2117. ''' <summary>
  2118. ''' 只提示开发者与调试模式用户。
  2119. ''' </summary>
  2120. Debug = 2
  2121. ''' <summary>
  2122. ''' 弹出提示所有用户。
  2123. ''' </summary>
  2124. Hint = 3
  2125. ''' <summary>
  2126. ''' 弹窗,不要求反馈。
  2127. ''' </summary>
  2128. Msgbox = 4
  2129. ''' <summary>
  2130. ''' 弹窗,要求反馈。
  2131. ''' </summary>
  2132. Feedback = 5
  2133. ''' <summary>
  2134. ''' 弹窗,结束程序。
  2135. ''' </summary>
  2136. Assert = 6
  2137. End Enum
  2138. ''' <summary>
  2139. ''' 记录程序是否递交了错误提示,以确保运行测试正确。
  2140. ''' </summary>
  2141. Public IsErrorTriggered As Boolean = False
  2142. Private LogList As New StringBuilder
  2143. Private LogWritter As StreamWriter
  2144. Public Sub LogStart()
  2145. RunInNewThread(Sub()
  2146. Dim IsInitSuccess As Boolean = True
  2147. Try
  2148. For i = 4 To 1
  2149. If File.Exists(Path & "PCL\Log" & i & ".txt") Then
  2150. If File.Exists(Path & "PCL\Log" & (i + 1) & ".txt") Then File.Delete(Path & "PCL\Log" & (i + 1) & ".txt")
  2151. File.Copy(Path & "PCL\Log" & i & ".txt", Path & "PCL\Log" & (i + 1) & ".txt")
  2152. End If
  2153. Next
  2154. File.Create(Path & "PCL\Log1.txt").Dispose()
  2155. Catch ex As IOException
  2156. IsInitSuccess = False
  2157. Hint("可能同时开启了多个 PCL2,程序可能会出现未知问题!", HintType.Critical)
  2158. Log(ex, "日志初始化失败(疑似文件占用问题)")
  2159. Catch ex As Exception
  2160. IsInitSuccess = False
  2161. Log(ex, "日志初始化失败", LogLevel.Hint)
  2162. End Try
  2163. Try
  2164. LogWritter = New StreamWriter(Path & "PCL\Log1.txt", True) With {.AutoFlush = True}
  2165. Catch ex As Exception
  2166. LogWritter = Nothing
  2167. Log(ex, "日志写入失败", LogLevel.Hint)
  2168. End Try
  2169. While True
  2170. If IsInitSuccess Then
  2171. LogFlush()
  2172. Else
  2173. LogList = New StringBuilder '清空 LogList 避免内存爆炸
  2174. End If
  2175. Thread.Sleep(50)
  2176. End While
  2177. End Sub, "Log Writer", ThreadPriority.Lowest)
  2178. End Sub
  2179. Private ReadOnly LogFlushLock As New Object '防止外部调用 LogFlush 时同时输出多次日志
  2180. Public Sub LogFlush()
  2181. On Error Resume Next
  2182. If LogWritter Is Nothing Then Exit Sub
  2183. Dim Log As String = Nothing
  2184. SyncLock LogFlushLock
  2185. If LogList.Length > 0 Then
  2186. Dim LogListCache As StringBuilder
  2187. LogListCache = LogList
  2188. LogList = New StringBuilder
  2189. Log = LogListCache.ToString
  2190. End If
  2191. End SyncLock
  2192. If Log IsNot Nothing Then
  2193. LogWritter.Write(Log)
  2194. End If
  2195. End Sub
  2196. Private ReadOnly LogListLock As New Object '防止日志乱码,只在调试模式下启用
  2197. ''' <summary>
  2198. ''' 输出 Log。
  2199. ''' </summary>
  2200. ''' <param name="Title">如果要求弹窗,指定弹窗的标题。</param>
  2201. Public Sub Log(Text As String, Optional Level As LogLevel = LogLevel.Normal, Optional Title As String = "出现错误")
  2202. On Error Resume Next
  2203. '放在最后会导致无法显示极端错误下的弹窗(如无法写入日志文件)
  2204. '处理错误会导致再次调用 Log() 导致无限循环
  2205. '输出日志
  2206. Dim AppendText As String = "[" & GetTimeNow() & "] " & Text & vbCrLf '减轻同步锁占用
  2207. If ModeDebug Then
  2208. SyncLock LogListLock
  2209. LogList.Append(AppendText)
  2210. End SyncLock
  2211. Else
  2212. LogList.Append(AppendText)
  2213. End If
  2214. #If DEBUG Then
  2215. Console.Write(AppendText)
  2216. #End If
  2217. If IsProgramEnded OrElse Level = LogLevel.Normal Then Exit Sub
  2218. '去除前缀
  2219. Text = RegexReplace(Text, "", "\[[^\]]+?\] ")
  2220. '输出提示
  2221. Select Case Level
  2222. #If DEBUG Then
  2223. Case LogLevel.Developer
  2224. Hint("[开发者模式] " & Text, HintType.Info, False)
  2225. Case LogLevel.Debug
  2226. Hint("[调试模式] " & Text, HintType.Info, False)
  2227. #Else
  2228. Case LogLevel.Developer
  2229. Case LogLevel.Debug
  2230. If ModeDebug Then Hint("[调试模式] " & Text, HintType.Info, False)
  2231. #End If
  2232. Case LogLevel.Hint
  2233. IsErrorTriggered = True
  2234. Hint(Text, HintType.Critical, False)
  2235. Case LogLevel.Msgbox
  2236. IsErrorTriggered = True
  2237. MyMsgBox(Text, Title)
  2238. Case LogLevel.Feedback
  2239. IsErrorTriggered = True
  2240. If MyMsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", Title, "反馈", "取消") = 1 Then Feedback("exlog", False, True)
  2241. Case LogLevel.Assert
  2242. IsErrorTriggered = True
  2243. Dim Time As Long = GetTimeTick()
  2244. If MsgBox(Text & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback("exlog", False, True)
  2245. If GetTimeTick() - Time < 1500 Then
  2246. '弹窗无法保留
  2247. Log("[System] PCL 已崩溃:" & vbCrLf & Text)
  2248. FormMain.EndProgramForce(Result.Exception)
  2249. Else
  2250. FormMain.EndProgramForce(Result.Fail)
  2251. End If
  2252. End Select
  2253. End Sub
  2254. ''' <summary>
  2255. ''' 输出错误信息。
  2256. ''' </summary>
  2257. ''' <param name="Desc">错误描述。会在处理时在末尾加入冒号。</param>
  2258. Public Sub Log(Ex As Exception, Desc As String, Optional Level As LogLevel = LogLevel.Debug, Optional Title As String = "出现错误")
  2259. On Error Resume Next
  2260. If TypeOf Ex Is ThreadInterruptedException Then Exit Sub
  2261. IsErrorTriggered = True
  2262. '获取错误信息
  2263. Dim ExFull As String = Desc & ":" & GetString(Ex, False)
  2264. '输出日志
  2265. Dim AppendText As String = "[" & GetTimeNow() & "] " & Desc & ":" & GetString(Ex, False, True) & vbCrLf '减轻同步锁占用
  2266. If ModeDebug Then
  2267. SyncLock LogListLock
  2268. LogList.Append(AppendText)
  2269. End SyncLock
  2270. Else
  2271. LogList.Append(AppendText)
  2272. End If
  2273. #If DEBUG Then
  2274. Console.Write(AppendText)
  2275. #End If
  2276. If IsProgramEnded Then Exit Sub
  2277. '输出提示
  2278. Select Case Level
  2279. Case LogLevel.Normal
  2280. #If DEBUG Then
  2281. Case LogLevel.Developer
  2282. Dim ExLine As String = Desc & ":" & GetString(Ex, True)
  2283. Hint("[开发者模式] " & ExLine, HintType.Info, False)
  2284. Case LogLevel.Debug
  2285. Dim ExLine As String = Desc & ":" & GetString(Ex, True)
  2286. Hint("[调试模式] " & ExLine, HintType.Info, False)
  2287. #Else
  2288. Case LogLevel.Developer
  2289. Case LogLevel.Debug
  2290. Dim ExLine As String = Desc & ":" & GetString(Ex, True)
  2291. If ModeDebug Then Hint("[调试模式] " & ExLine, HintType.Info, False)
  2292. #End If
  2293. Case LogLevel.Hint
  2294. Dim ExLine As String = Desc & ":" & GetString(Ex, True)
  2295. Hint(ExLine, HintType.Critical, False)
  2296. Case LogLevel.Msgbox
  2297. MyMsgBox(ExFull, Title)
  2298. Case LogLevel.Feedback
  2299. If MyMsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", Title, "反馈", "取消") = 1 Then Feedback("exlog", False, True)
  2300. Case LogLevel.Assert
  2301. Dim Time As Long = GetTimeTick()
  2302. If MsgBox(ExFull & vbCrLf & vbCrLf & "是否反馈此问题?如果不反馈,这个问题可能永远无法得到解决!", MsgBoxStyle.Critical + MsgBoxStyle.YesNo, Title) = MsgBoxResult.Yes Then Feedback("exlog", False, True)
  2303. If GetTimeTick() - Time < 1500 Then
  2304. '弹窗无法保留
  2305. Log("[System] PCL 已崩溃:" & vbCrLf & ExFull)
  2306. FormMain.EndProgramForce(Result.Exception)
  2307. Else
  2308. FormMain.EndProgramForce(Result.Fail)
  2309. End If
  2310. End Select
  2311. End Sub
  2312. '反馈
  2313. Public Sub Feedback(Source As String, Optional ShowMsgbox As Boolean = True, Optional ForceOpenLog As Boolean = False)
  2314. On Error Resume Next
  2315. FeedbackInfo()
  2316. If ForceOpenLog OrElse (ShowMsgbox AndAlso MyMsgBox("若你在汇报一个 Bug,请点击 打开文件夹 按钮,并上传 Log(1~5).txt 中包含错误信息的文件。" & vbCrLf & "游戏崩溃一般与启动器无关,请不要因为游戏崩溃而提交反馈。", "反馈提交提醒", "打开文件夹", "不需要") = 1) Then
  2317. OpenExplorer("""" & Path & "PCL\""")
  2318. End If
  2319. OpenWebsite("https://jinshuju.net/f/rP4b6E?x_field_1=" & Source)
  2320. If Setup.Get("HintFeedback") = "" Then Setup.Set("HintFeedback", "/") '确保反馈报告会被加载
  2321. End Sub
  2322. ''' <summary>
  2323. ''' 在日志中输出系统诊断信息。
  2324. ''' </summary>
  2325. Public Sub FeedbackInfo()
  2326. On Error Resume Next
  2327. Log("[System] 诊断信息:" & vbCrLf &
  2328. "操作系统:" & My.Computer.Info.OSFullName & vbCrLf &
  2329. "剩余内存:" & Int(My.Computer.Info.AvailablePhysicalMemory / 1024 / 1024) & " M / " & Int(My.Computer.Info.TotalPhysicalMemory / 1024 / 1024) & " M" & vbCrLf &
  2330. "DPI:" & DPI & "(" & Math.Round(DPI / 96, 2) * 100 & "%)" & vbCrLf &
  2331. "文件位置:" & Path)
  2332. End Sub
  2333. '断言
  2334. Public Sub DebugAssert(Exp As Boolean)
  2335. If Not Exp Then Throw New Exception("断言命中")
  2336. End Sub
  2337. #End Region
  2338. #Region "随机"
  2339. Private ReadOnly Random As New Random
  2340. ''' <summary>
  2341. ''' 随机选择其一。
  2342. ''' </summary>
  2343. Public Function RandomOne(Of T)(objects As ICollection(Of T)) As T
  2344. Return objects(RandomInteger(0, objects.Count - 1))
  2345. End Function
  2346. ''' <summary>
  2347. ''' 取随机整数。
  2348. ''' </summary>
  2349. Public Function RandomInteger(min As Integer, max As Integer) As Integer
  2350. Return Math.Floor((max - min + 1) * Random.NextDouble) + min
  2351. End Function
  2352. ''' <summary>
  2353. ''' 将数组随机打乱。
  2354. ''' </summary>
  2355. Public Function RandomChaos(Of T)(array As IList(Of T)) As IList(Of T)
  2356. RandomChaos = New List(Of T)
  2357. Do While array.Count > 0
  2358. Dim i As Integer = RandomInteger(0, array.Count - 1)
  2359. RandomChaos.Add(array(i))
  2360. array.RemoveAt(i)
  2361. Loop
  2362. End Function
  2363. #End Region
  2364. End Module