Skip to content

Instantly share code, notes, and snippets.

@YujiFukami

YujiFukami/S_バーコード出力テスト

Created August 29, 2023 00:56
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save YujiFukami/f116e3e48d2c3bb32e0200e3b9f49f46 to your computer and use it in GitHub Desktop.
Save YujiFukami/f116e3e48d2c3bb32e0200e3b9f49f46 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
S_バーコード出力テスト
'S_バーコード出力テスト ・・・元場所：VBAProject.Mod01_
'Get__バーコード番号一覧 ・・・元場所：VBAProject.Mod01_
'GetCellArea ・・・元場所：IkiAddin.ModCell
'GetEndCol ・・・元場所：IkiAddin.ModCell
'GetEndCell ・・・元場所：IkiAddin.ModCell
'GetEndRow ・・・元場所：IkiAddin.ModCell
'GetArray2DFromCell ・・・元場所：IkiAddin.ModCell
'TransposeN1toArray1D ・・・元場所：IkiAddin.ModArray
'CheckArray2D ・・・元場所：IkiAddin.ModArray
'CheckArray2DStart1 ・・・元場所：IkiAddin.ModArray
'MakeBarcode_JAN ・・・元場所：IkiAddin.ModBarCode
'GetCheckDegit ・・・元場所：IkiAddin.ModBarCode
'Get_13ケタから全パリティ取得・・・元場所：IkiAddin.ModBarCode
'Get_偶奇パターン ・・・元場所：IkiAddin.ModBarCode
'Get_偶奇パターン単体 ・・・元場所：IkiAddin.ModBarCode
'Get_左側偶数パリティ ・・・元場所：IkiAddin.ModBarCode
'Get_パリティ単体 ・・・元場所：IkiAddin.ModBarCode
'Get_左側奇数パリティ ・・・元場所：IkiAddin.ModBarCode
'Get_右側偶数パリティ ・・・元場所：IkiAddin.ModBarCode
'Get_数値からパリティ作成 ・・・元場所：IkiAddin.ModBarCode
'S_パリティから塗潰 ・・・元場所：IkiAddin.ModBarCode
'S_バーコード寸法決定汎用 ・・・元場所：IkiAddin.ModBarCode
'ConvPxToWidth ・・・元場所：IkiAddin.ModGraphPaper
'PastePicture_FromCell ・・・元場所：IkiAddin.ModShape
'SetPictureInCell ・・・元場所：IkiAddin.ModShape
'宣言セクション※※※※※※※※※※※※※※※※※※※※※※※※※※※
'-----------------------------------
'元場所:IkiAddin.ModBarCode.Enum_偶奇
Public Enum Enum_偶奇
vb遇 = 0
vb奇 = 1
End Enum
'-----------------------------------
'元場所:IkiAddin.ModShape.EnumPicturePosition
Public Enum EnumPicturePosition
vb00中央 = 0
vb01左上 = 1
vb02左中央 = 2
vb03左下 = 3
vb04下中央 = 4
vb05右下 = 5
vb06右中央 = 6
vb07右上 = 7
vb08上中央 = 8
End Enum
'宣言セクション終了※※※※※※※※※※※※※※※※※※※※※※※※※※※
Public Sub S_バーコード出力テスト()
'情報取得
Dim List_バーコード As Variant: List_バーコード = Get__バーコード番号一覧
Dim Cell As Range: Set Cell = Sheet2.Range("バーコード") 'B2
'処理
Dim I As Long
Dim N As Long: N = UBound(List_バーコード, 1)
Dim CellArea As Range
Dim Code As String
Dim ShapeCode As Picture
For I = 1 To N
Set CellArea = Cell.Offset(I, 1) 'バーコードを生成するセル
Code = List_バーコード(I)
Code = Mid(Code, 1, 12) 'チェックディジットを除いた12桁だけを取得する
Set ShapeCode = MakeBarcode_JAN(Code, CellArea, "バーコード" & I) 'バーコード生成
ShapeCode.Width = ShapeCode.Width * 0.8 '幅をセル幅の80%にする
Call SetPictureInCell(ShapeCode, CellArea, vb00中央, 0.1) 'セルの中央に配置する
Next
End Sub
Private Function Get__バーコード番号一覧() As Variant
Dim Sheet As Worksheet: Set Sheet = Sheet2 '←←←←←←←←←←←←←←←←←←←←←←←
Dim Cell As Range: Set Cell = Sheet.Range("バーコード") 'B2←←←←←←←←←←←←←←←←←←←←←←←
If Cell.Value = "" Then Exit Function
Dim CellArea As Range: Set CellArea = GetCellArea(Cell, 1, 2) 'Cellを基準にセル範囲を取得
Dim List As Variant: List = GetArray2DFromCell(CellArea) 'セル範囲から二次元配列作成
List = TransposeN1toArray1D(List) 'Nx1の二次元配列を一次元配列に変換
Get__バーコード番号一覧 = List
End Function
Private Function GetCellArea(ByVal StartCell As Range, _
Optional ByRef ColCount As Long, _
Optional ByRef StartRow As Long = 1, _
Optional ByRef MaxRenzokuBlank As Long = 0) _
As Range
'基準位置のセルだけから表範囲セルを取得する。
'20220221
'20221121 MaxRenzokuBlankを入力可能に
'引数
'StartCell ・・・基準セル
'[ColCount] ・・・列数。省略なら基準セルから自動で探索
'[StartRow] ・・・セル範囲の範囲内での開始行番号。省略なら1で最初の行からの範囲。1行目の項目行を省きたい場合などは2を入力
'[MaxRenzokuBlank]・・・空白セルの連続個数(いくつ以上の空白セルが連続したら、最後の非空白セルが最終セル)
'列数の計算
If ColCount = 0 Then '列数が指定されていない
'一番左のセルの列を取得する
Dim Ce As Long '終了列
Ce = GetEndCol(StartCell) '最終列を取得
ColCount = Ce - StartCell.Column + 1 '列数を設定
End If
'最終セルの取得
Dim EndCell As Range: '表の最終セル (左下のセル)
Set EndCell = GetEndCell(StartCell, MaxRenzokuBlank).Offset(0, ColCount - 1)
'開始セルの再設定
Set StartCell = StartCell.Offset(StartRow - 1, 0)
'出力
Dim Output As Range: Set Output = Range(StartCell, EndCell)
Set GetCellArea = Output
End Function
Private Function GetEndCol(ByRef StartCell As Range, _
Optional ByVal MaxRenzokuBlank As Long = 0)
'指定セルから右方向の最終セルの列番号を取得する
'20211102
'20220221 連続空白個数の判定式を修正
'20220301 改良
'StartCell :探索する基準の開始セル
'MaxRenzokuBlank :空白セルの連続個数(いくつ以上の空白セルが連続したら、最後の非空白セルが最終セル)
Dim InputSheet As Worksheet
Dim StartRow As Long
Dim StartCol As Long
Dim TmpRenzokuBlank As Long
Dim TmpEndCol As Long
Dim TmpCol As Long
Set InputSheet = StartCell.Parent
If MaxRenzokuBlank = 0 Then
MaxRenzokuBlank = 500 '←←←←←←←←←←←←←←←←←←←←←←←
End If
StartRow = StartCell.Row
StartCol = StartCell.Column
For TmpCol = StartCol To Columns.Count
If InputSheet.Cells(StartRow, TmpCol).Value = "" Then
If MaxRenzokuBlank = 0 Then
'その位置の手前が最終行
Exit For
Else
TmpRenzokuBlank = TmpRenzokuBlank + 1
End If
If TmpRenzokuBlank >= MaxRenzokuBlank Then '20220221
'指定した数以上に空白セルが連続した場合は、最後の非空白セルが最終行
Exit For
End If
Else
TmpEndCol = TmpCol
TmpRenzokuBlank = 0
End If
Next TmpCol
If TmpEndCol = 0 Then TmpEndCol = StartCell.Column '20220301(右側がずっと空白セルの場合)
GetEndCol = TmpEndCol '出力
End Function
Private Function GetEndCell(ByRef StartCell As Range, _
Optional ByRef MaxRenzokuBlank As Long = 0) As Range
'オートフィルタが設定してある場合も考慮しての最終セルの取得
'20210728
'StartCell :探索する基準の開始セル
'MaxRenzokuBlank :空白セルの連続個数(いくつ以上の空白セルが連続したら、最後の非空白セルが最終セル)
Dim EndRow As Long
Dim InputSheet As Worksheet
EndRow = GetEndRow(StartCell, MaxRenzokuBlank)
Set InputSheet = StartCell.Parent
Dim Output As Range
Set Output = InputSheet.Cells(EndRow, StartCell.Column)
Set GetEndCell = Output
End Function
Private Function GetEndRow(ByRef StartCell As Range, _
Optional ByVal MaxRenzokuBlank As Long = 0)
'オートフィルタが設定してある場合も考慮しての最終行の取得
'20210728
'20220221 連続空白個数の判定式を修正
'StartCell :探索する基準の開始セル
'MaxRenzokuBlank :空白セルの連続個数(いくつ以上の空白セルが連続したら、最後の非空白セルが最終セル)
Dim InputSheet As Worksheet: Set InputSheet = StartCell.Parent '対象シート取得
Dim StartRow As Long '開始セル行番号
Dim StartCol As Long '開始セル列番号
Dim TmpRenzokuBlank As Long '一次的な空白セルの連続個数
Dim TmpEndRow As Long '一時的な最終行番号
Dim TmpRow As Long '一時的な行番号
If InputSheet.AutoFilterMode Or MaxRenzokuBlank <> 0 Then 'オートフィルタが設定されている場合
If MaxRenzokuBlank = 0 Then
MaxRenzokuBlank = 500 '←←←←←←←←←←←←←←←←←←←←←←←
End If
StartRow = StartCell.Row
StartCol = StartCell.Column
For TmpRow = StartRow To Rows.Count 'シート下端行まで探索
If IsError(InputSheet.Cells(TmpRow, StartCol).Value) = True Then
If MaxRenzokuBlank = 0 Then
'その位置の手前が最終行
Exit For
Else
TmpRenzokuBlank = TmpRenzokuBlank + 1
End If
If TmpRenzokuBlank >= MaxRenzokuBlank Then '20220221
'指定した数以上に空白セルが連続した場合は、最後の非空白セルが最終行
Exit For
End If
ElseIf InputSheet.Cells(TmpRow, StartCol).Value = "" Then
If MaxRenzokuBlank = 0 Then
'その位置の手前が最終行
Exit For
Else
TmpRenzokuBlank = TmpRenzokuBlank + 1
End If
If TmpRenzokuBlank >= MaxRenzokuBlank Then '20220221
'指定した数以上に空白セルが連続した場合は、最後の非空白セルが最終行
Exit For
End If
Else
TmpEndRow = TmpRow
TmpRenzokuBlank = 0
End If
Next
Else 'オートフィルタが設定されていない場合
'通常の最終行の取得
TmpEndRow = InputSheet.Cells(Rows.Count, StartCell.Column).End(xlUp).Row
End If
GetEndRow = TmpEndRow '出力
End Function
Private Function GetArray2DFromCell(CellArea As Range) As Variant
'セルオブジェクトからセル値の二次元配列を取得する
'セルオブジェクトが単一セルでも二次元配列となる。
'「単一セル.Value」が配列でなく変数になるのに対応
'20220921
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/35185051.html
'引数
'CellArea・・・セル範囲
'戻り値
'セル範囲から生成される二次元配列
Dim Output As Variant
If CellArea.CountLarge = 1 Then '単一セルの場合
ReDim Output(1 To 1, 1 To 1)
Output(1, 1) = CellArea.Value
Else
Output = CellArea.Value
End If
'出力
GetArray2DFromCell = Output
End Function
Private Function TransposeN1toArray1D(Array2D_N1 As Variant) As Variant
'要素数Nx1(縦一列)の二次元配列を転移して一次元配列にする
'各要素がオブジェクトでも対応可能
'通常のWorksheetFunction.Transposeだと日付型が文字列型になる問題対応
'20220921
'引数チェック
Call CheckArray2D(Array2D_N1) '二次元配列かチェック
Call CheckArray2DStart1(Array2D_N1) '開始要素番号が1かチェック
If UBound(Array2D_N1, 2) <> 1 Then
MsgBox "横要素数は1にしてください", vbExclamation
Stop
End If
'処理
Dim I As Long
Dim N As Long: N = UBound(Array2D_N1, 1) '縦要素数
Dim Output As Variant: ReDim Output(1 To N) '出力する配列の準備
For I = 1 To N
If IsObject(Array2D_N1(I, 1)) = True Then '要素がオブジェクトの場合
Set Output(I) = Array2D_N1(I, 1) 'オブジェクトを格納
Else '変数の場合
Output(I) = Array2D_N1(I, 1) '変数で格納
End If
Next
'出力
TransposeN1toArray1D = Output
End Function
Private Sub CheckArray2D(ByRef Array2D As Variant, _
Optional ByRef ArrayName As String = "配列")
'入力配列が2次元配列かどうかチェックする
'20210804
'20220309 変数名変更
On Error Resume Next
Dim Dummy2 As Long: Dummy2 = UBound(Array2D, 2)
Dim Dummy3 As Long: Dummy3 = UBound(Array2D, 3)
On Error GoTo 0
If Dummy2 = 0 Or Dummy3 <> 0 Then
MsgBox ArrayName & "は2次元配列を入力してください", vbExclamation
Stop
Exit Sub '入力元のプロシージャを確認するために抜ける
End If
End Sub
Private Sub CheckArray2DStart1(ByRef Array2D As Variant, _
Optional ByRef ArrayName As String = "配列")
'入力2次元配列の開始番号が1かどうかチェックする
'20210804
'20220309 変数名変更
If LBound(Array2D, 1) <> 1 Or LBound(Array2D, 2) <> 1 Then
MsgBox ArrayName & "の開始要素番号は1にしてください", vbExclamation
Stop
Exit Sub '入力元のプロシージャを確認するために抜ける
End If
End Sub
Private Function MakeBarcode_JAN(ByRef Num12 As String, _
ByRef OutCellArea As Range, _
Optional ByRef PictureName As String = "バーコード") _
As Picture
'JANコードでのバーコードを作成する
'バーコードは別シートにおいてセルの塗りつぶしで作成し、そのセル範囲を画像として貼り付ける。
'20221105
'引数
'Num12 ・・・JANコードの12桁(13桁目のチェックデジットは自動的に作成する
'OutCellArea ・・・出力先のセル範囲。このセル範囲の大きさにフィットしたバーコードが作成される
'[PictureName]・・・出力される画像のシェイプ名
'引数チェック
If Len(Num12) <> 12 Then
MsgBox "番号は12桁を入力してください", vbExclamation
Exit Function
End If
If IsNumeric(Num12) = False Then
MsgBox "番号に数字でないものが混じっています", vbExclamation
Exit Function
End If
'チェックデジット取得
Dim Lng_CheckDigit As Long: Lng_CheckDigit = GetCheckDegit(Num12)
Dim Num13 As String: Num13 = Num12 & Lng_CheckDigit
Dim List_パリティ13 As Variant: List_パリティ13 = Get_13ケタから全パリティ取得(Num13)
Dim List_パリティ左 As Variant: List_パリティ左 = Get_数値からパリティ作成("101")
Dim List_パリティ中央 As Variant: List_パリティ中央 = Get_数値からパリティ作成("01010")
Dim List_パリティ右 As Variant: List_パリティ右 = Get_数値からパリティ作成("101")
'バーコード作成用のシート準備
Dim Book As Workbook: Set Book = ActiveWorkbook
Dim Sheet As Worksheet: Set Sheet = Book.Sheets.Add
Sheet.Cells.Interior.Color = rgbWhite 'すべて白にしてグリッド線を見えなくする
'セル出力
Dim StartCell As Range: Set StartCell = Sheet.Range("A1") '←←←←←←←←←←←←←←←←←←←←←←←
'左側のパリティ出力
Dim Cell As Range: Set Cell = StartCell
Call S_パリティから塗潰(List_パリティ左, Cell, True)
Set Cell = Cell.Offset(0, 3) '次用にオフセット
'左側数字のパリティ出力
Dim I As Long
For I = 1 To 6
Dim Tmp_パリティ As Variant: Tmp_パリティ = List_パリティ13(I)
Call S_パリティから塗潰(Tmp_パリティ, Cell, False)
Set Cell = Cell.Offset(0, 7)
Next
'中央のパリティ出力
Call S_パリティから塗潰(List_パリティ中央, Cell, True)
Set Cell = Cell.Offset(0, 5)
'右側数字のパリティ出力
For I = 7 To 12
Tmp_パリティ = List_パリティ13(I)
Call S_パリティから塗潰(Tmp_パリティ, Cell, False)
Set Cell = Cell.Offset(0, 7)
Next
'右側のパリティ出力
Call S_パリティから塗潰(List_パリティ右, Cell, True)
'サイズ調整
Call S_バーコード寸法決定汎用(Sheet, StartCell.Resize(2, 95))
'画像データで持ってくる
Dim Output As Picture
Set Output = PastePicture_FromCell(StartCell.Resize(2, 95), OutCellArea, PictureName)
'バーコード作成用のシートの消去
Application.DisplayAlerts = False
Sheet.Delete
Application.DisplayAlerts = True
'出力
Set MakeBarcode_JAN = Output
End Function
Private Function GetCheckDegit(Num12 As String) As Long
'12桁の数字からJANコード用のチェックデジットを取得する
'引数チェック
If Len(Num12) <> 12 Then Exit Function
If IsNumeric(Num12) = False Then Exit Function
'処理
Dim I As Long
Dim SumNum As Long
For I = 1 To 12
Dim Num As Long: Num = Mid(Num12, I, 1)
If I Mod 2 = 1 Then '奇数の場合
SumNum = SumNum + Num * 1
Else '偶数の場合
SumNum = SumNum + Num * 3
End If
Next
'1桁目からチェックデジット計算
Dim NumFirst As Long: NumFirst = Right(Str(SumNum), 1) '1桁目取得
Dim Output As Long
If NumFirst = 0 Then
Output = 0
Else
Output = 10 - NumFirst
End If
'出力
GetCheckDegit = Output
End Function
Private Function Get_13ケタから全パリティ取得(Num13 As String)
Dim Num1 As Long: Num1 = Mid(Num13, 1, 1)
Dim Output(1 To 12) As Variant
Dim List_偶奇パターン As Variant: List_偶奇パターン = Get_偶奇パターン(Num1)
Dim I As Long
Dim Num As Long
For I = 2 To 7
Num = Mid(Num13, I, 1)
Dim Judge_遇奇 As Enum_偶奇
Judge_遇奇 = List_偶奇パターン(I - 1)
If Judge_遇奇 = Enum_偶奇.vb遇 Then
Output(I - 1) = Get_左側偶数パリティ(Num)
Else
Output(I - 1) = Get_左側奇数パリティ(Num)
End If
Next
For I = 8 To 13
Num = Mid(Num13, I, 1)
Output(I - 1) = Get_右側偶数パリティ(Num)
Next
Get_13ケタから全パリティ取得 = Output
End Function
Private Function Get_偶奇パターン(Num As Long) As Variant
Dim Output(0 To 9) As Variant
Output(0) = Get_偶奇パターン単体("111111")
Output(1) = Get_偶奇パターン単体("110100")
Output(2) = Get_偶奇パターン単体("110010")
Output(3) = Get_偶奇パターン単体("110001")
Output(4) = Get_偶奇パターン単体("101100")
Output(5) = Get_偶奇パターン単体("100110")
Output(6) = Get_偶奇パターン単体("100011")
Output(7) = Get_偶奇パターン単体("101010")
Output(8) = Get_偶奇パターン単体("101001")
Output(9) = Get_偶奇パターン単体("100101")
Get_偶奇パターン = Output(Num)
End Function
Private Function Get_偶奇パターン単体(StrNum As String) As Variant
Dim Output(1 To 6) As Long
Dim I As Long
For I = 1 To 6
Dim Num As Long: Num = Mid(StrNum, I, 1)
If Num = 0 Then
Output(I) = Enum_偶奇.vb遇
Else
Output(I) = Enum_偶奇.vb奇
End If
Next
Get_偶奇パターン単体 = Output
End Function
Private Function Get_左側偶数パリティ(Num As Long) As Variant
Dim List(0 To 9) As Variant
List(0) = Get_パリティ単体("0100111")
List(1) = Get_パリティ単体("0110011")
List(2) = Get_パリティ単体("0011011")
List(3) = Get_パリティ単体("0100001")
List(4) = Get_パリティ単体("0011101")
List(5) = Get_パリティ単体("0111001")
List(6) = Get_パリティ単体("0000101")
List(7) = Get_パリティ単体("0010001")
List(8) = Get_パリティ単体("0001001")
List(9) = Get_パリティ単体("0010111")
Get_左側偶数パリティ = List(Num)
End Function
Private Function Get_パリティ単体(StrNum As String) As Variant
Dim Lng_パリティ長さ As Long: Lng_パリティ長さ = Len(StrNum)
Dim Output() As Long: ReDim Output(1 To Lng_パリティ長さ)
Dim I As Long
For I = 1 To Lng_パリティ長さ
Output(I) = Mid(StrNum, I, 1)
Next
Get_パリティ単体 = Output
End Function
Private Function Get_左側奇数パリティ(Num As Long) As Variant
Dim List(0 To 9) As Variant
List(0) = Get_パリティ単体("0001101")
List(1) = Get_パリティ単体("0011001")
List(2) = Get_パリティ単体("0010011")
List(3) = Get_パリティ単体("0111101")
List(4) = Get_パリティ単体("0100011")
List(5) = Get_パリティ単体("0110001")
List(6) = Get_パリティ単体("0101111")
List(7) = Get_パリティ単体("0111011")
List(8) = Get_パリティ単体("0110111")
List(9) = Get_パリティ単体("0001011")
Get_左側奇数パリティ = List(Num)
End Function
Private Function Get_右側偶数パリティ(Num As Long) As Variant
Dim List(0 To 9) As Variant
List(0) = Get_パリティ単体("1110010")
List(1) = Get_パリティ単体("1100110")
List(2) = Get_パリティ単体("1101100")
List(3) = Get_パリティ単体("1000010")
List(4) = Get_パリティ単体("1011100")
List(5) = Get_パリティ単体("1001110")
List(6) = Get_パリティ単体("1010000")
List(7) = Get_パリティ単体("1000100")
List(8) = Get_パリティ単体("1001000")
List(9) = Get_パリティ単体("1110100")
Get_右側偶数パリティ = List(Num)
End Function
Private Function Get_数値からパリティ作成(StrNum As String) As Variant
Dim N As Long: N = Len(StrNum)
Dim Output As Variant: ReDim Output(1 To N)
Dim I As Long
For I = 1 To N
Output(I) = Mid(StrNum, I, 1)
Next
Get_数値からパリティ作成 = Output
End Function
Private Sub S_パリティから塗潰(List_パリティ As Variant, StartCell As Range, Judge_下に伸ばす As Boolean)
'0なら白
'1なら黒
Dim N As Long: N = UBound(List_パリティ, 1) '数字件数
Dim I As Long
For I = 1 To N
Dim Num As Long: Num = List_パリティ(I)
Dim Cell As Range
If Judge_下に伸ばす = True Then
Set Cell = StartCell.Offset(0, I - 1).Resize(2, 1)
Else
Set Cell = StartCell.Offset(0, I - 1)
End If
If Num = 0 Then
Cell.Interior.Color = rgbWhite
Else
Cell.Interior.Color = rgbBlack
End If
Next I
End Sub
Private Sub S_バーコード寸法決定汎用(Sheet As Worksheet, StartCell As Range)
Dim Height As Double: Height = 200 * 0.6 'ピクセル値に変換でx0.6'←←←←←←←←←←←←←←←←←←←←←←←←
Dim LngWidth As Long: LngWidth = 9 '←←←←←←←←←←←←←←←←←←←←←←←←
Dim Width As Double: Width = ConvPxToWidth(LngWidth) 'ピクセル値に変換
StartCell.EntireRow.RowHeight = Height
StartCell.Offset(1, 0).EntireRow.RowHeight = Height * 0.2
StartCell.EntireColumn.ColumnWidth = Width
End Sub
Private Function ConvPxToWidth(Px As Long)
'ピクセル値を幅に変換する
Dim Output As Double
If Px <= 4 Then
Output = 0.06 * Px
ElseIf Px = 5 Then
Output = 0.29
ElseIf Px <= 12 Then
Output = 0.06 * (Px - 6) + 0.35
ElseIf Px = 13 Then
Output = 0.76
ElseIf Px <= 17 Then
Output = 0.06 * (Px - 14) + 0.82
Else
Output = 0.1 * (Px - 18) + 1.1
End If
ConvPxToWidth = Output
End Function
Private Function PastePicture_FromCell(ByRef CopyArea As Range, _
ByRef PasteArea As Range, _
ByRef PictureName As String, _
Optional ByRef GapParUD As Double = 0, _
Optional ByRef GapParLR As Double = 0) _
As Picture
'指定のセル範囲を画像としてコピーしてきて、指定のセル範囲に貼り付ける
'貼り付ける範囲のセルにおいて上下左右の余白も設定できる
'20221012
'20221018 改良
'20221105 Functionプロシージャとして作成した画像をPicture型として返す
'紹介予定
'引数
'CopyArea ・・・画像としてコピーしてくるセル範囲
'PasteArea ・・・貼り付け先のセル範囲
'PictureName・・・貼り付けた画像の名前
'[GapParUD] ・・・貼り付け先のセル範囲での上下余白の割合(省略なら0)
'[GapParLR] ・・・貼り付け先のセル範囲での左右余白の割合(省略なら0)
'セルを画像として貼り付け
CopyArea.Copy
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
Dim Sheet As Worksheet: Set Sheet = PasteArea.Parent '貼り付け先のシート
Sheet.Activate
Dim Picture As Picture
On Error Resume Next '貼り付けが成功するまで繰り返す'Ver2.02
Dim K As Long
Do
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
Set Picture = Nothing
Set Picture = Sheet.Pictures.Paste '画像をまず貼り付け
On Error GoTo -1 'エラー初期化
If Not Picture Is Nothing Then
Exit Do
End If
K = K + 1
Debug.Print "試行回数" & K
Loop
On Error GoTo 0
Picture.Name = PictureName
'画像のサイズと位置を計算
Dim GapUD As Double: GapUD = PasteArea.Height * GapParUD '上下の余白
Dim GapLR As Double: GapLR = PasteArea.Width * GapParLR '左右の余白
Dim Height As Double: Height = PasteArea.Height - 2 * GapUD '高さ
Dim Width As Double: Width = PasteArea.Width - 2 * GapLR '幅
Dim Top As Double: Top = PasteArea.Top + GapUD '上位置
Dim Left As Double: Left = PasteArea.Left + GapLR '左位置
'画像のサイズと位置を設定
With Picture
.Left = Left
.Top = Top
.ShapeRange.LockAspectRatio = msoFalse '縦横比の固定を外す
.Height = Height
.Width = Width
End With
'出力
Set PastePicture_FromCell = Picture
End Function
Private Sub SetPictureInCell(ByRef Picture As Picture, _
ByRef Cell As Range, _
Optional ByRef Position As EnumPicturePosition = EnumPicturePosition.vb00中央, _
Optional ByRef Margin As Double = 0)
'画像をシートに収まるように配置する
'20230407
'紹介予定
'引数
'Picture ・・・画像ファイル
'Cell ・・・貼り付けるセル範囲
'[Position] ・・・セル範囲内での9点画像位置
'[Margin] ・・・余白(パーセンテージ) Margin x セルの幅or高さの余白が追加される
'対象シート設定
Dim Sheet As Worksheet: Set Sheet = Cell.Parent
Dim Shape As Shape: Set Shape = Sheet.Shapes(Picture.Name) 'シェイプオブジェクトとして格納
'セルのサイズ、画像のサイズを取得
Dim CellHeight As Double: CellHeight = Cell.Height
Dim CellWidth As Double: CellWidth = Cell.Width
Dim PicHeight As Double: PicHeight = Shape.Height
Dim PicWidth As Double: PicWidth = Shape.Width
'縦横比を比較してセル範囲に入るようにサイズ変更
If CellHeight / CellWidth > PicHeight / PicWidth Then 'セルのほうが縦長
' Shape.Width = CellWidth '画像の幅をセルの幅に合わせる
Shape.Width = CellWidth - CellWidth * Margin * 2 '画像の幅をセルの幅に合わせる
Else
' Shape.Height = CellHeight
Shape.Height = CellHeight - CellHeight * Margin * 2
End If
'9点の位置設定から左右、上下の位置を設定
Dim PositionLR As String
Dim PositionUD As String
Select Case Position
Case EnumPicturePosition.vb00中央
PositionLR = "中央"
PositionUD = "中央"
Case EnumPicturePosition.vb01左上
PositionLR = "左"
PositionUD = "上"
Case EnumPicturePosition.vb02左中央
PositionLR = "左"
PositionUD = "中央"
Case EnumPicturePosition.vb03左下
PositionLR = "左"
PositionUD = "下"
Case EnumPicturePosition.vb04下中央
PositionLR = "中央"
PositionUD = "下"
Case EnumPicturePosition.vb05右下
PositionLR = "右"
PositionUD = "下"
Case EnumPicturePosition.vb06右中央
PositionLR = "右"
PositionUD = "中央"
Case EnumPicturePosition.vb07右上
PositionLR = "右"
PositionUD = "上"
Case EnumPicturePosition.vb08上中央
PositionLR = "中央"
PositionUD = "上"
End Select
'上下、左右のオフセット量計算
Dim OffsetLR As Double
Dim OffsetUD As Double
Select Case PositionLR
Case "左"
' OffsetLR = 0
OffsetLR = CellWidth * Margin
Case "中央"
' OffsetLR = CellWidth / 2 - Shape.Width / 2
OffsetLR = CellWidth / 2 - Shape.Width / 2
Case "右"
' OffsetLR = CellWidth - Shape.Width
OffsetLR = CellWidth - Shape.Width - CellWidth * Margin
End Select
Select Case PositionUD
Case "上"
' OffsetUD = 0
OffsetUD = CellHeight * Margin
Case "中央"
' OffsetUD = CellHeight / 2 - Shape.Height / 2
OffsetUD = CellHeight / 2 - Shape.Height / 2
Case "下"
' OffsetUD = CellHeight - Shape.Height
OffsetUD = CellHeight - Shape.Height - CellHeight * Margin
End Select
'画像の位置設定
With Shape
.Top = Cell.Top + OffsetUD
.Left = Cell.Left + OffsetLR
End With
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment