添加建议中心

Builder/MainWindow.frm

@@ -52,8 +52,9 @@ Private Sub Form_Load()
     '创建字体
     Set EF = New GFont
     If PackPos = -1 Then
-        EF.AddFont App.Path & "\Builder.UI.otf"
+        EF.AddFont App.path & "\Builder.UI.otf"
         EF.MakeFont "Abadi MT Extra Light"
+        'EF.MakeFont "微软雅黑"
     Else
         EF.MakeFont "微软雅黑"
     End If
@@ -69,7 +70,7 @@ Private Sub Form_Load()
 
     '创建音乐列表
     Set MusicList = New GMusicList
-    MusicList.Create App.Path & "\music"
+    MusicList.Create App.path & "\music"
 
     '在此处初始化你的页面
     If PackPos = -1 Then
@@ -115,7 +116,7 @@ Private Sub Form_Unload(Cancel As Integer)
         Print #1, "echo 卸载程序正在清除残留文件 , Emerald Builder 版本号: " & Version
         Print #1, "echo 正在清理残留文件 ..."
         Print #1, "ping localhost -n 5 > nul"
-        Print #1, "rd /s /q """ & App.Path & """"
+        Print #1, "rd /s /q """ & App.path & """"
         Close #1
         ShellExecuteA 0, "open", VBA.Environ("temp") & "\copyemr.cmd", "", "", SW_SHOW
     End If

Core/AboutMe.bas

@@ -40,6 +40,9 @@ Attribute VB_Name = "AboutMe"
 '========================================================
 '   更新日志
 '========================================================
+'   更新内容(ver.1001)
+'   -完善XP兼容性
+'   -添加建议中心
 '   更新内容(ver.930)
 '   -兼容XP
 '   更新内容(ver.730)

Core/GCore.bas

@@ -52,7 +52,7 @@ Attribute VB_Name = "GCore"
         transDarkReturn = 13
     End Enum
     Public Type GGIF
-        time As Long
+        Time As Long
         frames() As Long
         tick As Long
         Count As Long
@@ -96,6 +96,18 @@ Attribute VB_Name = "GCore"
     Public Type ColorCollection
         IsAlpha() As Boolean
     End Type
+    Public Enum SuggestClearTime
+        NeverClear = 0
+        ClearOnUpdate = 1
+        ClearOnOnce = 2
+    End Enum
+    Public Type Suggestion
+        Content As String
+        Deepth As Long
+        Time As Long
+        ClearTime As SuggestClearTime
+    End Type
+    Public SGS() As Suggestion, SGTime As Long
     Public ColorLists() As ColorCollection
     Public ECore As GMan, EF As GFont, EAni As Object, ESave As GSaving, EMusic As GMusicList
     Public GHwnd As Long, GDC As Long, GW As Long, GH As Long
@@ -106,7 +118,7 @@ Attribute VB_Name = "GCore"
     Public FPSWarn As Long
     Public EmeraldInstalled As Boolean
     Public BassInstalled As Boolean
-    Public Const Version As Long = 19093001      'hhfhhhdfgdfhhhxxxhhhhhhhhffff
+    Public Const Version As Long = 19100102      'hhfhyhasdgdfhhhxxxhhhhhhhhffff
     Public TextHandle As Long, WaitChr As String
     Public XPMode As Boolean
 
@@ -170,6 +182,7 @@ Attribute VB_Name = "GCore"
     End Sub
     Public Sub StartEmerald(Hwnd As Long, w As Long, h As Long)
         ReDim ColorLists(0)
+        ReDim SGS(0)
 
         Call InitPool
 
@@ -224,11 +237,18 @@ Attribute VB_Name = "GCore"
 
         If App.LogMode = 0 Then Call CheckUpdate
 
-        If ReLoadCount > LoadedCount Then Suggest "重复加载的资源数量太多啦！不考虑每个页面的资源单独一个文件夹放置吗？"
+        If ReLoadCount > LoadedCount Then Suggest "重复加载的资源数量过多。", NeverClear, 1
 
     End Sub
-    Public Sub Suggest(Text As String)
-        Debug.Print Now, "Emeraldの建议：" & Text
+    Public Sub Suggest(Text As String, Clears As SuggestClearTime, Deepth As Long)
+        ReDim Preserve SGS(UBound(SGS) + 1)
+        With SGS(UBound(SGS))
+            .Content = Text
+            .ClearTime = Clears
+            .Time = GetTickCount
+            .Deepth = Deepth
+        End With
+        SGTime = GetTickCount
     End Sub
     Public Sub EndEmerald()
         If DebugMode Then
@@ -250,8 +270,8 @@ Attribute VB_Name = "GCore"
     End Sub
 '========================================================
 '   RunTime
