修改字体渲染方式问题并添加渲染枚举

.gitignore

@@ -2,4 +2,6 @@
 *.docx
 
 video/*
-runtime/*
+runtime/*
+article/*
+experiment/*

Core/GAnimation.cls

@@ -32,39 +32,39 @@ Attribute VB_Exposed = False
         GetProgress_3 = Cubic(pro, 0, 1, 1, 1)
     End Function
 '================================================================
-    'Animation Project
-    Public Sub FadeIn(X, Y, w, h, Alpha, pro As Single)
-        Alpha = Alpha * pro
+    'Animation Solution
+    Public Sub FadeIn(X, y, w, h, alpha, pro As Single)
+        alpha = alpha * pro
     End Sub
-    Public Sub FadeOut(X, Y, w, h, Alpha, pro As Single)
-        Alpha = Alpha - Alpha * pro
+    Public Sub FadeOut(X, y, w, h, alpha, pro As Single)
+        alpha = alpha - alpha * pro
     End Sub
-    Public Sub FlyInFromLeft(X, Y, w, h, Alpha, pro As Single)
+    Public Sub FlyInFromLeft(X, y, w, h, alpha, pro As Single)
         X = X * pro
     End Sub
-    Public Sub FlyInFromRight(X, Y, w, h, Alpha, pro As Single)
+    Public Sub FlyInFromRight(X, y, w, h, alpha, pro As Single)
         X = X + (GW - X) * pro
     End Sub
-    Public Sub FlyInFromTop(X, Y, w, h, Alpha, pro As Single)
-        Y = Y * pro
+    Public Sub FlyInFromTop(X, y, w, h, alpha, pro As Single)
+        y = y * pro
     End Sub
-    Public Sub FlyInFromBottom(X, Y, w, h, Alpha, pro As Single)
-        Y = Y + (GH - Y) * pro
+    Public Sub FlyInFromBottom(X, y, w, h, alpha, pro As Single)
+        y = y + (GH - y) * pro
     End Sub
-    Public Sub FlyInFromLeftFade(X, Y, w, h, Alpha, pro As Single)
+    Public Sub FlyInFromLeftFade(X, y, w, h, alpha, pro As Single)
         X = X * pro
-        Alpha = Alpha * pro
+        alpha = alpha * pro
     End Sub
-    Public Sub FlyInFromRightFade(X, Y, w, h, Alpha, pro As Single)
+    Public Sub FlyInFromRightFade(X, y, w, h, alpha, pro As Single)
         X = X + (GW - X) * pro
-        Alpha = Alpha * pro
+        alpha = alpha * pro
     End Sub
-    Public Sub FlyInFromTopFade(X, Y, w, h, Alpha, pro As Single)
-        Y = Y * pro
-        Alpha = Alpha * pro
+    Public Sub FlyInFromTopFade(X, y, w, h, alpha, pro As Single)
+        y = y * pro
+        alpha = alpha * pro
     End Sub
-    Public Sub FlyInFromBottomFade(X, Y, w, h, Alpha, pro As Single)
-        Y = Y + (GH - Y) * pro
-        Alpha = Alpha * pro
+    Public Sub FlyInFromBottomFade(X, y, w, h, alpha, pro As Single)
+        y = y + (GH - y) * pro
+        alpha = alpha * pro
     End Sub
 '================================================================

Core/GCore.bas

@@ -113,6 +113,11 @@ Attribute VB_Name = "GCore"
         ScaleFullScreen = 1
         ScaleSuitable = 2
     End Enum
+    Public Enum ERenderMode
+        RenderModeDefault = 0
+        RenderModeFillPath = 1
+        RenderModeClearType = 2
+    End Enum
     Public Type ScrollArea
         Width As Long
         Height As Long
@@ -131,7 +136,7 @@ Attribute VB_Name = "GCore"
     Public EmeraldInstalled As Boolean
     Public BassInstalled As Boolean
     '版本号说明：[年份][月份][日期][版次]
-    Public Const Version As Long = 20040201     '20年4月2日，第1个版本
+    Public Const Version As Long = 20092701     '20年9月27日，第1个版本
     Public TextHandle As Long, WaitChr As String, LastUpdateTime As Long, HighCPUPermission As Integer
     Public XPMode As Boolean
     Public Scales As Single

Core/GFont.cls

@@ -17,7 +17,7 @@ Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (B
 Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
 Dim brush As Long, fFile As String, fFam As Long, StrF(2) As Long, Font(8, 1 To 1000) As Long, Spath As Long, Spen As Long
 Public EmHeight As Long
-Public RenderMode As Integer
+Public RenderMode As ERenderMode
 '========================================================
 '   Init
     Public Sub MakeFont(Name As String)
@@ -85,19 +85,20 @@ Public RenderMode As Integer
 
         GetHeight = R.Bottom
     End Function
-    Public Sub Writes(Text As String, X As Single, Y As Single, g As Long, Color As Long, ByVal size As Long, W As Single, H As Single, ByVal align As StringAlignment, ByVal style As FontStyle, Optional ByVal BorderColor As Long, Optional ByVal BorderSize As Long = 0)
+    Public Sub Writes(Text As String, X As Single, y As Single, g As Long, Color As Long, ByVal size As Long, w As Single, h As Single, ByVal align As StringAlignment, ByVal style As FontStyle, Optional ByVal BorderColor As Long, Optional ByVal BorderSize As Long = 0)
         'On Error Resume Next
         If Font(style, size) = 0 Then
             PoolCreateFont fFam, size, style, UnitPixel, Font(style, size)
         End If
         If EmHeight = 0 Then EmHeight = GetHeight(g, "ABCDEFG", 18, StringAlignmentNear, FontStyleRegular)
 
-        If RenderMode = 0 Then
-            GdipDrawString g, StrPtr(Text), -1, Font(style, size), NewRectF(X, Y, W, H), StrF(align), brush
+        GdipSetSolidFillColor brush, Color
+
+        If RenderMode <> RenderModeFillPath Then
+            GdipDrawString g, StrPtr(Text), -1, Font(style, size), NewRectF(X, y, w, h), StrF(align), brush
         Else
             GdipResetPath Spath
-            GdipAddPathString Spath, StrPtr(Text), -1, fFam, style, size, NewRectF(X, Y, W, H), StrF(align)
-            GdipSetSolidFillColor brush, Color
+            GdipAddPathString Spath, StrPtr(Text), -1, fFam, style, size, NewRectF(X, y, w, h), StrF(align)
 
             GdipFillPath g, brush, Spath
             If BorderSize > 0 Then

Core/GPage.cls

@@ -46,7 +46,11 @@ Public IsSystem As Boolean
         PoolCreateFromHdc CDC, GG
 
         GdipSetSmoothingMode GG, SmoothingModeAntiAlias
-        GdipSetTextRenderingHint GG, TextRenderingHintAntiAlias
+        If EF.RenderMode = RenderModeClearType Then
+            GdipSetTextRenderingHint GG, TextRenderingHintClearTypeGridFit
+        Else
+            GdipSetTextRenderingHint GG, TextRenderingHintAntiAlias
+        End If
 
         Set DrawBox = dBox
 

Core/GSaving.cls

@@ -27,16 +27,33 @@ Public sToken As Boolean, path As String
 Public Key As String
 '========================================================
 '   Init
+    Public Function FetchUserName() As String
+        On Error Resume Next
+        FetchUserName = "default"
+        FetchUserName = PoolCreateObject("Wscript.Network").Username
+    End Function
+    Public Sub CheckFullPath(path As String)
+        Dim S() As String
+        S = Split(path, "\")
+        Dim p As String
+        p = S(0) & "\"
+        For I = 1 To UBound(S)
+            p = p & S(I) & "\"
+            If Dir(p, vbDirectory) = "" Then MkDir p
+        Next
+    End Sub
     Public Function Create(Name As String, Optional BMKey) As Boolean
         If ESave Is Nothing Then Set ESave = Me
 
         If XPMode Then
             If Dir("C:\Emerad\", vbDirectory) = "" Then MkDir "C:\Emerad\"
             path = "C:\Emerad\" & Name
         Else
-            path = "C:\Users\" & PoolCreateObject("Wscript.Network").Username & "\AppData\Local\" & Name
+            path = "C:\Users\" & FetchUserName & "\AppData\Local\" & Name
         End If
 
+        Call CheckFullPath(path)
+
         AutoSave = True
 
         If Not IsMissing(BMKey) Then Key = BMKey
@@ -64,13 +81,13 @@ Public Key As String
 ErrHandle:
                 If Err.Number <> 0 Then
                     MsgBox "存档已经损坏！", 16, DisplayName: ReDim MySave.Data(0)
-                    Suggest "应用存档损坏。", NeverClear, 2
+                    Suggest "游戏存档损坏。", NeverClear, 2
                 End If
             End If
             Create = True
         End If
 
-        If Create = False Then Suggest "应用存档授权失败。", NeverClear, 1
+        If Create = False Then Suggest "游戏存档授权失败。", NeverClear, 1
         sToken = Create
 
     End Function
@@ -90,7 +107,7 @@ ErrHandle:
         If msg <> "" Then
             Call Save
             MsgBox "已经发现并删除存档中以下非法数据：" & vbCrLf & msg, 64
-            Suggest "应用存档中含有非法数据。", NeverClear, 1
+            Suggest "游戏存档中含有非法数据。", NeverClear, 1
         End If
     End Sub
 '========================================================
@@ -133,3 +150,4 @@ ErrHandle:
     End Sub
 '========================================================
 
+

Emerald.vbp

@@ -1,6 +1,6 @@
 Type=Exe
 Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\Windows\SysWOW64\stdole2.tlb#OLE Automation
-Reference=*\G{13FC9823-115E-4CB2-9A02-881895942E28}#1.646#0#..\Muing II\Win32Api.tlb#Win32API֮vb6ͷ�ļ� 2017-5-4�������� made by �޻��� 
+Reference=*\G{13FC9823-115E-4CB2-9A02-881895942E28}#1.646#0#..\ClassYET\Win32Api.tlb#Win32API֮vb6ͷ�ļ� 2017-5-4�������� made by �޻��� 
 Class=GPage; Core\GPage.cls
 Module=Bass; Core\Bass.bas
 Module=GCore; Core\GCore.bas

Emerald.vbw

@@ -2,7 +2,7 @@ GPage = -284, 138, 576, 514,
 Bass = 130, 130, 990, 509, 
 GCore = 104, 104, 845, 544, 
 GMan = 104, 104, 964, 483, 
-GFont = 182, 182, 923, 622, 
+GFont = 182, 182, 923, 622, Z
 GMusic = 52, 52, 903, 467, 
 GMusicList = 78, 78, 929, 488, 
 GSaving = 104, 104, 955, 514, 
@@ -30,6 +30,6 @@ GCrashBox = 192, 192, 913, 615,
 Gdiplus = 0, 0, 955, 411, 
 ResPool = 192, 192, 1147, 603, 
 BuilderCore = 64, 64, 1019, 475, 
-ToNewPage = 0, 0, 955, 411, Z
+ToNewPage = 0, 0, 955, 411, 
 MD5 = 64, 64, 1019, 475, 
 SetupPage = 64, 64, 1051, 427,