corelvba/UI/ArrangeForm.bas

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm 
   Caption         =   "蘭雅sRGB 手动拼版"
   ClientHeight    =   2475
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4650
   OleObjectBlob   =   "ArrangeForm.frx":0000
   ShowModal       =   0   'False
   StartUpPosition =   2  '屏幕中心
   WhatsThisButton =   -1  'True
   WhatsThisHelp   =   -1  'True
End
Attribute VB_Name = "ArrangeForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub CommandButton1_Click()
  On Error GoTo ErrorHandler
  API.BeginOpt
  
  Dim ls, hs As Integer: Dim lj, hj As Double
  Dim matrix As Variant: Dim sr As ShapeRange
  
  ls = Val(TextBox1.text)
  hs = Val(TextBox2.text)
  lj = Val(TextBox3.text)
  hj = Val(TextBox4.text)
  matrix = Array(ls, hs, lj, hj)
  
  Set sr = ActiveSelectionRange

  If ls * hs = 0 Then Exit Sub
  If ls = 1 Or hs = 1 Then
    arrange_Clone_one matrix, sr
    GoTo ErrorHandler
  End If
  
  '// 代码运行时关闭窗口刷新
  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
  '// 拼版矩阵
  arrange_Clone matrix, sr
  Unload Me
  
ErrorHandler:
  API.EndOpt
End Sub

'// 拼版矩阵  matrix = Array(ls, hs, lj, hj)
Private Function arrange_Clone(matrix As Variant, sr As ShapeRange)
  ls = matrix(0): hs = matrix(1)
  lj = matrix(2): hj = matrix(3)
  x = sr.SizeWidth: Y = sr.SizeHeight
  Set s1 = sr.Clone
  '// StepAndRepeat 方法在范围内创建多个形状副本
  Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
  s1.Delete
End Function

Private Function arrange_Clone_one(matrix As Variant, sr As ShapeRange)
  ls = matrix(0): hs = matrix(1)
  lj = matrix(2): hj = matrix(3)
  x = sr.SizeWidth: Y = sr.SizeHeight
  Set s1 = sr.Clone
  '// StepAndRepeat 方法在范围内创建多个形状副本
  If ls > 1 Then
    Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
  Else
    Set dup1 = s1
  End If
  If hs > 1 Then
    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
  End If
  s1.Delete
End Function