この掲示板は AutoCADマクロ屋本舗 の掲示板です。

【 注意 】最初に必ず ↓↓ 下記内容 ↓↓ を参照ください。
① マクロが分からない方は、まず 【 マクロ講座 】 を参照ください。
② 質問の前に 【 マクロ使用前の注意事項 】 をお読みください。
③ 質問する時は、新規投稿フォーム下の【 新規投稿時のお願い 】を必ずお読みください。

AutoCadマクロ分析用Wordマクロ(レベル低いです)
WordのVBAでAutoCadマクロ解析用のマクロを作りました。
VBAの技量が低い上に、WordVBAを全くやったことが無いので、著しく幼稚な内容となってしまい
VBAの参考にならないばかりが、指摘点ばかり目につくと思います。
しかし、個人的に使うには、AutoCadマクロ解析のとっかかりにはなるかな?と思い、恥ずかしながら
投稿させて頂きました。
AutoCadマクロの文法がよく分かっていないので不適切な結果となっている部分もあるかと
思いますが、ご指摘頂ければ、可能な限り(時間がかかります)で修正したいと思います。
一応、マクロ集の、152.円 円周記入~110.日付変更マクロまでで試してみましたが、
エラーは出ませんでした。

使い方:Wordの標準モジュールに登録して、「AutoCadマクロ分析」を実行するだけです。
文章全体を対象としているので、一つの文章に一つのAutoCadマクロを書き込んで実行
してください。

