1
1

Replace_UI.frm 5.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Replace_UI
  3. ClientHeight = 4560
  4. ClientLeft = 45
  5. ClientTop = 330
  6. ClientWidth = 7590
  7. OleObjectBlob = "Replace_UI.frx":0000
  8. StartUpPosition = 1 'CenterOwner
  9. End
  10. Attribute VB_Name = "Replace_UI"
  11. Attribute VB_GlobalNameSpace = False
  12. Attribute VB_Creatable = False
  13. Attribute VB_PredeclaredId = True
  14. Attribute VB_Exposed = False
  15. #If VBA7 Then
  16. Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  17. Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  18. Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  19. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  20. Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  21. #Else
  22. Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  23. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  24. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  25. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  26. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  27. #End If
  28. Private Const GWL_STYLE As Long = (-16)
  29. Private Const GWL_EXSTYLE = (-20)
  30. Private Const WS_CAPTION As Long = &HC00000
  31. Private Const WS_EX_DLGMODALFRAME = &H1&
  32. Private Sub Close_Icon_Click()
  33. Unload Me '// 关闭
  34. End Sub
  35. Private Sub UserForm_Initialize()
  36. Dim IStyle As Long
  37. Dim hwnd As Long
  38. hwnd = FindWindow("ThunderDFrame", Me.Caption)
  39. IStyle = GetWindowLong(hwnd, GWL_STYLE)
  40. IStyle = IStyle And Not WS_CAPTION
  41. SetWindowLong hwnd, GWL_STYLE, IStyle
  42. DrawMenuBar hwnd
  43. IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
  44. SetWindowLong hwnd, GWL_EXSTYLE, IStyle
  45. With Me
  46. ' .StartUpPosition = 0
  47. ' .Left = 500
  48. ' .Top = 200
  49. .width = 378
  50. .Height = 228
  51. End With
  52. LNG_CODE = API.GetLngCode
  53. Init_Translations Me, LNG_CODE
  54. End Sub
  55. Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  56. If Button Then
  57. mx = X
  58. my = Y
  59. End If
  60. End Sub
  61. Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  62. If Button Then
  63. Me.Left = Me.Left - mx + X
  64. Me.Top = Me.Top - my + Y
  65. End If
  66. End Sub
  67. Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  68. Dim pos_x As Variant
  69. Dim pos_y As Variant
  70. pos_x = Array(307, 27)
  71. pos_y = Array(64, 126, 188, 200)
  72. If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
  73. Call copy_shape_replace
  74. ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
  75. Call copy_shape_replace_resize
  76. ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
  77. Call image_replace
  78. ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
  79. '// API.WebHelp "https://262235.xyz/index.php/tag/vba/"
  80. End If
  81. Replace_UI.Hide
  82. End Sub
  83. Private Sub image_replace()
  84. On Error GoTo ErrorHandler
  85. API.BeginOpt
  86. Dim image_path As String
  87. image_path = API.GetClipBoardString
  88. ActiveDocument.ReferencePoint = cdrCenter
  89. Dim sh As Shape, shs As Shapes, cs As Shape
  90. Dim X As Double, Y As Double
  91. Set shs = ActiveSelection.Shapes
  92. cnt = 0
  93. For Each sh In shs
  94. If cnt = 0 Then
  95. ActiveDocument.ClearSelection
  96. ActiveLayer.Import image_path
  97. Set sc = ActiveSelection
  98. cnt = 1
  99. Else
  100. sc.Duplicate 0, 0
  101. End If
  102. sh.GetPosition X, Y
  103. sc.SetPosition X, Y
  104. sh.GetSize X, Y
  105. sc.SetSize X, Y
  106. sh.Delete
  107. Next sh
  108. ErrorHandler:
  109. '// MsgBox "请先复制图片的完整路径,本工具能自动替换图片!"
  110. API.EndOpt
  111. End Sub
  112. Private Sub copy_shape_replace_resize()
  113. On Error GoTo ErrorHandler
  114. API.BeginOpt
  115. ActiveDocument.ReferencePoint = cdrCenter
  116. Dim sh As Shape, shs As Shapes, cs As Shape
  117. Dim X As Double, Y As Double
  118. Set shs = ActiveSelection.Shapes
  119. cnt = 0
  120. For Each sh In shs
  121. If cnt = 0 Then
  122. Set sc = ActiveDocument.ActiveLayer.Paste
  123. cnt = 1
  124. Else
  125. sc.Duplicate 0, 0
  126. End If
  127. sh.GetPosition X, Y
  128. sc.SetPosition X, Y
  129. sh.GetSize X, Y
  130. sc.SetSize X, Y
  131. sh.Delete
  132. Next sh
  133. ErrorHandler:
  134. '// MsgBox "请先复制Ctrl+C,然后选择要替换的物件运行本工具!"
  135. API.EndOpt
  136. End Sub
  137. Private Sub copy_shape_replace()
  138. On Error GoTo ErrorHandler
  139. API.BeginOpt
  140. ActiveDocument.ReferencePoint = cdrCenter
  141. Dim sh As Shape, shs As Shapes, cs As Shape
  142. Dim X As Double, Y As Double
  143. Set shs = ActiveSelection.Shapes
  144. cnt = 0
  145. For Each sh In shs
  146. If cnt = 0 Then
  147. Set sc = ActiveDocument.ActiveLayer.Paste
  148. cnt = 1
  149. Else
  150. sc.Duplicate 0, 0
  151. End If
  152. sh.GetPosition X, Y
  153. sc.SetPosition X, Y
  154. sh.Delete
  155. Next sh
  156. ErrorHandler:
  157. '// MsgBox "请先复制Ctrl+C,然后选择要替换的物件运行本工具!"
  158. API.EndOpt
  159. End Sub