浏览代码

蘭雅CorelVBA工具 2024.5.1 永久免费开源开放 lyvba.com

蘭雅sRGB 10 月之前
父节点
当前提交
ceaa9454f2
共有 4 个文件被更改,包括 47 次插入3 次删除
  1. 2 1
      LinesForm.frm
  2. 二进制
      LinesForm.frx
  3. 44 1
      ThisMacroStorage.cls
  4. 1 1
      Tools.bas

+ 2 - 1
LinesForm.frm

@@ -6,13 +6,14 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinesForm
    ClientTop       =   390
    ClientWidth     =   4680
    OleObjectBlob   =   "LinesForm.frx":0000
-   StartUpPosition =   1  'ËùÓÐÕßÖÐÐÄ
+   StartUpPosition =   1  'CenterOwner
 End
 Attribute VB_Name = "LinesForm"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 

二进制
LinesForm.frx


+ 44 - 1
ThisMacroStorage.cls

@@ -7,6 +7,13 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = True
+#If VBA7 Then
+  Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
+#Else
+  Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
+#End If
+Public sreg As New ShapeRange
+
 Private Sub GlobalMacroStorage_SelectionChange()
 On Error GoTo ErrorHandler
   Dim n As Long
@@ -30,8 +37,27 @@ On Error GoTo ErrorHandler
   Else
       LinesForm.Caption = "LinesForm By Lanya"
   End If
+
+  If ActiveSelection.Shapes.Count = 1 Then
+    '// 检测Ctrl:Alt:Shift键状态 17-18-16
+    
+    If scankey() = 17 Then
+      If sreg.Exists(ActiveShape) Then sreg.Remove sreg.IndexOf(ActiveShape)
+      sreg.Add ActiveShape
+      LinesForm.Caption = "ActiveShape add SREG! Count:" & sreg.Count
+    End If
+    
+    If scankey() = 18 Then
+      sreg.RemoveAll
+      LinesForm.Caption = "SREG is Removed!"
+    End If
+    
+    If scankey() = 16 Then
+      sreg.CreateSelection
+    End If
   
-  
+  End If
+
   If ActiveSelection.Shapes.Count > 2 And AutoDistribute_Key Then
     Dim sr As ShapeRange
     Set sr = ActiveSelectionRange
@@ -43,3 +69,20 @@ On Error GoTo ErrorHandler
 ErrorHandler:
 
 End Sub
+
+Private Function scankey() As Long
+    Dim ctrlPressed As Boolean
+    Dim shiftPressed As Boolean
+    Dim altPressed As Boolean
+    
+    
+    ' 检测Ctrl键的状态  ' 检测Shift键的状态   ' 检测Alt键的状态
+    ctrlPressed = GetAsyncKeyState(17) And &H8000
+    shiftPressed = GetAsyncKeyState(16) And &H8000
+    altPressed = GetAsyncKeyState(18) And &H8000
+    
+    scankey = 0
+    If altPressed Then scankey = 18
+    If shiftPressed Then scankey = 16
+    If ctrlPressed Then scankey = 17
+End Function

+ 1 - 1
Tools.bas

@@ -23,7 +23,7 @@ Public Function Simple_Train_Arrangement(Space_Width As Double)
     '// µ×¶ÔÆë If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
     '// ¸Ä³É¶¥¶ÔÆë 2022-08-10
     ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).TopY
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).topY
     cnt = cnt + 1
   Next s