{"id":1183,"date":"2012-01-16T10:39:07","date_gmt":"2012-01-16T01:39:07","guid":{"rendered":"http:\/\/www.ka-net.org\/blog\/?p=1183"},"modified":"2018-07-30T13:26:32","modified_gmt":"2018-07-30T04:26:32","slug":"%e3%82%bd%e3%83%bc%e3%82%b9%e3%82%b3%e3%83%bc%e3%83%89%e3%82%92%e7%95%aa%e5%8f%b7%e8%a1%8c%e4%bb%98%e3%81%8d%e3%81%ae%e3%83%86%e3%83%bc%e3%83%96%e3%83%ab%e3%81%ab%e5%a4%89%e6%8f%9b%e3%81%99%e3%82%8bwo","status":"publish","type":"post","link":"https:\/\/www.ka-net.org\/blog\/?p=1183","title":{"rendered":"\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u3092\u756a\u53f7\u884c\u4ed8\u304d\u306e\u30c6\u30fc\u30d6\u30eb\u306b\u5909\u63db\u3059\u308bWord\u30de\u30af\u30ed"},"content":{"rendered":"

Word\u6587\u66f8\u5185\u306e\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u3092\u3001\u4ed6\u306e\u6587\u66f8\u3068\u533a\u5225\u3057\u3066\u76ee\u7acb\u305f\u305b\u305f\u3044\u3068\u304d\u306b\u5f79\u7acb\u3064\u30de\u30af\u30ed\u3067\u3059\u3002<\/p>\n

\u4e0b\u56f3\u306e\u3088\u3046\u306a\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u304c\u3042\u3063\u305f\u3068\u304d\u3001\u30b3\u30fc\u30c9\u90e8\u5206\u3092\u9078\u629e\u3057\u3066\u30de\u30af\u30ed\u3092\u5b9f\u884c\u3059\u308b\u3068\u3001<\/p>\n

\"\"<\/a><\/p>\n

\u4e0b\u56f3\u306e\u3088\u3046\u306b\u756a\u53f7\u884c\u4ed8\u304d\u306e\u30c6\u30fc\u30d6\u30eb\u3078\u3068\u5909\u63db\u3055\u308c\u308b\u306e\u3067\u3001\u4e00\u76ee\u3067\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u3060\u3068\u5206\u304b\u308b\u3088\u3046\u306b\u306a\u308a\u307e\u3059\u3002<\/p>\n

\"\"<\/a>
\n<\/p>\n

Option Explicit\r\n\r\nPublic Sub SourceCodeToTable()\r\n'\u9078\u629e\u3057\u3066\u3044\u308b\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u3092\u8868\u5f62\u5f0f\u3067\u51fa\u529b\r\n  Dim tbl As Word.Table\r\n  Dim ln As Long, i As Long\r\n  \r\n  '---------------------------------------------------------------\r\n  '\u30bb\u30eb\u306e\u80cc\u666f\u8272\u30fb\u6587\u5b57\u8272\u8a2d\u5b9a(\u203b \u5fc5\u8981\u306b\u5fdc\u3058\u3066\u5909\u66f4)\r\n  '---------------------------------------------------------------\r\n  Const LineCellBGColor As Long = &H333333 '\u884c\u756a\u53f7\u30bb\u30eb\u306e\u80cc\u666f\u8272\r\n  Const LineCellFontColor As Long = &HFFFFFF '\u884c\u756a\u53f7\u30bb\u30eb\u306e\u6587\u5b57\u8272\r\n  Const CodeCellBGColor As Long = &HD9D9D9 '\u30b3\u30fc\u30c9\u30bb\u30eb\u306e\u80cc\u666f\u8272\r\n  Const CodeCellFontColor As Long = &H0 '\u30b3\u30fc\u30c9\u30bb\u30eb\u306e\u6587\u5b57\u8272\r\n  '---------------------------------------------------------------\r\n  \r\n  If ChkCondition = False Then\r\n    MsgBox "\u30bd\u30fc\u30b9\u30b3\u30fc\u30c9\u3092\u9078\u629e\u3057\u305f\u72b6\u614b\u3067\u5b9f\u884c\u3057\u3066\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n    Exit Sub\r\n  End If\r\n  \r\n  Application.ScreenUpdating = False\r\nOn Error GoTo Err:\r\n  Selection.Cut\r\n  Set tbl = ActiveDocument.Tables.Add(Selection.Range, 1&, 2&)\r\n  \r\n  '\u30d5\u30a9\u30f3\u30c8\u8a2d\u5b9a\r\n  With tbl.Range.Font\r\n    .Size = 10\r\n    .NameFarEast = "\uff2d\uff33 \u30b4\u30b7\u30c3\u30af"\r\n    .NameAscii = "\uff2d\uff33 \u30b4\u30b7\u30c3\u30af"\r\n    .NameOther = "\uff2d\uff33 \u30b4\u30b7\u30c3\u30af"\r\n    .Bold = False\r\n    .Italic = False\r\n    .Underline = wdUnderlineNone\r\n    .UnderlineColor = wdColorAutomatic\r\n    .StrikeThrough = False\r\n    .DoubleStrikeThrough = False\r\n    .Outline = False\r\n    .Emboss = False\r\n    .Shadow = False\r\n    .Hidden = False\r\n    .SmallCaps = False\r\n    .AllCaps = False\r\n    .Color = wdColorAutomatic\r\n    .Engrave = False\r\n    .Superscript = False\r\n    .Subscript = False\r\n  End With\r\n  \r\n  '\u6bb5\u843d\u8a2d\u5b9a\r\n  With tbl.Range.ParagraphFormat\r\n    .LineSpacingRule = wdLineSpaceSingle '\u884c\u9593\uff1a1\u884c\r\n    .WordWrap = False '[\u82f1\u5358\u8a9e\u306e\u9014\u4e2d\u3067\u6539\u884c\u3059\u308b(W)]\u306b\u30c1\u30a7\u30c3\u30af\r\n  End With\r\n  \r\n  '\u30c6\u30fc\u30d6\u30eb\u8a2d\u5b9a\r\n  tbl.Borders.Enable = False '\u7f6b\u7dda\u3092\u3059\u3079\u3066\u524a\u9664\r\n  tbl.Columns(1).PreferredWidthType = wdPreferredWidthPoints\r\n  tbl.Columns(1).PreferredWidth = MillimetersToPoints(12) '\u884c\u756a\u53f7\u5217\u306e\u5e45\u8a2d\u5b9a\r\n  tbl.Columns(1).Cells.VerticalAlignment = wdCellAlignVerticalTop\r\n  tbl.Columns(1).Cells.Shading.Texture = wdTextureNone\r\n  tbl.Columns(1).Cells.Shading.ForegroundPatternColor = wdColorAutomatic\r\n  tbl.Columns(1).Cells.Shading.BackgroundPatternColor = LineCellBGColor\r\n  tbl.Columns(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter\r\n  tbl.Columns(1).Cells(1).Range.Font.Color = LineCellFontColor\r\n  tbl.Columns(2).Cells.VerticalAlignment = wdCellAlignVerticalTop\r\n  tbl.Columns(2).Cells.Shading.Texture = wdTextureNone\r\n  tbl.Columns(2).Cells.Shading.ForegroundPatternColor = wdColorAutomatic\r\n  tbl.Columns(2).Cells.Shading.BackgroundPatternColor = CodeCellBGColor\r\n  tbl.Columns(2).Cells(1).Range.Font.Color = CodeCellFontColor\r\n  tbl.Columns(2).PreferredWidthType = wdPreferredWidthAuto\r\n  tbl.AutoFitBehavior wdAutoFitWindow '\u30a6\u30a3\u30f3\u30c9\u30a6\u30b5\u30a4\u30ba\u306b\u5408\u308f\u305b\u3066\u5e45\u8abf\u6574\r\n  \r\n  '\u30b3\u30fc\u30c9\u8cbc\u308a\u4ed8\u3051\r\n  tbl.Columns(2).Cells(1).Range.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False\r\n  ln = GetCellLines(tbl)\r\n  If ln = 0& Then Exit Sub\r\n  For i = 1 To ln\r\n    If i <> ln Then\r\n     tbl.Columns(1).Cells(1).Range.InsertAfter i & vbCr\r\n    Else\r\n      tbl.Columns(1).Cells(1).Range.InsertAfter i\r\n    End If\r\n  Next\r\n  Set tbl = Nothing\r\n  Application.ScreenUpdating = True\r\n  Exit Sub\r\n\r\nErr:\r\n  MsgBox "\u51e6\u7406\u304c\u5931\u6557\u3057\u307e\u3057\u305f\u3002", vbCritical + vbSystemModal\r\n  Application.ScreenUpdating = True\r\nEnd Sub\r\n\r\nPrivate Function ChkCondition() As Boolean\r\n'\u30d7\u30ed\u30b7\u30fc\u30b8\u30e3\u304c\u5b9f\u884c\u3067\u304d\u308b\u72b6\u6cc1\u306a\u306e\u304b\u3092\u78ba\u8a8d\r\n  Dim ret As Boolean\r\n  Dim tmp As String\r\n  \r\n  ret = True '\u521d\u671f\u5316\r\n  If Selection.Type <> wdSelectionNormal Then ret = False '\u30c6\u30ad\u30b9\u30c8\u304c\u9078\u629e\u72b6\u614b\u306b\u3042\u308b\u304b\u3092\u78ba\u8a8d\r\n  '\u9078\u629e\u6587\u5b57\u5217\u304c\u6539\u884c\u3068\u7a7a\u767d\u306e\u307f\u304b\u3069\u3046\u304b\u3092\u78ba\u8a8d\r\n  tmp = Selection.Text\r\n  tmp = Replace$(tmp, vbCr, "")\r\n  tmp = Replace$(tmp, "\u3000", "")\r\n  tmp = Replace$(tmp, " ", "")\r\n  If Len(tmp) < 1 Then ret = False\r\n  ChkCondition = ret\r\nEnd Function\r\n\r\nPrivate Function GetCellLines(ByVal tbl As Word.Table) As Long\r\n'\u30bb\u30eb\u306e\u884c\u6570\u30ab\u30a6\u30f3\u30c8\r\n  Dim ln As Long\r\n  \r\n  ln = 0 '\u521d\u671f\u5316\r\n  tbl.Columns(2).Cells(1).Range.Select\r\n  Selection.StartOf wdCell, wdMove\r\n  Do While Selection.Information(wdWithInTable)\r\n    ln = ln + 1\r\n    Selection.MoveDown wdLine, 1, wdMove\r\n  Loop\r\n  GetCellLines = ln\r\nEnd Function<\/pre>\n
\u30c6\u30fc\u30d6\u30eb\u306e\u80cc\u666f\u8272\u3084\u6587\u5b57\u8272\u3001\u30d5\u30a9\u30f3\u30c8\u7b49\u306f\u597d\u307f\u306b\u5fdc\u3058\u3066\u9069\u5f53\u306b\u5909\u66f4\u3057\u3066\u304f\u3060\u3055\u3044\u3002<\/p>\n
\n
\n