-    Public Function ToTime(time) As String
-        ToTime = Int(time / 60) & ":" & format(time Mod 60, "00")
+    Public Function ToTime(Time) As String
+        ToTime = Int(Time / 60) & ":" & format(Time Mod 60, "00")
     End Function
     Public Function Process(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
         On Error GoTo sth
@@ -281,6 +301,8 @@ sth:
         GetWinNTVersion = Left(strOSversion, 3)
     End Function
     Public Sub BlurTo(DC As Long, srcDC As Long, buffWin As Form, Optional Radius As Long = 60)
+        If XPMode Then BitBlt DC, 0, 0, GW, GH, srcDC, 0, 0, vbSrcCopy: Exit Sub
+
         Dim I As Long, g As Long, e As Long, B As BlurParams, w As Long, h As Long
         '粘贴到缓冲窗口
         buffWin.AutoRedraw = True
@@ -301,10 +323,12 @@ sth:
         buffWin.AutoRedraw = False
     End Sub
     Public Sub BlurImg(img As Long, Radius As Long)
+        If XPMode Then Exit Sub
+
         Dim B As BlurParams, e As Long, w As Long, h As Long
 
         '模糊操作
-
+        
         PoolCreateEffect2 GdipEffectType.Blur, e: B.Radius = Radius: GdipSetEffectParameters e, B, LenB(B)
         GdipGetImageWidth img, w: GdipGetImageHeight img, h
         GdipBitmapApplyEffect img, e, NewRectL(0, 0, w, h), 0, 0, 0
@@ -400,7 +424,7 @@ sth:
     Public Sub CheckUpdate()
         On Error Resume Next
         If InternetGetConnectedState(0&, 0&) = 0 Then
-            Debug.Print Now, "Emerald：未连接网络，检查更新取消。"
+            Suggest "未连接网络，Emerald 检查更新取消。", NeverClear, 0
             Err.Clear
             Exit Sub
         End If
@@ -419,7 +443,7 @@ sth:
             Start = GetTickCount
             Do While xmlHttp.ReadyState <> 4
                 If GetTickCount - Start >= UpdateTimeOut Then
-                    Debug.Print Now, "Emerald：检查更新超时。"
+                    Suggest "Emerald 检查更新超时。", NeverClear, 0
                     Exit Sub
                 End If
                 Sleep 10: DoEvents

Core/GDebug.cls

@@ -262,14 +262,14 @@ Public Sub RunExec()
 
                     Dim bFile As String, Size1 As Long, Size2 As Long
 
-                    If Dir(App.Path & "\.emr\backup\" & Params(2), vbDirectory) = "" Then
+                    If Dir(App.path & "\.emr\backup\" & Params(2), vbDirectory) = "" Then
                         SetConsoleColor colors.ErrText
-                        WriteWord "backup-Error: the backup not found '" & App.Path & "\.emr\backup\" & Params(2) & "'"
+                        WriteWord "backup-Error: the backup not found '" & App.path & "\.emr\backup\" & Params(2) & "'"
                         Call ExitExec
                         Exit Sub
                     End If
                     Dim bStep As Long, bfo As String, bsfo As String, targetFile As String, targetGet As Boolean
-                    bFile = Dir(App.Path & "\.emr\backup\" & Params(2) & "\"): bfo = "core": bsfo = ""
+                    bFile = Dir(App.path & "\.emr\backup\" & Params(2) & "\"): bfo = "core": bsfo = ""
                     If UBound(Params) = 3 Then targetFile = Params(3): WriteLine "Finding"
 
 ReCopy:
@@ -282,9 +282,9 @@ ReCopy:
                             NextLine
                         End If
                         If (targetFile <> "" And targetFile = bFile) Or (targetFile = "") Then
-                            Size1 = FileLen(App.Path & "\.emr\backup\" & Params(2) & "\" & bsfo & "\" & bFile): Size2 = 0
-                            Size2 = FileLen(App.Path & "\" & bfo & "\" & bFile)
-                            FileCopy App.Path & "\.emr\backup\" & Params(2) & "\" & bsfo & "\" & bFile, App.Path & "\" & bfo & "\" & bFile
+                            Size1 = FileLen(App.path & "\.emr\backup\" & Params(2) & "\" & bsfo & "\" & bFile): Size2 = 0
+                            Size2 = FileLen(App.path & "\" & bfo & "\" & bFile)
+                            FileCopy App.path & "\.emr\backup\" & Params(2) & "\" & bsfo & "\" & bFile, App.path & "\" & bfo & "\" & bFile
                             SetConsoleColor colors.DefaultText
                             WriteWord "Success : " & bFile & "      "
                             SetConsoleColor IIf(Size1 = Size2, colors.DefaultText, IIf(Size1 > Size2, colors.SuccessText, colors.ErrText))
@@ -298,8 +298,8 @@ ReCopy:
                         Sleep 10: DoEvents
                     Loop
                     bStep = bStep + 1
-                    If bStep = 1 And (Not targetGet) Then bFile = Dir(App.Path & "\.emr\backup\" & Params(2) & "\cache\"): bfo = ".emr\cache": bsfo = "cache"
-                    If bStep = 2 And (Not targetGet) Then bFile = Dir(App.Path & "\.emr\backup\" & Params(2) & "\project\"): bfo = "": bsfo = "project"
+                    If bStep = 1 And (Not targetGet) Then bFile = Dir(App.path & "\.emr\backup\" & Params(2) & "\cache\"): bfo = ".emr\cache": bsfo = "cache"
+                    If bStep = 2 And (Not targetGet) Then bFile = Dir(App.path & "\.emr\backup\" & Params(2) & "\project\"): bfo = "": bsfo = "project"
                     If bStep <= 2 And (Not targetGet) Then GoTo ReCopy
 
                     If targetFile = "" Then
@@ -323,37 +323,37 @@ ReCopy:
                     WriteLine "The consequences are at one's own expense !!!"
                     WriteLine "All your backups will be erased from your drive forever ."
                     SetConsoleColor colors.DefaultText
-                    WriteLine "Target folder : " & App.Path & "\.emr\backup\"
+                    WriteLine "Target folder : " & App.path & "\.emr\backup\"
                     WriteLine "Erase them any way ? [Y/N]"
                     AllowInput
                     Params(1) = "-clear2"
                 Case "-clear2"
                 Case "-clear3"
                     Dim FSO3 As Object
                     Set FSO3 = PoolCreateObject("Scripting.FileSystemObject")
-                    FSO3.DeleteFolder App.Path & "\.emr\backup"
+                    FSO3.DeleteFolder App.path & "\.emr\backup"
                     SetConsoleColor colors.DefaultText
                     WriteLine "Erasing"
-                    Do While Dir(App.Path & "\.emr\backup", vbDirectory) <> ""
+                    Do While Dir(App.path & "\.emr\backup", vbDirectory) <> ""
                         Call BackLine: Call ClearLine
                         WriteWord "Erasing " & IIf(GetTickCount Mod 4000 < 1000, ".", "") & IIf(GetTickCount Mod 4000 < 2000, ".", "") & IIf(GetTickCount Mod 4000 < 3000, ".", "")
                         Debuginfo.UpdateTimer_Timer
                         Sleep 10: DoEvents
                     Loop
                     SetConsoleColor colors.SuccessText
-                    MkDir App.Path & "\.emr\backup"
+                    MkDir App.path & "\.emr\backup"
                     WriteWord "backup-Success: succeed in erasing all your backup ."
                     Set FSO3 = Nothing
                     Call ExitExec
                     Exit Sub
                 Case "-list"
                     Dim backupF As String, backupI As Integer, FSO As Object
                     Set FSO = PoolCreateObject("Scripting.FileSystemObject")
-                    backupF = Dir(App.Path & "\.emr\backup\", vbDirectory)
+                    backupF = Dir(App.path & "\.emr\backup\", vbDirectory)
                     Do While backupF <> ""
                         If backupF <> "." And backupF <> ".." Then
                             backupI = backupI + 1
-                            WriteLine backupI & ". " & backupF & "  (" & FSO.GetFolder(App.Path & "\.emr\backup\" & backupF).size & " bytes)"
+                            WriteLine backupI & ". " & backupF & "  (" & FSO.GetFolder(App.path & "\.emr\backup\" & backupF).size & " bytes)"
                         End If
                         backupF = Dir(, vbDirectory)
                         'reserve : folder size
@@ -373,7 +373,7 @@ ReCopy:
                     Call ExitExec
                     Exit Sub
                 Case "-reset"
-                    Open App.Path & "\.emerald" For Output As #1
+                    Open App.path & "\.emerald" For Output As #1
                     Print #1, 0 'version
                     Print #1, Now 'Update Time
                     Print #1, False
@@ -447,7 +447,7 @@ ReCopy:
                     WriteLine "Music List : " & IIf(EAni Is Nothing, "[Missing]", ObjPtr(EMusic))
                     WriteLine "Assets Tree : " & UBound(AssetsTrees) & " trees in total ."
                     For I = 1 To UBound(AssetsTrees)
-                        WriteLine I & ". " & AssetsTrees(I).Path & " (" & IIf(IsMissing(AssetsTrees(I).arg1), "[Missing]", AssetsTrees(I).arg1) & "," & IIf(IsMissing(AssetsTrees(I).arg2), "[Missing]", AssetsTrees(I).arg2) & ") , " & UBound(AssetsTrees(I).Files) & " files in total ."
+                        WriteLine I & ". " & AssetsTrees(I).path & " (" & IIf(IsMissing(AssetsTrees(I).arg1), "[Missing]", AssetsTrees(I).arg1) & "," & IIf(IsMissing(AssetsTrees(I).arg2), "[Missing]", AssetsTrees(I).arg2) & ") , " & UBound(AssetsTrees(I).Files) & " files in total ."
                     Next
                     WriteLine "Current EditBox : " & TextHandle
                     WriteLine "Bass : " & BassInstalled
@@ -867,7 +867,7 @@ End Sub
 Public Sub Update()
     If PageMark = 1 Then Call Update2: Exit Sub
 
-    'On Error Resume Next
+    On Error Resume Next
 
     Page.PaintLine -1, GH - 1, GW, GH - 1, argb(255, 0, 183, 195), 2
     If FPS <> 0 Then Page.Writes FPS & "/" & Int(1000 / Int(FPSct / FPS)), 15, 14, 34, argb(205, 182, 174, 173)