Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Серый форум → Общение → Windows Script Host, HTA (VBScript, JScript) → VBScript: нужны скрипты в Excel
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Нужна программа(в VBS) чтоб в Excel рисовался небольшой квадрат, и он двигался строго по квадратной траектории, и вторая программа тоже самое, но по траектории ромба.
Сам ни разу не програмировал, что-то подобное, по этому даже не прдствалю как сделать, не много работал в VB... Прошу срочно помочь.
Прошу срочно разъяснить, где именно должен рисоваться и двигаться квадрат? На форме? На рабочем листе (что в таком случае понимать под квадратом)? Зачем Вам это вообще нужно? Прошу срочно ответить. 
У меня уточнений по задаче больше нет, но думаю, что на рабочем листе. А так как будет удобнее сделать.
В макросах экселевских ничего не понимаю, но погуглив и попыхтев получилось вот что:
Sub newFigure()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, 200, 50, 50).Select
Selection.Name = "fig"
End Sub
Sub Run1()
ActiveSheet.Shapes("fig").Select
x = 0.75
y = 0
For k = 1 To 1600
Selection.ShapeRange.IncrementLeft x
Selection.ShapeRange.IncrementTop y
Application.Wait (2)
If k = 400 Then
x = 0
y = 0.75
End If
If k = 800 Then
x = -0.75
y = 0
End If
If k = 1200 Then
x = 0
y = -0.75
End If
Next k
End Sub
Sub Run2()
ActiveSheet.Shapes("fig").Select
x = 1
y = 0.75
For k = 1 To 800
Selection.ShapeRange.IncrementLeft x
Selection.ShapeRange.IncrementTop y
Application.Wait (2)
If k = 200 Then
x = -1
End If
If k = 400 Then
y = -0.75
End If
If k = 600 Then
x = 1
End If
Next k
End SubРаботает отличненько (если я правильно понял поставленную вами задачу). Залил файл на пару бесплатных файлохранилищ, можете скачать проверить. Здесь или тут
Помог материал отсюда
LDOst, уточняйте.
В одном флаконе (проверялось на «Microsoft Office 2003»):
Option Explicit
Const xlMaximized = &HFFFFEFD7
' Some of Enum MsoAutoShapeType
Const msoShapeRectangle = 1
Const msoShapeDiamond = 4
' Some Shape styles
Const msoShadow14 = 14
Const msoThreeD1 = 1
Const msoLineSolid = 1
Const msoLineRoundDot = 3
Const msoLineSingle = 1
Const msoTrue = &HFFFFFFFF
Const msoGradientDiagonalDown = 4
' Some of Enum MsoPresetGradientType
Const msoGradientRainbow = 16
Const msoGradientRainbowII = 17
' Some of Enum MsoPresetExtrusionDirection
Const msoExtrusionBottomRight = 1
Const msoExtrusionBottom = 2
Const msoExtrusionBottomLeft = 3
Const msoExtrusionRight = 4
Const msoExtrusionNone = 5
Const msoExtrusionLeft = 6
Const msoExtrusionTopRight = 7
Const msoExtrusionTop = 8
Const msoExtrusionTopLeft = 9
' Some of Enum XlMousePointer
Const xlDefault = &HFFFFEFD1
Const xlWait = 2
Dim objExcel
Dim objCommandBar
Dim dictCommandBars
Dim i
Dim sngStartCoord
Dim sngFlySize
Dim sngFigureSize
Dim sngStep
Dim sngSqrt2
Dim intExtrDirectionSquare
Dim intExtrDirectionRhombus
Dim objShapeSquare
Dim objShapeRhombus
Set objExcel = WScript.CreateObject("Excel.Application")
Set dictCommandBars = WScript.CreateObject("Scripting.Dictionary")
With objExcel
.Visible = True
.UserControl = True
.Cursor = xlWait
.Interactive = False
.ScreenUpdating = False
.WindowState = xlMaximized
.DisplayFormulaBar = False
.DisplayStatusBar = False
.SheetsInNewWorkbook = 1
For Each objCommandBar In .CommandBars
If objCommandBar.Visible Then
dictCommandBars.Add objCommandBar.Name, objCommandBar
objCommandBar.Enabled = False
End If
Next
With .Workbooks.Add
With .ActiveSheet
With .Application.ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
.DisplayOutline = False
.DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False
.DisplayWorkbookTabs = False
End With
sngStartCoord = 100
sngFlySize = 360
sngFigureSize = 50
With .Shapes.AddShape(msoShapeRectangle, sngStartCoord + sngFigureSize / 2, sngStartCoord + sngFigureSize / 2, sngFlySize, sngFlySize)
With .Line
.Weight = 0.25
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0
.ForeColor.SchemeColor = 24
.Visible = msoTrue
End With
End With
With .Shapes.AddShape(msoShapeDiamond, sngStartCoord + sngFigureSize / 2, sngStartCoord + sngFigureSize / 2, sngFlySize, sngFlySize)
With .Line
.Weight = 0.25
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0
.ForeColor.SchemeColor = 41
.Visible = msoTrue
End With
End With
intExtrDirectionSquare = msoExtrusionBottomRight
intExtrDirectionRhombus = msoExtrusionRight
Set objShapeSquare = .Shapes.AddShape(msoShapeRectangle, sngStartCoord, sngStartCoord, sngFigureSize, sngFigureSize)
SetShape objShapeSquare, 1, intExtrDirectionSquare
Set objShapeRhombus = .Shapes.AddShape(msoShapeRectangle, sngStartCoord, sngStartCoord + sngFlySize / 2, sngFigureSize, sngFigureSize)
SetShape objShapeRhombus, 2, intExtrDirectionRhombus
objShapeRhombus.IncrementRotation 45
.Application.ScreenUpdating = True
WScript.Sleep 1000
sngStep = 3
sngSqrt2 = Sqr(sngStep^2 + sngStep^2) / sngStep
For i = 1 To sngFlySize Step sngStep
If i >= sngFlySize / 3 * 2 Then
intExtrDirectionSquare = msoExtrusionBottomLeft
intExtrDirectionRhombus = msoExtrusionTop
ElseIf i >= sngFlySize / 3 Then
intExtrDirectionSquare = msoExtrusionBottom
intExtrDirectionRhombus = msoExtrusionTopRight
End If
MoveShape objShapeSquare, sngStep, 0, -sngStep, intExtrDirectionSquare
MoveShape objShapeRhombus, sngSqrt2, sngSqrt2, sngStep, intExtrDirectionRhombus
Next
For i = 1 To sngFlySize Step sngStep
If i >= sngFlySize / 3 * 2 Then
intExtrDirectionSquare = msoExtrusionTopLeft
intExtrDirectionRhombus = msoExtrusionLeft
ElseIf i >= sngFlySize / 3 Then
intExtrDirectionSquare = msoExtrusionLeft
intExtrDirectionRhombus = msoExtrusionTopLeft
End If
MoveShape objShapeSquare, 0, sngStep, -sngStep, intExtrDirectionSquare
MoveShape objShapeRhombus, sngSqrt2, -sngSqrt2, sngStep, intExtrDirectionRhombus
Next
For i = 1 To sngFlySize Step sngStep
If i >= sngFlySize / 3 * 2 Then
intExtrDirectionSquare = msoExtrusionTopRight
intExtrDirectionRhombus = msoExtrusionBottom
ElseIf i >= sngFlySize / 3 Then
intExtrDirectionSquare = msoExtrusionTop
intExtrDirectionRhombus = msoExtrusionBottomLeft
End If
MoveShape objShapeSquare, -sngStep, 0, -sngStep, intExtrDirectionSquare
MoveShape objShapeRhombus, -sngSqrt2, -sngSqrt2, sngStep, intExtrDirectionRhombus
Next
For i = 1 To sngFlySize Step sngStep
If i >= sngFlySize / 3 * 2 Then
intExtrDirectionSquare = msoExtrusionBottomRight
intExtrDirectionRhombus = msoExtrusionRight
ElseIf i >= sngFlySize / 3 Then
intExtrDirectionSquare = msoExtrusionRight
intExtrDirectionRhombus = msoExtrusionBottomRight
End If
MoveShape objShapeSquare, 0, -sngStep, -sngStep, intExtrDirectionSquare
MoveShape objShapeRhombus, -sngSqrt2, sngSqrt2, sngStep, intExtrDirectionRhombus
Next
WScript.Sleep 1000
With .Application.ActiveWindow
.DisplayGridlines = True
.DisplayHeadings = True
.DisplayOutline = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.DisplayWorkbookTabs = True
End With
End With
.Saved = True
End With
For Each objCommandBar In dictCommandBars.Items
objCommandBar.Enabled = True
Next
.Interactive = True
.Cursor = xlDefault
.DisplayFormulaBar = True
.DisplayStatusBar = True
End With
Set dictCommandBars = Nothing
Set objExcel = Nothing
WScript.Quit 0
'=============================================================================
'=============================================================================
Sub MoveShape(objShape, sngIncLeft, sngIncTop, sngIncRotate, intExtrDirection)
With objShape
.IncrementLeft sngIncLeft
.IncrementTop sngIncTop
.IncrementRotation sngIncRotate
.ThreeD.SetExtrusionDirection intExtrDirection
End With
End Sub
'=============================================================================
'=============================================================================
Sub SetShape(objShape, intType, intExtrDirection)
With objShape
With .Line
.Weight = 0.25
.DashStyle = msoLineRoundDot
.Style = msoLineSingle
.Transparency = 0
.ForeColor.SchemeColor = 24
.BackColor.RGB = RGB(255, 255, 255)
.Visible = msoTrue
End With
With .Fill
.Transparency = 0
Select Case intType
Case 1
.ForeColor.RGB = RGB(255, 51, 153)
.BackColor.RGB = RGB(51, 102, 255)
.PresetGradient msoGradientDiagonalDown, 2, msoGradientRainbowII
Case 2
.ForeColor.RGB = RGB(166, 3, 171)
.BackColor.RGB = RGB(166, 3, 171)
.PresetGradient msoGradientDiagonalDown, 1, msoGradientRainbow
Case Else
' Nothing to do
End Select
.Visible = msoTrue
End With
With .ThreeD
.ExtrusionColor.RGB = RGB(204, 236, 255)
.SetThreeDFormat msoThreeD1
.SetExtrusionDirection intExtrDirection
.Perspective = True
.Depth = 72
.Visible = msoTrue
End With
End With
End Sub
'=============================================================================Я просто в... 
В 2 ночи некто выражает желание получить анимацию в Excel: и чтобы квадрат, и чтобы по траектории, и ... см. выше.
А к 10 утра уже выложена реализация всего этого плюс в цвете и с вращением (ну чтоб не скучно было).
Нет, я понимаю, бывает, долго ли умеючи... Но у меня, зрителя со стороны, вызывает оторопелое опупение, когнитивный диссонанс и бурное восхищение.
alexii, это был экспромт или все-таки заготовка?
jite, это была бессонница. Плюс два с половиной часа попыток выложить поутру скрипт на форум.
На самом деле, более правильный подход к вопросу продемонстрировал коллега DnsIs — ровно то, что заказывали (я не пробовал загружать файл, но визуально, по коду, — должно работать).
2 alexii в следующий раз когда будет бессонница, загляните в комьюнити в ветку расчёта аннуитета, может по утру и темку закроем 
О, еще бы XMPP на WSH добить бы)
2JSman, чего уже добились в написании Jabber-клиента? Возможно где то посмотреть?
Огромное спасибо DnsIs, alexii. Все подходит, все работает. Очень сильно помогли) Не ожидал такую оперативность, и это очень приятно) И вижу тема вызвала у всех особый интерес))
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
