将bmp位图贴到excel中的一段VB代码

最新推荐文章于 2024-04-23 22:41:04 发布

zhongyuanceshi

最新推荐文章于 2024-04-23 22:41:04 发布

阅读量1.3k

点赞数

文章标签： excel vb string hex function c

本文链接：https://blog.csdn.net/zhongyuanceshi/article/details/4129954

版权

Function DEX2HEX(dec, places)

Dim hexarr(16) As String
hexarr(0) = "0"
hexarr(1) = "1"
hexarr(2) = "2"
hexarr(3) = "3"
hexarr(4) = "4"
hexarr(5) = "5"
hexarr(6) = "6"
hexarr(7) = "7"
hexarr(8) = "8"
hexarr(9) = "9"
hexarr(10) = "A"
hexarr(11) = "B"
hexarr(12) = "C"
hexarr(13) = "D"
hexarr(14) = "E"
hexarr(15) = "F"

Dim result As String
Dim tmp As Long

tmp = dec
For i = 1 To places Step 1
j = tmp Mod 16
tmp = tmp / 16
'If tmp < 16 Then
'result = "0" & result
'Else
result = Trim(hexarr(j)) & Trim(result)
'End If
Next i
DEX2HEX = result
End Function



Sub showFonts()
'
' 宏3 Macro
' spd-jxliu 记录的宏 2007-3-20
'

'   0x9401(37889) --0xfad9(64217)

    Dim num, code As Long
    Dim NameA, NameB, NameC, NameD, FileBig5, FileGb, FileKsc As String
    Dim unicode As String
    code = 22007
    For num = 2 To 65536 Step 1
    rowstr = Trim(Str(num)) & ":1"
    Rows(rowstr).RowHeight = 34
    unicode = DEX2HEX(code, 4)
    NameA = "A" & Trim(Str(num))
    Range(NameA).Select
    Selection.NumberFormatLocal = "@"
    ActiveCell.Value = unicode

    NameB = "B" & Trim(Str(num))
    Range(NameB).Select
    FileGBF = "C:/fonts/KH76字库/新增10个字中间Unicode码1/位图/16bmp1/" & unicode & ".bmp"
    havegbf = Dir(FileGBF)
    If (havegbf <> "") Then
    ActiveSheet.Pictures.Insert(FileGBF).Select
    Selection.ShapeRange.Height = 32
    Selection.ShapeRange.Width = 32
    Selection.ShapeRange.IncrementLeft 5
    Selection.ShapeRange.IncrementTop 1
    End If

'    NameC = "C" & Trim(Str(num))
'    Range(NameC).Select
'    FileJPNF = "D:/test/JAP_first/161/Ux_" & unicode & ".bmp"
'    havejpnf = Dir(FileJPNF)
'    If (havejpnf <> "") Then
'    ActiveSheet.Pictures.Insert(FileJPNF).Select
'    Selection.ShapeRange.Height = 32
'    Selection.ShapeRange.Width = 32
'    Selection.ShapeRange.IncrementLeft 5
'    Selection.ShapeRange.IncrementTop 1
'    End If


    If (havegbf = "" And havejpnf = "") Then
    num = num - 1
    End If
    code = code + 1

    If code > 41000 Then
    ActiveWorkbook.Save
    Exit For
    End If
' If num Mod 1000 = 0 Then
   ' ActiveWorkbook.Save
   ' End If
    Next num

End Sub