Windows11,Office2013で作成
パタパタ2.xlsm
Windows11,Office2013で作成
パタパタ2.xlsm
ExcelVBAのMid関数は切り抜くだけじゃない
この動画のマクロはWindows11/Office2013で作成してます。
Sub sample_1()
a = "A12345ABC": Debug.Print "元データ :" & a
' aの2文字目から5文字分を切り抜く
Debug.Print "パターン1:" & Mid(a, 2, 5)
' aの2文字目から以下全部を切り抜く
Debug.Print "パターン2:" & Mid(a, 2)
' aの2文字目から100文字分を切り抜く
Debug.Print "パターン3:" & Mid(a, 2, 100)
End Sub
Sub sample_2()
a = "A00000ABC": Debug.Print "元データ :" & a
' aの2文字目から5文字分のエリアに12345を入れる
Mid(a, 2, 5) = 12345
Debug.Print "パターン1:" & a
' aの2文字目から5文字分のエリアに123を入れる
a = "A00000ABC"
Mid(a, 2, 5) = 123
Debug.Print "パターン2:" & a
' aの2文字目から123を入れる
a = "A00000ABC"
Mid(a, 2) = 123
Debug.Print "パターン3:" & a
' aの2文字目から5文字分のエリアに123456789を入れる
a = "A00000ABC"
Mid(a, 2, 5) = 123456789
Debug.Print "パターン4:" & a
End Sub
Public Sub VBA100_65_1()
Dim dat As String
Dim lLen As Long, c, r, fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = ActiveWorkbook.Path
Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "text.txt"), 2, True)
For r = 2 To Range("A1").CurrentRegion.Rows.Count
dat = ""
For c = 1 To Range("A1").CurrentRegion.Columns.Count
'Debug.Print lLen, Sheets(2).Cells(c + 1, 1), Sheets(2).Cells(c + 1, 2), Sheets(2).Cells(c + 1, 3), Sheets(1).Cells(r, c)
Select Case Sheets(2).Cells(c + 1, 2)
Case "N" '0づめ数字
dat = dat & Format(Sheets(1).Cells(r, c), String(Sheets(2).Cells(c + 1, 3), "0"))
Case "C" '左詰め文字
dat = dat & Left(Sheets(1).Cells(r, c) + String(Sheets(2).Cells(c + 1, 3), " "), Sheets(2).Cells(c + 1, 3))
End Select
Next
Debug.Print dat & "*" '動作確認用
file.writeline dat
Next
file.Close
Set file = Nothing
End Sub
Public Sub VBA100_65_2()
Dim dat As String * 100 '少し多めに取っておく
Dim lLen As Long, c, r, fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = ActiveWorkbook.Path
Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "text.txt"), 2, True)
For r = 2 To Range("A1").CurrentRegion.Rows.Count
lLen = 1
dat = ""
For c = 1 To Range("A1").CurrentRegion.Columns.Count
'Debug.Print lLen, Sheets(2).Cells(c + 1, 1), Sheets(2).Cells(c + 1, 2), Sheets(2).Cells(c + 1, 3), Sheets(1).Cells(r, c)
Select Case Sheets(2).Cells(c + 1, 2)
Case "N" '0づめ数字
Mid(dat, lLen, Sheets(2).Cells(c + 1, 3)) = Format(Sheets(1).Cells(r, c), String(Sheets(2).Cells(c + 1, 3), "0"))
Case "C" '左詰め文字
Mid(dat, lLen, Sheets(2).Cells(c + 1, 3)) = Sheets(1).Cells(r, c)
End Select
lLen = lLen + Sheets(2).Cells(c + 1, 3)
Next
Debug.Print Mid(dat, 1, lLen - 1) & "*" '動作確認用
file.writeline Mid(dat, 1, lLen - 1)
Next
file.Close
Set file = Nothing
End Sub
VBAでステレオグラム(立体視/マジカル・アイ)を描いてみた
この動画のマクロはWindows11/Office2013で作成してます。
#If Win64 Then
' Excel が64ビット版の場合の関数定義です。
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#Else
' Excel が32ビット版の場合の関数定義です。
Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#End If
Const dots = "ドット"
Const ptrn = "図形"
Const strg = "ステレオグラム"
Const dots_size = 64
Const img_size_w = 300
Const img_size_h = 150
Sub Macro1()
'Sheetの初期化
MakeSheet dots
MakeSheet ptrn
MakeSheet strg
Sheets(dots).Activate
Call make_dots
MessageBoxTimeoutA 0, "ドット模様を書いた", "メッセージ", 1, 65536, 3 * 1000
Sheets(ptrn).Activate
MessageBoxTimeoutA 0, "パターンを描くぜ", "メッセージ", 1, 65536, 3 * 1000
Call make_img
MessageBoxTimeoutA 0, "ステレオグラムを描くぜ", "メッセージ", 1, 65536, 3 * 1000
Sheets(strg).Activate
Call make_autostereogram
MessageBoxTimeoutA 0, "見れ", "メッセージ", 1, 65536, 3 * 1000
End Sub
Function make_dots()
For r = 1 To dots_size
For c = 1 To dots_size
'乱数を発生させセルに値を入れ、背景色をその乱数で塗る
g = Int(Rnd * 255)
Sheets(dots).Cells(c, r).Value = g
Sheets(dots).Cells(c, r).Interior.Color = RGB(g, g, g)
Next
Next
End Function
Function make_img()
'Sheet2に
'半径が高さの1/3の円を描く
For r = 1 To img_size_w
For c = 1 To img_size_h
If (r - img_size_w / 2) ^ 2 + (c - img_size_h / 2) ^ 2 < (img_size_h / 3) ^ 2 Then
Sheets(ptrn).Cells(c, r).Value = 1
Sheets(ptrn).Cells(c, r).Interior.Color = RGB(0, 0, 0)
Else
Sheets(ptrn).Cells(c, r).Value = 0
End If
Next
'下側に境界線をつける
Sheets(ptrn).Cells(img_size_h + 1, r).Interior.Color = RGB(255, 0, 0)
Next
End Function
Function make_autostereogram()
shift_amplitude = 0.15
For r = 1 To img_size_w
For c = 1 To img_size_h
If r <= dots_size Then
'はじめの64(dots_size)セルはドットパターンをそのままコピー
Sheets(strg).Cells(c, r).Value = Sheets(dots).Cells(c Mod dots_size + 1, r).Value
Else
'図形パターンが重ならないところは64列前と同じ色にする
'図形パターンと重なるところは、64-α列前と同じ色にする。これで模様がずれるはず。
shift = Int(Sheets(ptrn).Cells(c, r).Value * shift_amplitude * dots_size)
Sheets(strg).Cells(c, r).Value = Sheets(strg).Cells(c, r - dots_size + shift).Value
End If
'セル背景色にセル値の色をぬる
g = Sheets(strg).Cells(c, r).Value
Sheets(strg).Cells(c, r).Interior.Color = RGB(g, g, g)
DoEvents
Next
Next
Range(Sheets(strg).Cells(1, 1), Sheets(strg).Cells(img_size_w, img_size_h)).ClearContents
End Function
Function MakeSheet(xMakeSheet As String)
'既存のシートを削除
Application.DisplayAlerts = False ' メッセージを非表示
If ExistsSheet(xMakeSheet) Then Sheets(xMakeSheet).Delete
Application.DisplayAlerts = True ' メッセージを表示
'シートを追加
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = xMakeSheet
'シートを神エクセル方眼紙にする
px = 3
Cells.ColumnWidth = px * 0.15
Cells.RowHeight = px * 1.5
End Function
Function ExistsSheet(bName As String)
Dim ws As Variant
ExistsSheet = False
'全シート繰り返す
For Each ws In Sheets
If LCase(ws.Name) = LCase(bName) Then
ExistsSheet = True ' シートが存在した
Exit Function
End If
Next
End Function
ExcelVBAで数学の教科書にあるような立体図形を描いてみた
この動画のマクロはWindows11/Office2013で作成してます。
Sub Macro_Ex_Wd_Pp()
Dim myDocument
Dim i, x, y, r, h
'Word,Excel,Powerpointどれでも動くようにする
Select Case True
Case Application.Caption = "Word"
Set myDocument = ActiveDocument
Case InStr(Application.Caption, "Excel") > 0
Set myDocument = ActiveSheet
Case Else
Set myDocument = ActivePresentation.Slides(1)
End Select
'今ある図形を消す
For i = myDocument.Shapes.Count To 1 Step -1
myDocument.Shapes(i).Delete
Next i
'図形の表示位置、半径、高さ
x = 150: y = 200
r = 100: h = 100
'球、円柱、円錐
Call Ball(myDocument, x, y, r)
Call Cylinder(myDocument, x, y, r, h)
Call Cone(myDocument, x, y, r, h)
'立方体、四角錐、三角錐
x = 500: y = 100
Call Cube(myDocument, x, y, r)
y = 250
Call Pyramid(myDocument, x, y, r)
y = 350
Call Tetrahedron(myDocument, x, y, r)
End Sub
Function Ball(obj, x, y, r)
'球を描画
' obj 描画するオブジェクト
' 中心(x,y) 半径r
Dim SN(0 To 2) As Variant
Dim shp, a
a = 0.3
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8, x + r, y + r * a / 8)
'赤道の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2 '破線
'赤道の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'外周
Set shp = obj.Shapes.AddShape(msoShapeOval, x - r / 1, y - r / 1, r * 2, r * 2)
SN(2) = shp.Name
shp.Fill.Visible = msoFalse '円の塗りつぶしなし
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "球"
Set Ball = shp
End Function
Function Cylinder(obj, x, y, r, h)
'円柱を描画
' obj 描画するオブジェクト
' 上面中心(x,y) 半径r
'y > h+r/2であるべき
Dim SN(0 To 4) As Variant
Dim shp, a
a = 0.3 '楕円の潰れ具合
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8, x + r, y + r * a / 8)
'上面
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 360
lineattr shp, msoLineSolid, 2
'底面の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = -180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2
'底面の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(2) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'右の線
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x - r, y + r * a / 8, x - r, y + r * a / 8 + h)
SN(3) = shp.Name
lineattr shp, msoLineSolid, 2
'左の線
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x + r, y + r * a / 8, x + r, y + r * a / 8 + h)
SN(4) = shp.Name
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "円柱"
Set Cylinder = shp
End Function
Function Cone(obj, x, y, r, h)
'円錐を描画
' obj 描画するオブジェクト
' 頂点(x,y) 半径r
' y > hであるべき
Dim SN(0 To 3) As Variant
Dim shp, a
a = 0.3 '楕円の潰れ具合
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8 + h, x + r, y + r * a / 8 + h)
'底面の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2
'底面の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'稜線(左)
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y, x - r, y + r * a / 8 + h)
SN(2) = shp.Name
lineattr shp, msoLineSolid, 2
'稜線(右)
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y, x + r, y + r * a / 8 + h)
SN(3) = shp.Name
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "円錐"
Set Cone = shp
End Function
Function Cube(obj, x, y, r)
'立方体を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 3) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の立方体の頂点の配列
p = Array(Array(-1, 1, -1), _
Array(1, 1, -1), _
Array(1, 1, 1), _
Array(-1, 1, 1), _
Array(-1, -1, -1), _
Array(1, -1, -1), _
Array(1, -1, 1), _
Array(-1, -1, 1))
'座標点をr/2倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r / 2)
Next
'全頂点を回転
rt = Array(30, 20, -20) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(5, 4, 7, 6, 5, 1, 2, 3, 7))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
Set shp = trackline(obj, o, p, Array(2, 6))
Call lineattr(shp, msoLineSolid, 2)
SN(1) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(3, 0, 1))
Call lineattr(shp, msoLineDash, 2)
SN(2) = shp.Name
Set shp = trackline(obj, o, p, Array(0, 4))
Call lineattr(shp, msoLineDash, 2)
SN(3) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "立方体"
Set Cube = shp
End Function
Function Pyramid(obj, x, y, r)
'正四角錐を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 2) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の正四面体の頂点の配列
p = Array(Array(0, -3 / Sqr(2) / 2, 0), _
Array(1, 1 / Sqr(2) / 2, 1), _
Array(-1, 1 / Sqr(2) / 2, 1), _
Array(-1, 1 / Sqr(2) / 2, -1), _
Array(1, 1 / Sqr(2) / 2, -1))
'座標点をr/2倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r / 2)
Next
'全頂点を回転
rt = Array(10, 20, 0) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(0, 2, 1, 0, 4, 1))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(2, 3, 4))
Call lineattr(shp, msoLineDash, 2)
SN(1) = shp.Name
Set shp = trackline(obj, o, p, Array(0, 3))
Call lineattr(shp, msoLineDash, 2)
SN(2) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "四角錐"
Set Pyramid = shp
End Function
Function Tetrahedron(obj, x, y, r)
'正四面体を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 1) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の正四面体の頂点の配列
p = Array(Array(0, 0, Sqr(2) / Sqr(3) * (2 / 3)), _
Array(-1 / 2, 1 / Sqr(3) / 2, -Sqr(2) / Sqr(3) / 3), _
Array(1 / 2, 1 / Sqr(3) / 2, -Sqr(2) / Sqr(3) / 3), _
Array(0, -1 / Sqr(3), -Sqr(2) / Sqr(3) / 3))
'座標点をr倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r)
Next
'全頂点を回転
rt = Array(300, 120, -25) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(0, 1, 2, 0, 3, 1))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(2, 3))
Call lineattr(shp, msoLineDash, 2)
SN(1) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "正四面体"
Set Tetrahedron = shp
End Function
Function trackline(obj, o, p, Route)
'点から点への線を描画
Dim shp_Name() As Variant
Dim shp, i
ReDim shp_Name(UBound(Route) - 1)
For i = 0 To UBound(Route) - 1
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, o(0) + Int(p(Route(i + 1))(0)), o(1) + Int(p(Route(i + 1))(1)), o(0) + Int(p(Route(i))(0)), o(1) + Int(p(Route(i))(1)))
shp_Name(i) = shp.Name
'番号をふる(デバック用)
'Set txt = obj.Shapes.AddTextbox(msoTextOrientationHorizontal, o(0) + Int(p(Route(i + 1))(0)), o(1) + Int(p(Route(i + 1))(1)), 20, 20)
'txt.TextFrame.Characters.Text = Route(i + 1)
Next
If UBound(Route) > 1 Then
obj.Shapes.Range(shp_Name).Group.Name = shp_Name(0)
Set trackline = obj.Shapes(shp_Name(0))
Else
Set trackline = shp
End If
End Function
Function lineattr(obj, d, Optional w As Integer = 1, Optional rgb As Long = 12287562)
'線のスタイル、太さ、色(任意)を変更
With obj
.Line.DashStyle = d
.Line.Weight = w
.Line.ForeColor.rgb = rgb
End With
End Function
Function Xrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'X軸回転させる
' 1 0 0
' 0 cos sin
' 0 -sin cos
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Xrote = Array(v(0), Cos(d * rad_1do) * v(1) + Sin(d * rad_1do) * v(2), -Sin(d * rad_1do) * v(1) + Cos(d * rad_1do) * v(2))
End Function
Function Yrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'Y軸回転させる
' cos 0 -sin
' 0 1 0
' sin 0 cos
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Yrote = Array(Cos(d * rad_1do) * v(0) - Sin(d * rad_1do) * v(2), v(1), Sin(d * rad_1do) * v(0) + Cos(d * rad_1do) * v(2))
End Function
Function Zrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'Z軸回転させる
' cos sin 0
' -sin cos 0
' 0 0 1
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Zrote = Array(Cos(d * rad_1do) * v(0) + Sin(d * rad_1do) * v(1), -Sin(d * rad_1do) * v(0) + Cos(d * rad_1do) * v(1), v(2))
End Function
Function MatScl(v, scl)
'(x,y,z)座標の配列の要素をscl倍する
Dim a
a = Array(v(0) * scl, v(1) * scl, v(2) * scl)
MatScl = Array(v(0) * scl, v(1) * scl, v(2) * scl)
End Function
ExcelVBAで数独を解いてみた
この動画のマクロはWindows11/Office2013で作成してます。
Option Explicit
#If Win64 Then
' Excel が64ビット版の場合の関数定義です。
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#Else
' Excel が32ビット版の場合の関数定義です。
Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#End If
Type SudokuType
盤面 As String * 81
flag行(8) As Integer
flag列(8) As Integer
flag面(8) As Integer
残り As Integer
End Type
Type AddrType
行 As Integer
列 As Integer
面 As Integer
End Type
Dim answer As String
Dim org As String
Dim cnt As Long
'盤面を描く左上のセル番号
Const board_top_c = 4
Const board_top_r = 3
Sub Macro()
Dim Driver As New Selenium.WebDriver
Dim o_elem, Item, i, Sudoku_txt
Dim startTime, endTime, processTime
'数独を盤面を描く
With Range(Cells(board_top_c, board_top_r), Cells(board_top_c + 8, board_top_r + 8))
.ClearContents
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.BorderAround Weight:=xlThick
End With
Range(Cells(board_top_c + 0, board_top_r + 3), Cells(board_top_c + 8, board_top_r + 5)).BorderAround Weight:=xlThick
Range(Cells(board_top_c + 3, board_top_r + 0), Cells(board_top_c + 5, board_top_r + 8)).BorderAround Weight:=xlThick
'数独データ
Sudoku_txt = "000000000000000027400608000071000300238506419964100750395027800182060974046819205" '初級
'Sudoku_txt = "000000000000000280376400000700001000020000000400300006010028000000005000000000003" '最高級
Sudoku_txt = "005300000800000020070010500400005300010070006003200080060500009004000030000009700" 'フィンランド人数学者の世界一難しい数独。
'Sudoku_txt = "" '空白の場合ネットから拾う
If Sudoku_txt = "" Then
'Sudoku_txtがカラの場合ネットからの情報を使う
'ここでブラウザを立ち上げるため、SeleniumBasicのインストールが別途必要です。
'ツール - 参照設定でSeleniumTypeLibをチェックすること。
'Edgeブラウザを起動
Driver.Start "Edge"
Driver.Window.SetPosition 1300, 0
Driver.Window.SetSize 800, 800
Driver.Get "http://www.sudokugame.org/"
'インラインフレームに制御を切り替える
Driver.SwitchToFrame "f1"
'数独マスのinputをとってくる
Set o_elem = Driver.FindElementsByCss("table.sd td input")
For Each Item In o_elem
If Item.Attribute("value") = "" Then
Sudoku_txt = Sudoku_txt + "0" '空マス
Else
Sudoku_txt = Sudoku_txt + Item.Attribute("value") '数字が入ったマス
End If
Next
org = Sudoku_txt
Else
org = ""
End If
Dim Sudoku As SudokuType 'Sudoku構造体の宣言
Call Sudoku_init(Sudoku) 'Sudoku構造体の初期化
'問題データーSudoku_txtからSudoku構造体に値を設定
For i = 0 To 80
Call Sudoku_setNum(Sudoku, i, Mid(Sudoku_txt, i + 1, 1))
Next
Call showBoard(Sudoku.盤面, 0) '盤面の描画
MessageBoxTimeoutA 0&, Sudoku_txt, "解答スタート", 1, 65536, 2 * 1000
'カウンタをリセット
cnt = 0
'開始時間取得
startTime = Timer
'------------------------------------
' 数独解答
Call Sudoku_Try(Sudoku)
'------------------------------------
'終了時間取得
endTime = Timer
'処理時間計算
processTime = endTime - startTime
Debug.Print cnt & "手 " & processTime & "秒"
MessageBoxTimeoutA 0&, cnt & "手 " & processTime & "秒", "解答終わりました", 1, 65536, 5 * 1000
If org <> "" Then
'ネットからとってきた問題なのでネットに回答
MessageBoxTimeoutA 0&, Sudoku_txt, "ホームページに回答", 1, 65536, 2 * 1000
For i = 1 To 81
o_elem.Item(i).SendKeys Mid(answer, i, 1)
Next
'「チェック」ボタンを押す
Driver.FindElementByCss("#btcheck").Click
MessageBoxTimeoutA 0&, Sudoku_txt, "ホームページに回答終了", 1, 65536, 3 * 1000
'ポップアップのOKボタンを押す
Driver.SwitchToAlert.Accept
'ブラウザを閉じる
Driver.Quit
Set Driver = Nothing
End If
End Sub
Private Function Sudoku_Try(t As SudokuType) As Boolean
Dim rtn As Boolean
Sudoku_Try = False
Do
Do
'縦or横orブロックの他の数字から1個絞れるマスを埋める
rtn = methodA(t)
Call showBoard(t.盤面, 5) '盤面の描画
Loop While rtn
If t.残り > 0 Then
'1-9の数字を入れてみて、数字が1個に絞られるマスを埋める
rtn = methodB(t)
Call showBoard(t.盤面, 3) '盤面の描画
End If
Loop While rtn
'数字が置けなくなった。つまり完成したか手詰まり
If t.残り = 0 Then
'完成
answer = t.盤面
Debug.Print "完成"
Debug.Print answer
Call showBoard(t.盤面, 3) '盤面の描画
Sudoku_Try = True
Exit Function
Else
'手詰まり。別のところに数字を入れて再試行処理へ
'Debug.Print "手詰まり。別のところに数字を入れて再試行処理へ"
If backtrack(t) = True Then
Sudoku_Try = True
Exit Function
End If
End If
End Function
Private Function methodA(t As SudokuType) As Boolean
'縦or横orブロックの他の数字から1個絞れるマスを埋める
Dim p, flag, n
For p = 0 To 80
If Mid(t.盤面, p + 1, 1) = "0" Then
Dim Addr As AddrType
Addr = TranslateAddr(p)
flag = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面)
If flag <> 0 Then
'512=2の9乗を割れる、flag=2のべき定数であり、フラグが1個しか立ってない状態
If 512 Mod flag = 0 Then
'立ってるビットが1個だけ。つまり数字が1個に絞られている
n = getFirstNum(flag)
Debug.Print "methodA 位置p:" & Right(" " + str(p), 2) & " に数字:" & n & " を置くことが可能"
Call Sudoku_setNum(t, p, n)
methodA = True
End If
End If
End If
Next
methodA = False
End Function
Private Function methodB(t As SudokuType) As Boolean
'1-9の数字を入れてみて、数字が1個に絞られるマスを埋める
Dim n, p, flag
Dim pflag行(9)
Dim pflag列(9)
Dim pflag面(9)
Dim c行(8)
Dim c列(8)
Dim c面(8)
'数字(1-9)を置けるかをチェックしていく
For n = 1 To 9
For p = 0 To 8
c行(p) = 0
c列(p) = 0
c面(p) = 0
Next
'全マスに対して数字nが置けるかチェック
For p = 0 To 80
If Sudoku_canPlace(t, p, n) Then
Dim Addr As AddrType
Addr = TranslateAddr(p)
c行(Addr.行) = c行(Addr.行) + 1
pflag行(Addr.行) = p
c列(Addr.列) = c列(Addr.列) + 1
pflag列(Addr.列) = p
c面(Addr.面) = c面(Addr.面) + 1
pflag面(Addr.面) = p
End If
Next
'置ける数字が1個に絞られるマスに数字を埋めて処理を抜ける
For p = 0 To 8
If c行(p) = 1 Then
'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & " に数字:" & n & " を置くことが可能"
Call Sudoku_setNum(t, pflag行(p), n)
methodB = True
Exit Function
End If
Next
For p = 0 To 8
If c列(p) = 1 Then
'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & " に数字:" & n & " を置くことが可能"
Call Sudoku_setNum(t, pflag列(p), n)
methodB = True
Exit Function
End If
Next
For p = 0 To 8
If c面(p) = 1 Then
'Debug.Print "methodB 位置p:" & Right(" " + str(p), 2) & " に数字:" & n & " を置くことが可能"
Call Sudoku_setNum(t, pflag面(p), n)
methodB = True
Exit Function
End If
Next
methodB = False
Next
End Function
Private Function backtrack(t As SudokuType) As Boolean
'盤面のデータを保存して別のところに数字を入れて再試行
Dim backupSpace As SudokuType, p, n
backtrack = False
backupSpace = t
p = Sudoku_nextAvail(t)
For n = 1 To 9
If Sudoku_canPlace(t, p, n) Then
Debug.Print "backtrack 位置p:" & Right(" " + str(p), 2) & " に数字:" & n & " を置いて再試行"
Call Sudoku_setNum(t, p, n)
If Sudoku_Try(t) = True Then
backtrack = True
Exit Function
End If
t = backupSpace
End If
Next
End Function
Sub Sudoku_init(t As SudokuType)
'SudokuType型データを初期化
'flagに &H3FE = b0011 1111 1110を設定。
'つまり123456789の数字のフラグを建てた状態
Dim i As Integer
For i = 0 To 8
t.flag行(i) = &H3FE
t.flag列(i) = &H3FE
t.flag面(i) = &H3FE
t.残り = 81
Next
End Sub
Sub Sudoku_setNum(t As SudokuType, p, n)
'数独に数字を置く
'p:先頭からの位置
'n:置く数字
Dim mask As Integer
Dim Addr As AddrType
Addr = TranslateAddr(p)
mask = Not (2 ^ n)
'行列面のflagエリアに置く数字に対応するビットを下ろす
' ---- --98 7654 321-
' 各flagエリア 0000 0000 0000 0000
' 例 2を置く場合、mask=not(2^2)=not(4)=not(b000000100)=b11111011
' flag And mask より、flagの3bit目が0になる
t.flag行(Addr.行) = t.flag行(Addr.行) And mask
t.flag列(Addr.列) = t.flag列(Addr.列) And mask
t.flag面(Addr.面) = t.flag面(Addr.面) And mask
' t.盤面のp番目(pは0始まり)をnにする
'Debug.Print "p=" & p & "-> " & Right(str(n), 1)
t.盤面 = Mid(t.盤面, 1, p) & Right(str(n), 1) & Mid(t.盤面, p + 2) '1文字置き換え
If n > 0 Then
t.残り = t.残り - 1
End If
'カウントアップ
cnt = cnt + 1
End Sub
Private Function TranslateAddr(p) As AddrType
'先頭からの位置p(0-80)から行列面を求める
Dim bq As Integer, br As Integer, i As Byte
TranslateAddr.行 = Int(p / 9) '9で割った商 行を表す
TranslateAddr.列 = Int(p Mod 9) '9で割った余り 列を表す
'行列をさらに3で割って、第何面を求める
bq = Int(TranslateAddr.列 / 3)
br = Int(TranslateAddr.行 / 3)
TranslateAddr.面 = br * 3 + bq
End Function
Private Function getFirstNum(flag) As Integer
getFirstNum = 0
If flag = 0 Then
Exit Function
End If
'最初に1が立ってるフラグ位置を求める
'つまり可能性のある最小の数字
While (flag And 1) = 0
getFirstNum = getFirstNum + 1
flag = Int(flag / 2) 'フラグを右にシフト
Wend
End Function
Private Function Sudoku_nextAvail(t As SudokuType) As Integer
'数字を置ける次の空マスを見つける
Dim min_c, min_p, p
min_c = 10
min_p = -1
For p = 0 To 80
If Mid(t.盤面, p + 1, 1) = "0" Then
Dim c
c = Sudoku_countAvail(t, p)
If c < min_c Then
min_c = c
min_p = p
End If
End If
Next
Sudoku_nextAvail = min_p
End Function
Private Function Sudoku_countAvail(t As SudokuType, p) As Integer
'行列面のflagのAND演算より、置ける可能性のある数字の個数を求める
Dim flag
Dim Addr As AddrType
Addr = TranslateAddr(p)
'flag = getFlags(t, p)
flag = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面)
Sudoku_countAvail = countBits(flag)
End Function
Private Function countBits(f) As Integer
'fの2進数表記で1が何個あるか
countBits = 0
While f
If f And 1 Then
countBits = countBits + 1
End If
f = Int(f / 2)
Wend
End Function
Function Sudoku_canPlace(t As SudokuType, p, n)
'pに数字nが置けるかチェックする
If Mid(t.盤面, p + 1, 1) <> "0" Then
'すでに数字が置かれている
Sudoku_canPlace = 0
Else
Dim Addr As AddrType
Addr = TranslateAddr(p)
'マスの行列面の状態ビットと数字ビットのAND演算をして、置けるかどうか判定
'おけない場合Sudoku_canPlaceは0になる。
Sudoku_canPlace = t.flag行(Addr.行) And t.flag列(Addr.列) And t.flag面(Addr.面) And (2 ^ n)
End If
End Function
Sub showBoard(Sudoku_txt, f_shoki)
'盤面をシートに書く
Dim num, p
Dim Addr As AddrType
For p = 0 To 80
Addr = TranslateAddr(p)
num = CInt(Mid(Sudoku_txt, p + 1, 1))
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.Size = 36
If num > 0 Then
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列) = num
Else
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列) = ""
End If
'マスの文字色
If f_shoki = 0 Then
'初期状態(f_shoki=0)の描画
'文字色は数字は黒色で、空マスは赤を入れる
If num > 0 Then
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = 1
Else
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = 3
End If
Else
'問題の数字以外は文字色にf_shokiを入れる
If Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex <> 1 Then
Cells(board_top_c, board_top_r).Offset(Addr.行, Addr.列).Font.ColorIndex = f_shoki
End If
End If
Next
DoEvents
End Sub
ExcelVBAで祝日つき予定表の作成してみた
この動画のマクロはWindows11/Office2013で作成してます。
内閣府 「国民の祝日」について
https://www8.cao.go.jp/chosei/shukujitsu/gaiyou.html
昭和30年(1955年)から令和5年(2023年)国民の祝日(csv形式:20KB)
https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv
Option Explicit
Sub Macro1()
Const org_r = 1 ' 横方向
Const org_c = 2 ' 縦方向
Const num_box = 2
Const sUrl = "https://www8.cao.go.jp/chosei/shukujitsu/syukujitsu.csv"
'その他の変数宣言
Dim this_year, xShukujitu, ws, ShukujitsuTBL, y, m, d, sLast, sLastDay, cell_date, cell_month, xlookup, x_date
' 今年の年を取得
this_year = Year(Date)
Application.DisplayAlerts = False ' メッセージを非表示
' 今年のシートの作成
If ExistsSheet(Str(this_year)) Then Sheets(Str(this_year)).Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Str(this_year)
' 来年のシートの作成
If ExistsSheet(Str(this_year + 1)) Then Sheets(Str(this_year + 1)).Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Str(this_year + 1)
' 祝日シートの作成
xShukujitu = "祝日"
If ExistsSheet(xShukujitu) Then Sheets(xShukujitu).Delete
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = xShukujitu
' ネット上の祝日データーCSVの読み込み
Set ws = ActiveSheet.QueryTables.Add(Connection:="TEXT;" & sUrl, Destination:=Range(xShukujitu & "!$A$1"))
ws.TextFilePlatform = 932 ' Shift_JIS を開く
ws.TextFileStartRow = 1 ' 1 行目から読み込み
ws.TextFileParseType = xlDelimited ' 区切り文字の形式
ws.TextFileCommaDelimiter = True ' カンマ区切り
ws.TextFileColumnDataTypes = Array(2, 2) ' データータイプを文字型にする
ws.Refresh BackgroundQuery:=False ' CSV取得
ShukujitsuTBL = ws.Name
For y = this_year To this_year + 1
Sheets(Str(y)).Select
For m = 1 To 12
' 翌月1日の前日を取得
sLast = DateSerial(y, m + 1, 0)
' 末日の日を取得
sLastDay = Format(sLast, "d")
For d = 1 To sLastDay
Set cell_date = Cells(org_c + d, org_r + (m - 1) * (num_box + 1)) ' 1日目を書くセル
x_date = DateSerial(y, m, d)
cell_date.Value = x_date
cell_date.NumberFormatLocal = "d"
' 祝日テーブルを検索
On Error Resume Next
xlookup = ""
xlookup = WorksheetFunction.VLookup(Format(x_date, "yyyy/m/d"), Sheets(xShukujitu).Range(ShukujitsuTBL), 2, False)
On Error GoTo 0
If xlookup <> "" Then
' 祝日テーブルにあった!
cell_date.Offset(0, 1).Value = xlookup
cell_date.Font.Color = RGB(255, 0, 0)
End If
Select Case Weekday(x_date)
Case 1 ' 日曜
Range(cell_date, cell_date.Offset(0, num_box)).Interior.Color = RGB(255, 153, 204)
Case 7 ' 土曜
Range(cell_date, cell_date.Offset(0, num_box)).Interior.Color = RGB(0, 204, 255)
End Select
Next
Set cell_month = Cells(org_c, org_r + (m - 1) * (num_box + 1)) ' 月の名前を書くセル
cell_month.Value = m & "月"
' 枠線を引く
With Range(cell_month, cell_month.Offset(sLastDay, num_box))
.Borders.LineStyle = xlContinuous
.BorderAround Weight:=xlThick
End With
Next
Next
End Sub
' シートの存在を判定する関数
Private Function ExistsSheet(ByVal bName As String)
Dim ws As Variant
ExistsSheet = False
For Each ws In Sheets
If LCase(ws.Name) = LCase(bName) Then
ExistsSheet = True ' 存在した
Exit Function
End If
Next
End Function
VBAでWindowsアプリ「メモ帳」を操作してみた・SendMessage/PostMessage編
この動画のマクロはWindows11/Office2013で作成してます。
メモ帳のidとかはWindows11とそれ以前のWindowsとでは異なってる可能性がありますので、
Windows11以外で動かす場合はspyxx_amd64.exeでidを確認しコード修正をする必要があります。
Option Explicit
'64ビットOffice用です。
'32ビット版ではPtrSafe をとると動くかもしれません。確認はしてませんが。
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hMemochoParent As Long, ByVal hMemochoChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hMemocho As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hMemocho As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const WM_COMMAND = &H111
Const WM_CLOSE = &H10
Const WM_SETTEXT As Long = &HC
Const WM_GETTEXT As Long = &HD
Const WM_GETTEXTLENGTH As Long = &HE
Const EM_REPLACESEL As Long = &HC2
Const EM_SETMODIFY As Long = &HB9
Const BM_CLICK As Long = &HF5
Const VK_RETURN As Long = &HD 'Enterキー
Const WM_KEYDOWN As Long = &H100
Const WM_KEYUP As Long = &H101
Sub Memo2()
Dim hMemocho As Long
Dim hNamae As Long
Dim hChild As Long
Dim nLen As Long
Dim rtn As Long
Dim xStr As String
Dim xFikename As String
Dim fso, CurrentDirectory, i
'---------------------------------------------------------------------------
'エクセルファイルのあるパス名を取得
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = ActiveWorkbook.Path
' メモ帳の起動
Call Shell("notepad.exe", vbNormalFocus)
Do While hMemocho = 0
hMemocho = FindWindowEx(0, 0, "Notepad", vbNullString)
'DoEvents
Sleep 100 'DoEventsだとうまく動かないのでSleepを使った
Loop
'Windows11付属のメモ帳の編集エリア
hChild = FindWindowEx(hMemocho, 0&, "RichEditD2DPT", vbNullString)
For i = 1 To 2
xStr = Cells(i, 2).Value
rtn = SendMessage(hChild, EM_REPLACESEL, 0, xStr & vbCrLf) ' 文字列を送信
Next
rtn = SendMessage(hChild, EM_SETMODIFY, 0, 0&) '変更フラグOFF
'メモ帳の編集エリアから文字列を読み取る
' コマンドラインの文字列の長さ 0&はLong型の0を意味する
nLen = SendMessage(hChild, WM_GETTEXTLENGTH, 0, 0&)
' 文字列 +1 の長さの空白文字列を用意 +1はNullコード(&H00)
xStr = String(nLen + 1, vbNullChar)
rtn = SendMessage(hChild, WM_GETTEXT, nLen + 1, xStr)
Debug.Print xStr
'---------------------------------------------------------------------------
' 「名前を付けて保存」Windowの処理
' このエクセルファイルと同じフォルダーに"abc.txt"という名前で保存する
'
'保存しようとするファイルが存在してると、上書きを聞いてくるので
'予めファイルがあったら削除しておく。
xFikename = fso.BuildPath(CurrentDirectory, "abc.txt")
If fso.FileExists(xFikename) Then
fso.DeleteFile xFikename, True
End If
rtn = PostMessage(hMemocho, WM_COMMAND, &H4, 0&) 'ファイル - 名前をつけて保存
Do While hNamae = 0 Or hChild = 0
hNamae = FindWindowA(vbNullString, "名前を付けて保存")
hChild = FindWindowEx(hNamae, 0&, "DUIViewWndClassName", vbNullString)
hChild = FindWindowEx(hChild, 0&, "DirectUIHWND", vbNullString)
hChild = FindWindowEx(hChild, 0&, "FloatNotifySink", vbNullString)
hChild = FindWindowEx(hChild, 0&, "ComboBox", vbNullString)
'DoEvents
Sleep 100 'DoEventsだとうまく動かないのでSleepを使った
Loop
xStr = xFikename
rtn = SendMessage(hChild, WM_SETTEXT, 0, xFikename) ' 文字列を送信
'保存(&S)を押す
hChild = FindWindowEx(hNamae, 0&, "Button", "保存(&S)")
rtn = PostMessage(hChild, BM_CLICK, 0, 0&)
''Enterキーを押す
'rtn = PostMessage(hChild, WM_KEYDOWN, VK_RETURN, 0&)
'rtn = PostMessage(hChild, WM_KEYUP, VK_RETURN, 0&)
'メモ帳の終了
'rtn = PostMessage(hMemocho, WM_COMMAND, &H7, 0&) 'ファイル - 終了
rtn = PostMessage(hMemocho, WM_CLOSE, 0, 0&) 'アプリケーションを終了
End Sub
VBAでWindowsアプリ「メモ帳」を操作してみた・UI Automation
この動画のマクロはWindows11/Office2013で作成してます。
メモ帳のidとかはWindows11とそれ以前のWindowsとでは異なってる可能性がありますので、
Windows11以外で動かす場合はInspect.exeでidを確認しコード修正をする必要があります。
Option Explicit
' 32ビット版Excelの場合はPtrSafeは不要ですので、削除してみてください。
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "User32.dll" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageID As Long, ByVal dwMilliseconds As Long) As Long
Sub Memo()
Dim str_Title, i, fso, CurrentDirectory, xFikename
Dim hWnd As Long
Dim uiAuto As CUIAutomation
Dim iCnd As IUIAutomationCondition
Dim iValuePattern As IUIAutomationValuePattern
'---------------------------------------------------------------------------
'エクセルファイルのあるパス名を取得
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = ActiveWorkbook.Path
'---------------------------------------------------------------------------
' メモ帳の起動
Call Shell("notepad.exe", vbNormalFocus)
'1秒停止
Call Sleep(1000)
'タイトルでアプリを見つける
'hWnd = FindWindowA(vbNullString, "タイトルなし - メモ帳")
'クラス名で探す
hWnd = FindWindowEx(0, 0, "Notepad", vbNullString)
If hWnd = 0 Then
Call MessageBoxTimeoutA(0&, "メモ帳がみつかりません", "hWndエラー", vbMsgBoxSetForeground, 0&, 10000)
Exit Sub
End If
'メモ帳の」Windowのエレメントを探す
Dim elmMemocho As IUIAutomationElement
Set uiAuto = New CUIAutomation
Set elmMemocho = uiAuto.ElementFromHandle(ByVal hWnd)
If elmMemocho Is Nothing Then
i = MessageBoxTimeoutA(0&, "TimelineView" & Chr(13) & "がみつかりません", "FindFirstエラー", vbMsgBoxSetForeground, 0&, 10000)
Exit Sub
End If
'---------------------------------------------------------------------------
'メモ帳に文字列を書く
Dim elmMemocho_edit As IUIAutomationElement
Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "RichEditD2DPT")
Set elmMemocho_edit = elmMemocho.FindFirst(TreeScope_Subtree, iCnd)
Set iValuePattern = elmMemocho_edit.GetCurrentPattern(UIA_ValuePatternId)
' B1,B2セルの内容をメモ帳に書く
iValuePattern.SetValue Range("B1").Value & Chr(13) & Range("B2").Value
' メモ帳の編集内容を見るにはCurrentValue
'Debug.Print iValuePattern.CurrentValue
'---------------------------------------------------------------------------
'名前を付けて保存する
'
'「ファイル」のメニューのエレメントを探す
Dim elmMemocho_m0 As IUIAutomationElement
Dim elmMemocho_m1 As IUIAutomationElement
Dim elmMemocho_m2 As IUIAutomationElement
Dim elmMemocho_m3 As IUIAutomationElement
Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "Windows.UI.Input.InputSite.WindowClass")
Set elmMemocho_m0 = elmMemocho.FindFirst(TreeScope_Subtree, iCnd)
Set iCnd = uiAuto.CreatePropertyCondition(UIA_AutomationIdPropertyId, "MenuBar")
Set elmMemocho_m1 = elmMemocho_m0.FindFirst(TreeScope_Subtree, iCnd)
Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "ファイル")
Set elmMemocho_m2 = elmMemocho_m1.FindFirst(TreeScope_Subtree, iCnd)
'「ファイル」のメニューを押す
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = elmMemocho_m2.GetCurrentPattern(UIA_InvokePatternId)
elmMemocho_m2.SetFocus
InvokePattern.Invoke
'「ファイル」のメニュー配下の「名前を付けて保存」のエレメントを探す
Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "名前を付けて保存")
Do
Set elmMemocho_m3 = elmMemocho.FindFirst(TreeScope_Subtree, iCnd)
DoEvents
Loop While elmMemocho_m3 Is Nothing
'「名前を付けて保存」のメニューを押す
elmMemocho_m3.SetFocus
Set InvokePattern = elmMemocho_m3.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
'---------------------------------------------------------------------------
' 「名前を付けて保存」Windowの処理
' このエクセルファイルと同じフォルダーに"abc.txt"という名前で保存する
'
'保存しようとするファイルが存在してると、上書きを聞いてくるので
'予めファイルがあったら削除しておく。
xFikename = fso.BuildPath(CurrentDirectory, "abc.txt")
If fso.FileExists(xFikename) Then
fso.DeleteFile xFikename, True
End If
'「名前を付けて保存」Windowのエレメントを探す
Dim elmMemocho_s0 As IUIAutomationElement
Dim elmMemocho_s1 As IUIAutomationElement
Dim elmMemocho_s2 As IUIAutomationElement
Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "名前を付けて保存")
Do
Set elmMemocho_s0 = elmMemocho.FindFirst(TreeScope_Subtree, iCnd)
DoEvents
Loop While elmMemocho_s0 Is Nothing
Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "DUIViewWndClassName")
Set elmMemocho_s1 = elmMemocho_s0.FindFirst(TreeScope_Subtree, iCnd)
Set iCnd = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "AppControlHost")
Set elmMemocho_s2 = elmMemocho_s1.FindFirst(TreeScope_Subtree, iCnd)
Set iValuePattern = elmMemocho_s2.GetCurrentPattern(UIA_ValuePatternId)
'ファイル名の送信
iValuePattern.SetValue xFikename
'保存ボタンを押す
Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "保存(S)")
Set elmMemocho_s1 = elmMemocho_s0.FindFirst(TreeScope_Subtree, iCnd)
elmMemocho_s1.SetFocus
Set InvokePattern = elmMemocho_s1.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
'---------------------------------------------------------------------------
'メモ帳の終了
'「ファイル」のメニューを押す
Set InvokePattern = elmMemocho_m2.GetCurrentPattern(UIA_InvokePatternId)
elmMemocho_m2.SetFocus
InvokePattern.Invoke
'「ファイル」のメニュー配下の「名前を付けて保存」のエレメントを探す
Set iCnd = uiAuto.CreatePropertyCondition(UIA_NamePropertyId, "終了")
Do
Set elmMemocho_m3 = elmMemocho.FindFirst(TreeScope_Subtree, iCnd)
DoEvents
Loop While elmMemocho_m3 Is Nothing
'「終了」のメニューを押す
elmMemocho_m3.SetFocus
Set InvokePattern = elmMemocho_m3.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
End Sub
#If Win64 Then
' Excel が64ビット版の場合の関数定義です。
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#Else
' Excel が32ビット版の場合の関数定義です。
Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#End If
Sub Macro()
'MsgBox "おはよう"
MessageBoxTimeoutA 0&, "おはよう", "2秒で閉じるメッセージ", 0, 0&, 2 * 1000
'MsgBox "こんんちは", 1
MessageBoxTimeoutA 0&, "こんんちは", "2秒で閉じるメッセージ", 1, 0&, 2 * 1000
'rtn = MsgBox("こんばんわ", 67, "タイトルも変えられますよ")
rtn = MessageBoxTimeoutA(0&, "こんばんわ", "2秒で閉じるメッセージ", 3, 0&, 2 * 1000)
MessageBoxTimeoutA 0&, "ゆっくりしていってね!!!", "ゆっくり閉じるメッセージ", 0, 0&, 60 * 1000
For i = 0 To 5
MessageBoxTimeoutA 0&, "type=" & i, "1秒で閉じるメッセージ", i, 0&, 1 * 1000
Next
For i = 0 To 5
MessageBoxTimeoutA 0&, "重大なメッセージ" & Chr(13) & "type=" & i & " + 16", "1秒で閉じるメッセージ", i + 16, 0&, 1 * 1000
Next
For i = 0 To 5
MessageBoxTimeoutA 0&, "警告クエリ" & vbCrLf & "type=" & i & " + 32", "1秒で閉じるメッセージ", i + 32, 0&, 1 * 1000
Next
For i = 0 To 5
MessageBoxTimeoutA 0&, "警告メッセージ" & vbCrLf & "type=" & i & " + 48", "1秒で閉じるメッセージ", i + 48, 0&, 1 * 1000
Next
For i = 0 To 5
MessageBoxTimeoutA 0&, "情報メッセージ" & vbCrLf & "type=" & i & " + 64", "1秒で閉じるメッセージ", i + 64, 0&, 1 * 1000
Next
MessageBoxTimeoutA 0&, _
" ____∧∧ / ̄ ̄ ̄ ̄ ̄ ̄ ̄ ̄" & vbCrLf & _
" ~' ____(,,゚Д゚)< 次に逝ってよし!" & vbCrLf & _
" UU U U \________" _
, "10秒で閉じるメッセージ", 0 + 64, 0&, 10 * 1000
End Sub
VBScript
<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
Set objShell = WScript.CreateObject("WScript.Shell")
objShell.Popup "おはよう",5, "5秒で閉じるメッセージ",0
objShell.Popup "こんんちは",5, "5秒で閉じるメッセージ",1
For i = 0 To 5
objShell.Popup "type=" & i, 1 , "1秒で閉じるメッセージ", i
Next
For i = 0 To 5
objShell.Popup "重大なメッセージ" & Chr(13) & "type=" & i & " + 16",1, "1秒で閉じるメッセージ",i+16
Next
For i = 0 To 5
objShell.Popup "警告クエリ" & Chr(13) & "type=" & i & " + 32",1, "1秒で閉じるメッセージ",i+32
Next
</script>
</job>
VBAでEdge操作を自動化してみた。
.NET Frameworkがインストールされていないと、実行時にオートメーションエラーが発生します。 オートメーションエラーが発生する場合、.NET Framework 3.5をインストールしてください。動画ではEdgeでの起動オプションが設定出来ないと言ってますが、 Edgeでの起動オプション変更方法が判明しました!
'ブラウザを起動
Dim driver As New Selenium.WebDriver
Set driver = CreateObject("Selenium.webDriver")
'Edgeに起動オプションをjsonで渡す
driver.SetCapability "ms:edgeOptions", "{""args"": [""user-data-dir=" & Replace(fso.BuildPath(CurrentDirectory, "edge_vba1"), "\", "\\") & """" & _
",""disable-blink-features=AutomationControlled""" & _
"] }"
driver.Start "edge"
Option Explicit
#If Win64 Then
' Excel が64ビット版の場合の関数定義です。
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#Else
' Excel が32ビット版の場合の関数定義です。
Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageID As Long, _
ByVal dwMilliseconds As Long) As Long
#End If
Sub Macro()
Dim driver, o_elem, fso, file, str_user, str_pass, CurrentDirectory, myBy, bFlag, num_trend_word, i
'パスワードファイルを読む
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = ActiveWorkbook.Path
Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "pass1.txt"), 1)
str_user = file.ReadLine
str_pass = file.ReadLine
file.Close
Set file = Nothing
'Edgeブラウザを起動
Set driver = CreateObject("Selenium.webDriver")
'EdgeだとAddArgumentが動かない。pythonだと動く
driver.AddArgument "user-data-dir=" & fso.BuildPath(CurrentDirectory, "edge_vba")
driver.Start "Edge"
driver.Get "https://websearch.rakuten.co.jp/"
Set o_elem = driver.FindElementsByPartialLinkText("ログイン")
If o_elem.Count > 0 Then
'ログインしていない リンクをクリック
driver.ExecuteScript "arguments[0].click();", o_elem.Item(1)
'パスワード入力エリアが出現するまで待つ
Call WaitElementbyCss(driver, "#loginInner_p")
driver.FindElementByCss("#loginInner_p").SendKeys str_pass
driver.FindElementByCss("#loginInner_u").SendKeys str_user
driver.FindElementByCss("input.loginButton").Click
End If
'トレンドワードを配列に格納
Call WaitElementbyCss(driver, "div.TrendWord-module__trendWordWrap__19AOz input")
Set o_elem = driver.FindElementsByCss("div.TrendWord-module__trendWordWrap__19AOz input")
num_trend_word = o_elem.Count
Dim str_trend_word(5)
For i = 1 To num_trend_word
str_trend_word(i - 1) = o_elem.Item(i).Value
Next
'配列に格納されたトレンドワードを検索する
For i = 0 To num_trend_word
'検索窓にトレンドワードを入力する
Set o_elem = driver.FindElementsByCss("#search-input,#srchformtxt_qt")
o_elem.Item(1).Clear
o_elem.Item(1).SendKeys str_trend_word(i)
'検索ボタンを押す
Set o_elem = driver.FindElementsByCss("#search-submit,#searchBtn")
o_elem.Item(1).Click
MessageBoxTimeoutA 0&, "1秒後、自動に閉じます", "時間待ちです", 1, 65536, 1 * 1000
Next
'IEを閉じる
driver.Quit
Set driver = Nothing
End Sub
Sub WaitElementbyCss(driver, css)
Dim bFlag, myBy
bFlag = False
Set myBy = New By
Do
bFlag = driver.IsElementPresent(myBy.css(css))
driver.Wait 1000
Loop Until bFlag = True
End Sub
<!-- :
@%windir%\System32\cscript.exe //nologo "%~f0?.wsf"
@exit /b %errorlevel%
-->
<job>
<script language="VBScript">
Dim driver, o_elem, fso, file, str_user, str_pass, CurrentDirectory, myBy, bFlag, num_trend_word, i
'パスワードファイルを読む
Set fso = CreateObject("Scripting.FileSystemObject")
CurrentDirectory = fso.getParentFolderName(WScript.ScriptFullName)
Set file = fso.OpenTextFile(fso.BuildPath(CurrentDirectory, "pass1.txt"), 1)
str_user = file.ReadLine
str_pass = file.ReadLine
file.Close
Set file = Nothing
'Edgeブラウザを起動
Set driver = WScript.CreateObject("Selenium.webDriver")
Set myBy = WScript.CreateObject("selenium.By")
'EdgeだとAddArgumentが動かない。pythonだと動く
driver.AddArgument "user-data-dir=" & fso.BuildPath(CurrentDirectory, "edge_vba")
driver.Start "Edge"
driver.Get "https://websearch.rakuten.co.jp/"
Set o_elem = driver.FindElementsByPartialLinkText("ログイン")
If o_elem.Count > 0 Then
'ログインしていない リンクをクリック
driver.ExecuteScript "arguments[0].click();", o_elem.Item(1)
'パスワード入力エリアが出現するまで待つ
Call WaitElementbyCss(driver, "#loginInner_p")
driver.FindElementByCss("#loginInner_p").SendKeys str_pass
driver.FindElementByCss("#loginInner_u").SendKeys str_user
driver.FindElementByCss("input.loginButton").Click
End If
'トレンドワードを配列に格納
Call WaitElementbyCss(driver, "div.TrendWord-module__trendWordWrap__19AOz input")
Set o_elem = driver.FindElementsByCss("div.TrendWord-module__trendWordWrap__19AOz input")
num_trend_word = o_elem.Count
Dim str_trend_word(5)
For i = 1 To num_trend_word
str_trend_word(i - 1) = o_elem.Item(i).Value
Next
'配列に格納されたトレンドワードを検索する
For i = 0 To num_trend_word
'検索窓にトレンドワードを入力する
Set o_elem = driver.FindElementsByCss("#search-input,#srchformtxt_qt")
o_elem.Item(1).Clear
o_elem.Item(1).SendKeys str_trend_word(i)
'検索ボタンを押す
Set o_elem = driver.FindElementsByCss("#search-submit,#searchBtn")
o_elem.Item(1).Click
WScript.CreateObject("WScript.Shell").popup "1秒後、自動に閉じます",1, "時間待ちです", 1
Next
'IEを閉じる
driver.Quit
Set driver = Nothing
Sub WaitElementbyCss(driver, css)
Dim bFlag, myBy
bFlag = False
Set myBy = WScript.CreateObject("Selenium.By")
Do
bFlag = driver.IsElementPresent(myBy.css(css))
driver.Wait 1000
Loop Until bFlag = True
End Sub
</script>
</job>