簡単タグメーカのソースコードです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
Option Explicit Const OFOLDER = "G1" 'タグメーカ Sub TAG_Make() Dim I As Long, J As Long, K As Long Dim row_max As Long Dim tag_out As String Dim br_flag As Boolean Dim table_flag As Boolean Dim table_done As Boolean Dim list_flag As Long Dim tag_tmp1 As String Dim tag_tmp2 As String Dim tag_end As String Const START_ROW = 2 'A列、B列から最大の行を取得 row_max = WorksheetFunction.Max(Range("A5000").End(xlUp).Row, Range("B5000").End(xlUp).Row) '入力データが存在するまで繰り返し For I = START_ROW To row_max '行末に改行Tagを入れるかどうかのフラグ br_flag = True table_flag = False table_done = False 'A列、B列に何も存在しないときはそのまま記入 If Cells(I, 1) = "" And Cells(I, 2) = "" Then tag_out = tag_out & Cells(I, 3) br_flag = False 'A列にタグを設定しているとき ElseIf Cells(I, 1) <> "" Then tag_tmp1 = Get_TagA(Cells(I, 1).Value) '表を作成 If tag_tmp1 = "<th>" Or tag_tmp1 = "<td>" Then If Cells(I, 2) = "" Then Call Make_Table(tag_tmp1, tag_out, I) table_done = True Else table_flag = True End If 'HyperLink、Imgを作成 ElseIf InStr(tag_tmp1, "%%%") > 0 Then tag_out = tag_out & Replace(tag_tmp1, "%%%", Cells(I, 3).Value) Else tag_out = tag_out & tag_tmp1 End If 'C列が空白の場合は改行しないこととする If Cells(I, 3) = "" Then br_flag = False End If End If 'B列にタグを設定しているとき If Cells(I, 2) <> "" Then tag_tmp2 = Get_TagE(Cells(I, 2).Value) '開始タグを追加 If InStr(tag_tmp2, ",") > 0 Then 'まず開始タグを追加 tag_out = tag_out & Split(tag_tmp2, ",")(0) If table_flag Then Call Make_Table(tag_tmp1, tag_out, I) table_done = True Else tag_out = tag_out & get_cell_tag(Cells(I, 3)) '.Value End If tag_end = Split(tag_tmp2, ",")(1) End If 'タグの終了かどうか判定 tag_tmp2 = Get_TagE(Cells(I + 1, 2).Value) If tag_tmp2 <> "continue" Then tag_out = tag_out & tag_end End If Else If table_done = False Then tag_out = tag_out & get_cell_tag(Cells(I, 3)) '.Value End If End If '改行タグをいれるかどうか判定 If br_flag Then tag_out = tag_out & "<br>" & vbCrLf Else tag_out = tag_out & vbCrLf End If Next I 'Output Text(HTML)ファイル Dim OF As Integer Dim FNAME As String Dim FPATH As String '出力先フォルダをFPATHに指定 If Range(OFOLDER) = "" Then MsgBox ("出力先フォルダが設定されていません。" & vbCrLf & "「出力フォルダ」をクリックして設定してください。" & _ vbCrLf & "設定しない場合は現フォルダに出力します。") FPATH = ThisWorkbook.Path & "\" Else FPATH = Range(OFOLDER).Text & "\" End If 'ファイル名にシート名を指定 FNAME = ActiveSheet.Name 'ファイルを開く Open FPATH & FNAME & ".html" For Output As #1 'ファイルに出力 Print #1, tag_out 'ファイルを閉じる Close #1 'Explore Open Shell "c:\windows\explorer.exe " & FPATH, vbNormalFocus End Sub '表作成するマクロ Private Sub Make_Table(ByVal tag_begin As String, ByRef tag_out, ByVal row1 As Integer) Dim col_max As Long Dim tag_end As String Dim I As Long '選択行の最大列を取得 col_max = Cells(row1, 100).End(xlToLeft).Column '最初に<tr>タグを追加 tag_out = tag_out & "<tr>" 'tag_begin,tag_endにth系、td系を設定する If tag_begin = "<th>" Then tag_end = "</th>" Else tag_end = "</td>" End If '各セル情報を追記 For I = 3 To col_max tag_out = tag_out & tag_begin & get_cell_tag(Cells(row1, I)) & tag_end Next I '最後に</tr>タグを追加 tag_out = tag_out & "</tr>" End Sub 'TAGLISTシートのA列から該当するタグ情報を取得 Private Function Get_TagA(ByVal str1 As String) As String Dim row_max As Long Dim tmp As String Dim I As Long row_max = TagSheet.Range("A1").End(xlDown).Row tmp = "" For I = 2 To row_max If TagSheet.Cells(I, 1).Value = str1 Then tmp = TagSheet.Cells(I, 2).Value Exit For End If Next I Get_TagA = tmp End Function 'TAGLISTシートのE列から該当するタグ情報を取得 Private Function Get_TagE(ByVal str1 As String) As String Dim row_max As Long Dim tmp As String Dim I As Long row_max = TagSheet.Range("A1").End(xlDown).Row tmp = "" For I = 2 To row_max If TagSheet.Cells(I, 5).Value = str1 Then tmp = TagSheet.Cells(I, 6).Value & "," & TagSheet.Cells(I, 7).Value Exit For End If Next I Get_TagE = tmp End Function '新シート作成 Sub Sheet_Make() Dim tmp As String tmp = InputBox(Title:="新シート作成", Prompt:="シート名を入力してください", Default:=Replace(Date, "/", "") & "メルマガ") If tmp = "" Then Exit Sub End If Worksheets("マスターシート").Copy After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = tmp End Sub '出力先フォルダの選択 Sub Select_Folder() With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then ActiveSheet.Range(OFOLDER) = .SelectedItems(1) End If End With End Sub Sub Clear_log() Range("B1:C1").EntireColumn.ClearContents End Sub Private Function get_cell_tag(r1 As Range) As String Dim fn_color As Long Dim bg_color As Long Dim tmp1 As String '出力タグ Dim tmp2 As String '文字列 '文字色と背景色を取得 fn_color = r1.Font.Color bg_color = r1.Interior.Color '文字を取得 tmp2 = r1.Text '文字色の色が黒でない場合はFont設定 '<font color=""> </font> If fn_color <> vbBlack Then tmp1 = "<font color=""" & hex2color(Hex(fn_color)) & """>" & tmp2 & "</font>" Else tmp1 = tmp2 End If '背景色が白でない場合はspan設定 '<span style="background-color:色"></span> If bg_color <> vbWhite Then tmp1 = "<span style=""background-color:" & hex2color(Hex(bg_color)) & """>" & tmp1 & "</span>" End If get_cell_tag = tmp1 End Function 'Excel はBGRと並んでいるので変換する Private Function hex2color(str1 As String) As String Dim rep As Long Dim I As Long Dim tmp1 As String Select Case Len(str1) Case 1: tmp1 = "#0" & str1 & "0000" Case 2: tmp1 = "#" & str1 & "0000" Case 3: tmp1 = "#" & Right(str1, 2) & "0" & Left(str1, 1) & "00" Case 4: tmp1 = "#" & Right(str1, 2) & Left(str1, 2) & "00" Case 5: tmp1 = "#" & Right(str1, 2) & Mid(str1, 2, 2) & "0" & Left(str1, 1) Case 6: tmp1 = "#" & Right(str1, 2) & Mid(str1, 3, 2) & Left(str1, 2) End Select hex2color = tmp1 End Function |