Option Explicit
Type myPropety
Color As WdColor
BakColor As WdColor
Bold As Boolean
Italic As Boolean
Patterm As Variant 'Array関数のためVariant型
Rng As Variant 'Jag配列として扱うためVariant型
End Type
Const PartitionEnvVarStr As String = "to"
Const ListTitleTo As String = "----- 分割変数Set一覧 -----"
Const ListTitleEnv As String = "----- 環境変数一覧 -----"
Const ListTitleVar As String = "----- システム変数一覧 -----"
Const PatternTo1 As String = ";to;"
Const PatternTo2 As String = ";to;$M="""
Const PatternTo3 As String = ";to;$M="""""""
Const PatternTo4 As String = ";to;$M="""""""""""""""
Const PatternTo5 As String = ";to;$M="""""""""""""""""""""""""""""""
'---------------------------------------------------------------------------------------------------------------
Sub AutoCadマクロ分析()
Dim EnvVarGetDistribution As myPropety
Dim EnvVarSetDistribution As myPropety
Dim ToIf As myPropety
Dim ToNth As myPropety
Dim SysVarGetDistribution As myPropety
Dim Diesel As myPropety
Dim DieselIn As myPropety
Dim DblQuotation As myPropety
Dim PartitionTo As myPropety
Dim UserInput As myPropety
Dim JagAryNth As myPropety
Dim JagAryIf As myPropety
Dim JagAryToIf As myPropety
Dim JagAryToNth As myPropety
Dim ListEnvVar() As String
Dim ListSysVar() As String
Dim ListPartitionTo() As String
'********** プロパティの設定 ***********************************************************************************
'環境変数(Get)
EnvVarGetDistribution.Patterm = Array("$(getenv,")
EnvVarGetDistribution.Color = wdColorAutomatic
EnvVarGetDistribution.BakColor = wdColorTan
EnvVarGetDistribution.Bold = True
EnvVarGetDistribution.Italic = False
'環境変数(Set)
EnvVarSetDistribution.Patterm = Array("")
EnvVarSetDistribution.Color = wdColorAutomatic
EnvVarSetDistribution.BakColor = wdColorRose
EnvVarSetDistribution.Bold = True
EnvVarSetDistribution.Italic = False
'システム変数(Get)
SysVarGetDistribution.Patterm = Array("$(getvar,")
SysVarGetDistribution.Color = wdColorAutomatic
SysVarGetDistribution.BakColor = wdColorLightTurquoise
SysVarGetDistribution.Bold = False
SysVarGetDistribution.Italic = True
'DISEL式
Diesel.Patterm = Array("$(+", "$(-", "$(*", "$(/", "$(=", "$(<", "$(>", "$(!=", "$(<=", "$(>=", _
"$(and", "$(angros", "$(edtime", "$(eq", "$(eval", "$(fix", "$(index", _
"$(or", "$(rtos", "$(strlen", "$(substr", "$(upper", "$(xor")
Diesel.Color = wdColorBlue
Diesel.BakColor = wdColorAutomatic
Diesel.Bold = True
Diesel.Italic = False
'$M=
DieselIn.Patterm = Array("$M=")
DieselIn.Color = wdColorAutomatic
DieselIn.BakColor = wdColorGray15
DieselIn.Bold = False
DieselIn.Italic = False
'「"」
DblQuotation.Patterm = Array("""")
DblQuotation.Color = wdColorAutomatic
DblQuotation.BakColor = wdColorAutomatic
DblQuotation.Bold = False
DblQuotation.Italic = False
'マクロ分割用「to;数字」
PartitionTo.Patterm = Array(";to;")
PartitionTo.Color = wdColorAutomatic
PartitionTo.BakColor = wdColorLightOrange
PartitionTo.Bold = True
PartitionTo.Italic = False
'「\」
UserInput.Patterm = Array("\")
UserInput.Color = wdColorAutomatic
UserInput.BakColor = wdColorLightBlue
UserInput.Bold = False
UserInput.Italic = False
'アンダーライン補正用(「;to;$M="""$(if,」の範囲までアンダーラインを拡大)
ToIf.Patterm = Array(PatternTo2 & "$(if,", PatternTo3 & "$(if,", _
PatternTo4 & "$(if,", PatternTo5 & "$(if,")
'Setenv;to;数字をif文で制御している場合
JagAryToIf.Patterm = Array(PatternTo1 & "$(if,", PatternTo2 & "$(if,", PatternTo3 & "$(if,", _
PatternTo4 & "$(if,", PatternTo5 & "$(if,")
JagAryToIf.Color = wdColorAutomatic
JagAryToIf.BakColor = wdColorLightOrange
JagAryToIf.Bold = True
JagAryToIf.Italic = False
'Setenv;to;数字をif文で制御している場合
JagAryToNth.Patterm = Array(PatternTo1 & "$(nth,", PatternTo2 & "$(nth,", PatternTo3 & "$(nth,", _
PatternTo4 & "$(nth,", PatternTo5 & "$(nth,")
JagAryToNth.Color = wdColorAutomatic
JagAryToNth.BakColor = wdColorLightOrange
JagAryToNth.Bold = True
JagAryToNth.Italic = False
'$(nthジャグ配列
JagAryNth.Patterm = Array("$(nth,")
JagAryNth.Color = wdColorAutomatic
JagAryNth.BakColor = wdColorLightYellow
JagAryNth.Bold = False
JagAryNth.Italic = False
'$(if,ジャグ配列
JagAryIf.Patterm = Array("$(if,")
JagAryIf.Color = wdColorAutomatic
JagAryIf.BakColor = wdColorLightGreen
JagAryIf.Bold = False
JagAryIf.Italic = False
'********** 開始 ***********************************************************************************************
ThisDocument.Activate 'マクロの書かれているブックをアクティブにする
Application.ScreenUpdating = False
'********** マクロ解析結果のリセット ***************************************************************************
SentencesEndDelete ListTitleTo '"----- 分割変数Set一覧 -----"以降の文字列削除
RubyAllDelete 'ルビ削除
ActiveDocument.Content.Font.Shading.BackgroundPatternColor = wdColorAutomatic '背景削除
ActiveDocument.Content.Text = Replace(ActiveDocument.Content.Text, vbCr, "") '改行削除
'*********** マクロが動作したことを認識させるためにリセット状態を表示させる ************************************
Selection.HomeKey Unit:=wdStory '表示位置初期化
Application.ScreenUpdating = True
Application.ScreenRefresh
Application.ScreenUpdating = False
'********** Rangeの取得 ****************************************************************************************
EnvVarGetDistribution.Rng = RangeArray(EnvVarGetDistribution.Patterm)
SysVarGetDistribution.Rng = RangeArray(SysVarGetDistribution.Patterm)
ToIf.Rng = RangeArray(ToIf.Patterm)
Diesel.Rng = RangeArray(Diesel.Patterm)
DieselIn.Rng = RangeArray(DieselIn.Patterm)
DblQuotation.Rng = RangeArray(DblQuotation.Patterm)
PartitionTo.Rng = RangeArray(PartitionTo.Patterm)
UserInput.Rng = RangeArray(UserInput.Patterm)
JagAryToIf.Rng = RangeArray(JagAryToIf.Patterm)
JagAryToNth.Rng = RangeArray(JagAryToNth.Patterm)
'********** 変数名の取得 ***************************************************************************************
EnvVarGetDistribution = VariableGet(EnvVarGetDistribution)
SysVarGetDistribution = VariableGet(SysVarGetDistribution)
PartitionTo = ExtensionNumber(PartitionTo)
'********** 遅延制御 *******************************************************************************************
DblQuotation.Rng = DblQuotationUnionRng(DblQuotation.Rng)
UnderlineAdd DblQuotation.Rng 'アンダーバーの描画
UnderlineToIFAdd ToIf.Rng '「;to;$M="""$(if,」の範囲までアンダーラインを拡大
'********** JaggedRangeの取得 *********************************************************************************
JagAryNth = RangeJagged(JagAryNth)
JagAryIf = RangeJagged(JagAryIf)
JagAryToIf = RangeJagged(JagAryToIf)
JagAryToNth = RangeJagged(JagAryToNth)
PaintJagRng JagAryNth
PaintJagRng JagAryIf
'********** GetDistributionを踏まえて変数一覧の取得 ************************************************************
'↓プログラムの検証のために","をつけて環境変数をGetしているので仮に付けている
'131:属性値変更にある$(getenv,$(getenv,att))で、$(getenv,att)自体が変数扱いと
'なっている場合に,だけヒットさせるため(このような表現が必要かどうかは不明)
ListEnvVar = BubbleSort(OverlapDelet(ListStrGet(EnvVarGetDistribution.Rng, "," & PartitionEnvVarStr)))
ListSysVar = BubbleSort(OverlapDelet(ListStrGet(SysVarGetDistribution.Rng, "")))
ListPartitionTo = BubbleSort(OverlapDelet(ListStrGet(PartitionTo.Rng, "")))
'********** 環境変数(Set)処理 **********************************************************************************
EnvVarSetDistribution.Patterm = SemicolonInsert(ListEnvVar)
'上記の理由で意図的に付加している,をsetの検索のために除去する
EnvVarSetDistribution.Rng = RangeArray(EnvVarSetDistribution.Patterm)
'********** Paint **********************************************************************************************
'↓プログラムの検証のために","をつけて環境変数をGetしているので仮に付けている
Paint EnvVarGetDistribution, "," & PartitionEnvVarStr
Paint SysVarGetDistribution
Paint EnvVarSetDistribution
Paint Diesel
Paint DieselIn
Paint PartitionTo
Paint UserInput
PaintTo JagAryToIf
PaintTo JagAryToNth
'********** Setenv;to;数字をif文で制御している場合のペイント処理 **********************************************
'環境変数,SystemVariableDistributionの表示
ListPrint ListPartitionTo, ListTitleTo, 9 'マクロ分割制御用Setenv一覧
ListPrint ListEnvVar, ListTitleEnv, 4 '環境変数一覧
ListPrint ListSysVar, ListTitleVar, 4 'システム変数一覧
'********** 改行 ***********************************************************************************************
InsertVbCR JagAryNth.Rng, "$(getenv," & PartitionEnvVarStr & ")"
'********** ルビ関連処理 ***************************************************************************************
'注意:ルビを設定すると.Textが、Fieldオブジェクトに置き換えられRangeオブジェクトとしての情報が破壊される
RubyParameterNumber JagAryNth.Rng 'ルビ設定により以後、「,」のRangeが使えない
RubyParameterNumber JagAryIf.Rng 'ルビ設定により以後、「,」のRangeが使えない
RubyPartitionNthNumber JagAryNth.Rng, "$(getenv," & PartitionEnvVarStr & ")" '以後、「nth」のRangeが使えない
RubyDblQuotationNumber DblQuotation.Rng
'********** 後処理 *********************************************************************************************
With ActiveDocument.Content.ParagraphFormat
.WordWrap = False '英単語の途中で改行無し
.Alignment = wdAlignParagraphLeft '左寄せ
End With
Selection.HomeKey Unit:=wdStory '表示位置初期化
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Function RangeJagged(ByRef myPropety As myPropety) As myPropety
'********** Variant型の配列にVariant型の配列を入れることによりジャグ配列として返す **********
Dim ArrayParent() As Variant ' 親配列(戻り値)Variant型でなければならない
Dim ArrayCnt As Integer: ArrayCnt = 0
Dim FindRng As Range
Dim LopMatchPattern As Variant
For Each LopMatchPattern In myPropety.Patterm
Set FindRng = ActiveDocument.Range(0, 0)
With FindRng.Find
.Text = LopMatchPattern
Do While .Execute
ReDim Preserve ArrayParent(ArrayCnt)
FindRng.Select 'FindRngへの参照回避
ArrayParent(ArrayCnt) = RangeJaggedChild(Selection.Range)
ArrayCnt = ArrayCnt + 1
Loop
End With
Next
myPropety.Rng = ArrayParent
RangeJagged = myPropety
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function RangeJaggedChild(ParentRng As Range) As Variant 'Variant型でなければならない
'********** 親Rangeに続く「,」「)」をネスティングを考慮して抽出しVariant型の配列に入れて返す **********
Dim NestingCnt As Integer: NestingCnt = 1
Dim ArrayChild() As Variant
ReDim Preserve ArrayChild(0): Set ArrayChild(0) = ParentRng
Dim UnderLineChk As Boolean
If ArrayChild(0).Font.Underline = wdUnderlineSingle Then
UnderLineChk = True
Else
UnderLineChk = False
End If
Dim ArrayCnt As Integer: ArrayCnt = 1
Dim FindRng As Range
ActiveDocument.Range(ParentRng.End, ParentRng.End).Select
Set FindRng = Selection.Range
With FindRng.Find
.Text = "[(,)]"
.MatchWholeWord = False
.MatchWildcards = True
Do While .Execute
If FindRng.Text = "(" Then
NestingCnt = NestingCnt + 1
ElseIf FindRng.Text = ")" Then
NestingCnt = NestingCnt - 1
If NestingCnt = 0 Then
ReDim Preserve ArrayChild(ArrayCnt)
FindRng.Select 'FindRngへの参照回避
Set ArrayChild(ArrayCnt) = Selection.Range
Exit Do
End If
Else '「,」がヒット
If NestingCnt = 1 Then
'アンダーラインが引かれていると配列に入れない
If (FindRng.Font.Underline <> wdUnderlineSingle) Or (UnderLineChk) Then
ReDim Preserve ArrayChild(ArrayCnt)
FindRng.Select 'FindRngへの参照回避
Set ArrayChild(ArrayCnt) = Selection.Range
ArrayCnt = ArrayCnt + 1
End If
End If
End If
Loop
End With
RangeJaggedChild = ArrayChild
End Function
'---------------------------------------------------------------------------------------------------------------
Private Sub UnderlineAdd(ByRef myRng As Variant) 'Jagged配列対応のためVariant
'********* アンダーラインを付加する **********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Dim SrartRng As Range
Dim SrartRngFlag As Boolean: SrartRngFlag = True
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myRng
If SrartRngFlag Then
If LopRng.Text <> """""" Then
Set SrartRng = LopRng
SrartRngFlag = False
End If
Else
If LopRng.Text <> """""" Then
SrartRngFlag = True
ActiveDocument.Range(SrartRng.Start, LopRng.End).Font.Underline = wdUnderlineSingle '一重下線
End If
End If
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub UnderlineToIFAdd(ByRef myRng As Variant) 'Jagged配列対応のためVariant
'********* アンダーラインを付加する **********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myRng
LopRng.Font.Underline = wdUnderlineSingle
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub ListPrint(ByRef myString() As String, ByVal myTitle As String, ByVal DistributionNumber As Integer)
'********** 文章の末に文字列配列を羅列する ***********
Selection.EndKey Unit:=wdStory '文末にカーソル移動
Selection.TypeText vbCr & myTitle
Dim TabCnt As Integer: TabCnt = 0
Dim myLop As Variant '配列LoopのためVariant型
If ArrayNonUsedChk(myString) Then
Selection.TypeText vbCr & "<無し>"
Else
For Each myLop In myString
If TabCnt = 0 Then
Selection.TypeText vbCr
TabSet (DistributionNumber)
Selection.TypeText Replace(myLop, ",", "") & ":"
TabCnt = TabCnt + 1
Else
Selection.TypeText vbTab & Replace(myLop, ",", "") & ":"
TabCnt = TabCnt + 1
If TabCnt = DistributionNumber Then TabCnt = 0
End If
Next
End If
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub TabSet(ByVal DistributionNumber As Integer)
'********** 選択されている行のタブをリセット後、引数の数に分割して設定 **********
Selection.Range.Paragraphs.TabStops.ClearAll
Dim myWidth As Single
With ActiveDocument.PageSetup
myWidth = .PageWidth - .LeftMargin - .RightMargin
End With
Dim i As Integer
For i = 1 To DistributionNumber - 1
Selection.ParagraphFormat.TabStops.Add Position:=myWidth * i / DistributionNumber _
, Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Function SemicolonInsert(ByRef mystr() As String) As String()
'********** SetEnv用のPattermを構築するために前後に;を挿入する **********
If ArrayNonUsedChk(mystr) Then '配列が空の場合エスケープ
SemicolonInsert = mystr 'そのまま返す
Exit Function
End If
Dim TmpStr() As String
Dim ChkStr As String
Dim ArrayCnt As Integer: ArrayCnt = 0
Dim LopStr As Variant '配列LoopのためVariant型
For Each LopStr In mystr
'$(getenv,$(getenv,att))のようにgetenv,の次に$がくると「;;」を環境変数のSetと判断してしまうのでスキップさせる
ChkStr = ";" & Replace(LopStr, ",", "") & ";"
If ChkStr <> ";;" Then
ReDim Preserve TmpStr(ArrayCnt)
TmpStr(ArrayCnt) = ChkStr
ArrayCnt = ArrayCnt + 1
End If
Next
SemicolonInsert = TmpStr
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function ExtensionNumber(ByRef myPropety As myPropety) As myPropety
'********** ;to;の範囲を数字を含めたものに拡張する **********
If ArrayNonUsedChk(myPropety.Rng) Then '配列が空の場合エスケープ
ExtensionNumber = myPropety 'そのまま返す
Exit Function
End If
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myPropety.Rng
LopRng.MoveEndWhile cset:="0123456789"
LopRng.Select
Next
ExtensionNumber = myPropety
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function ListStrGet(ByRef myRng As Variant, ByVal RemoveStr As String) As String() 'Jagged対応Variant
'********** Rngの値から除外文字に該当するRngを除いた文字列配列を返す **********
Dim ListStr() As String
If ArrayNonUsedChk(myRng) Then '配列が空の場合エスケープ
ListStrGet = BubbleSort(ListStr) '空の配列を返す
Exit Function
End If
Dim ArrayCnt As Integer: ArrayCnt = 0
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myRng
LopRng.MoveStartWhile cset:=Chr(21), Count:=wdForward 'ルビ設定時のChr(21)勝手な挿入対策
If RemoveStr <> LopRng.Text Then
ReDim Preserve ListStr(ArrayCnt)
ListStr(ArrayCnt) = LopRng.Text
ArrayCnt = ArrayCnt + 1
End If
Next
ListStrGet = ListStr
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function OverlapDelet(ByRef ListStr() As String) As String()
'********** 重複する配列を削除 **********
Dim TmpStr() As String
If ArrayNonUsedChk(ListStr) Then '配列が空の場合エスケープ
OverlapDelet = TmpStr
Exit Function
End If
'連想配列Dictionaryに変換して重複配列を一気に削除
Dim db As Variant
Dim c As Variant
Set db = CreateObject("Scripting.Dictionary")
For Each c In ListStr
db(c) = 1 'セル値をキーにして重複分を吸収
Next c
'連想配列Dictionary型をStringの配列に戻す
Dim LopStr As Variant '配列LoopのためVariant型
Dim LopCnt As Integer: LopCnt = 0
For Each LopStr In db
ReDim Preserve TmpStr(LopCnt)
TmpStr(LopCnt) = LopStr
LopCnt = LopCnt + 1
Next
OverlapDelet = TmpStr
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function BubbleSort(ByRef argAry() As String) As String() 'Jagged配列対応のためVariant
'********** 一次配列をソートした結果を返す **********
If ArrayNonUsedChk(argAry) Then '配列が空の場合エスケープ
BubbleSort = argAry 'そのまま返す
Exit Function
End If
Dim vSwap As Variant
Dim i, j As Integer
For i = LBound(argAry) To UBound(argAry)
For j = UBound(argAry) To i Step -1
If argAry(i) > argAry(j) Then
vSwap = argAry(i)
argAry(i) = argAry(j)
argAry(j) = vSwap
End If
Next j
Next i
BubbleSort = argAry
End Function
'---------------------------------------------------------------------------------------------------------------
Private Sub RubyPartitionNthNumber(ByRef myRng As Variant, ByVal ChkKW As String) 'Jagged配列対応のためVariant
'********** マクロを分割するnth文の分割番号をルビ表示 **********
'******$(nth,$(getenv,to)に続くルビの数を数えているので厳密には,を数えていない(改善要)*********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Dim arr As Variant
Dim PartitionNumber As Long
Dim tmpRng As Range
Dim CommaCnt As Integer
Dim i, j As Integer
For i = 0 To UBound(myRng, 1)
arr = myRng(i)
For j = 0 To UBound(arr, 1)
arr(j).Select
Set tmpRng = Selection.Range
tmpRng.MoveEnd wdCharacter, Len(ChkKW)
If tmpRng.Text = arr(j) & ChkKW Then
'続く「,」を数えるが、MoveEndWhileではルビがあるとFieldオブジェクト分を
'含んでしまい正確に計算できない。
Do While tmpRng.Next.Text = Chr(21)
Set tmpRng = tmpRng.Next
tmpRng.Select
CommaCnt = CommaCnt + 1
Loop
arr(j).PhoneticGuide Text:=CommaCnt - 1
CommaCnt = 0
End If
Next
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub RubyParameterNumber(myRng As Variant) 'Jagged配列対応のためVariant
'********** Nth,If分のパラメーターナンバーをルビ表示 **********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Dim arr As Variant
Dim i, j As Integer
For i = 0 To UBound(myRng, 1)
arr = myRng(i)
For j = 1 To UBound(arr, 1) - 1
arr(j).MoveStartWhile cset:=Chr(21), Count:=wdForward
arr(j).PhoneticGuide Text:=j - 1
Next
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub RubyDblQuotationNumber(ByRef myRng As Variant) 'Jagged配列対応のためVariant
'********** 評価を遅らせているダブルクォティションの遅延回数をルビ表示 **********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Application.StatusBar = "ダブルクォーティションの数をチェック中"
Dim Kanji As Variant: Kanji = Array("一", "二", "三", "四")
Dim n_thPower As Double
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myRng
LopRng.MoveStartWhile cset:=Chr(21), Count:=wdForward 'ルビ設定時のChr(21)勝手な挿入対策
'ダブルクォティションの数=2^n-1からn乗が整数であるか判断
n_thPower = Log(Len(LopRng.Text) + 1) / Log(2)
If n_thPower = Int(n_thPower) Then
LopRng.PhoneticGuide Text:=Kanji(n_thPower - 1)
ElseIf Len(LopRng.Text) = 2 Then
LopRng.PhoneticGuide Text:="空?"
Else
LopRng.PhoneticGuide Text:="×"
End If
Next
Application.StatusBar = ""
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Function DblQuotationUnionRng(ByRef myRng As Variant) As Variant 'Jagged配列対応のためVariant
'********** 隣接する「"」を一つのRangeにまとめて返す **********
If ArrayNonUsedChk(myRng) Then '配列が空の場合エスケープ
DblQuotationUnionRng = myRng 'そのまま返す
Exit Function
End If
Dim tmpRng() As Range
Dim ArrayCnt As Integer: ArrayCnt = -1
Dim LastEnd As Integer: LastEnd = -1
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myRng
LopRng.MoveStartWhile cset:=Chr(21), Count:=wdForward 'ルビ設定時のChr(21)勝手な挿入対策
If LastEnd = LopRng.Start Then
tmpRng(ArrayCnt).End = LopRng.End
LastEnd = LopRng.End
Else
ArrayCnt = ArrayCnt + 1
ReDim Preserve tmpRng(ArrayCnt)
'参照渡しのmyPropetyとの関係を断ち切るために一度Selectする
LopRng.Select 'LopRngへの参照回避
Set tmpRng(ArrayCnt) = Selection.Range
LastEnd = LopRng.End
End If
Next
DblQuotationUnionRng = tmpRng
End Function

'---------------------------------------------------------------------------------------------------------------
Private Sub InsertVbCR(ByRef myRng As Variant, ByVal ChkKW As String) 'Jagged配列対応のためVariant
'********** .TextにChkKWが続く配列の前に2個vbCRを挿入する(Start位置補正付) **********
If ArrayNonUsedChk(myRng) Then Exit Sub '配列が空の場合エスケープ
Dim arr As Variant
Dim tmpRng As Range
Dim i, j As Integer
For i = 0 To UBound(myRng, 1)
arr = myRng(i)
For j = 0 To UBound(arr, 1)
arr(j).Select
Set tmpRng = Selection.Range
tmpRng.MoveEnd wdCharacter, Len(ChkKW)
If tmpRng.Text = arr(j) & ChkKW Then
arr(j).InsertBefore vbCr & vbCr
arr(j).Start = arr(j).Start + 2
End If
Next
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Function VariableGet(ByRef myPropety As myPropety) As myPropety
'*********** Rng配列に続く変数にRange範囲を変更し、myPropetyとして返す **********
'$(getenv,a$(getenv,b)のようなネスティング対策で、一度$(getenv,でヒットさせて)or$まで拡張する方式とした
If ArrayNonUsedChk(myPropety.Rng) Then '配列が空の場合エスケープ
VariableGet = myPropety 'そのまま返す
Exit Function
End If
Dim MoveStartCount As Integer: MoveStartCount = Len(myPropety.Patterm(0))
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myPropety.Rng
LopRng.MoveEndUntil cset:=";,)$", Count:=wdForward
LopRng.MoveStart Unit:=wdCharacter, Count:=MoveStartCount - 1
Next
VariableGet = myPropety
End Function
'---------------------------------------------------------------------------------------------------------------
Private Sub Paint(ByRef myPropety As myPropety, Optional ByVal RemoveStr As String = "")
'********** myPropetyに従って、文字色、背景、強調、イタリックの処理を行う **********
If ArrayNonUsedChk(myPropety.Rng) Then Exit Sub '配列が空の場合エスケープ
Dim LopRng As Variant '配列LoopのためVariant型
For Each LopRng In myPropety.Rng
If LopRng.Text <> RemoveStr Then
PaintExecution myPropety, LopRng
End If
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub PaintTo(ByRef myPropety As myPropety)
'********** toifの「,」に続く数字1文字のmyPropetyに従って、文字色、背景、強調、イタリックの処理を行う ********
If ArrayNonUsedChk(myPropety.Rng) Then Exit Sub '配列が空の場合エスケープ
Dim arr As Variant
Dim tmpRng As Range
Dim i, j As Integer
For i = 0 To UBound(myPropety.Rng, 1)
arr = myPropety.Rng(i)
For j = 0 To UBound(arr, 1)
If arr(j).Text = "," Then
arr(j).Next.Select
'115:コピー/移動(回転付)にある;$(if,$(eq,$(getenv,p1),$(getvar,lastpoint)),4,$(if,$(getenv,sw),1,6))のように
',4,$と「,」の次に$が来た場合にさらなる条件分岐があるかどうかの判断を付加する必要がある。
PaintExecution myPropety, Selection
End If
Next
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub PaintJagRng(ByRef myPropety As myPropety, Optional ByVal RemoveStr As String = "")
'********** myPropetyに従って、文字色、背景、強調、イタリックの処理を行う **********
'配列が空の場合はエスケープ
If ArrayNonUsedChk(myPropety.Rng) Then Exit Sub '配列が空の場合エスケープ
Dim arr As Variant
Dim i, j As Integer
For i = 0 To UBound(myPropety.Rng, 1)
arr = myPropety.Rng(i)
For j = 0 To UBound(arr, 1)
If arr(j).Text <> RemoveStr Then
PaintExecution myPropety, arr(j)
End If
Next
Next
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Sub PaintExecution(ByRef myPropety As myPropety, ByRef myArray As Variant)
'********** プロパティセット **********
myArray.MoveStartWhile cset:=Chr(21), Count:=wdForward 'ルビ設定時のChr(21)勝手な挿入対策
With myArray
.Shading.BackgroundPatternColor = myPropety.BakColor
With .Font
.Color = myPropety.Color
.Bold = myPropety.Bold
.Italic = myPropety.Italic
End With
End With
End Sub
'---------------------------------------------------------------------------------------------------------------
Private Function RangeArray(ByRef myPatterm As Variant) As Range()
'********** myPropety内のPattermに則たFind結果をRng配列に入れて返す **********
Dim tmpRng() As Range
If ArrayNonUsedChk(myPatterm) Then
RangeArray = tmpRng
Exit Function '配列が空の場合エスケープ
End If

Dim FindRng As Range

Dim ArrayCnt As Integer: ArrayCnt = 0
Dim LopMatchPattern As Variant '配列LoopのためVariant型
For Each LopMatchPattern In myPatterm
Set FindRng = ActiveDocument.Range(0, 0)
With FindRng.Find
.Text = LopMatchPattern
Do While .Execute
ReDim Preserve tmpRng(ArrayCnt)
FindRng.Select 'FindRngへの参照回避
Set tmpRng(ArrayCnt) = Selection.Range
ArrayCnt = ArrayCnt + 1
Loop
End With
Next
RangeArray = tmpRng
End Function
'---------------------------------------------------------------------------------------------------------------
Private Function ArrayNonUsedChk(ByRef myArray As Variant) As Boolean
'********** 配列が使用されているかどうかの判断 **********
'使用されている=True 使用されていない=False
Dim ArrayUseChk As Integer
On Error Resume Next
ArrayUseChk = UBound(myArray)
If Err.Number <> 0 Then
On Error GoTo 0
ArrayNonUsedChk = True
Exit Function
End If
On Error GoTo 0
ArrayNonUsedChk = False
End Function
'************* "----- 環境変数一覧 -----"以降の文字列削除 ***********
'---------------------------------------------------------------------------------------------------------------
Private Function SentencesEndDelete(ByVal myKW As String) As Boolean
'********** myKwから文章の終わりまで削除 **********
SentencesEndDelete = False
Dim myRange As Range
Set myRange = ActiveDocument.Range(0, 0)
myRange.Find.Text = myKW
If myRange.Find.Execute Then
myRange.Select
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Delete
SentencesEndDelete = True '削除成功
End If
End Function
'---------------------------------------------------------------------------------------------------------------
Private Sub RubyAllDelete()
'********** 全文章中のルビーを削除 **********
Dim LopField As Field
For Each LopField In ActiveDocument.Fields
If LopField.Type = wdFieldFormula Then
If InStr(1, LopField.Code.Text, "\s\up") > 0 Then
LopField.Select 'FieldをSelectすることによりRangeに変換可能とする
Selection.Range.PhoneticGuide ""
End If
End If
Next
End Sub

  • わん
  • 2018/01/03 (Wed) 21:05:56
Re: AutoCadマクロ分析用Wordマクロ(レベル低いです)
なかなか環境がなく試せませんが、コード有難うございます。(CADはあるのにwordがないというなぞ環境)
勉強させて頂きます。
  • zukki-
  • 2018/01/09 (Tue) 12:29:51

返信フォーム






プレビュー (投稿前に内容を確認)