ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: 小花鹿

[讨论] 小花鹿学习VBA记录

  [复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-15 14:07 | 显示全部楼层
Sub savejpg()
    Dim m, mc, shp As Shape
    Dim nm, n&, mypath
    Dim w, h, w1, h1, myhtm
    Dim myxls As Workbook, thisbook, pic, pic1, psize
    Application.ScreenUpdating = False
    mypath = ThisWorkbook.Path & "\"
    If Len(Dir(mypath & "图片", vbDirectory)) = 0 Then
        MkDir mypath & "图片"
    End If
    Set thisbook = ThisWorkbook
    Set myxls = Workbooks.Add
    myhtm = "htm" & Format(Time, "hhmmss")
    myxls.SaveAs Filename:=mypath & myhtm & ".htm", FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
    For Each shp In thisbook.ActiveSheet.Shapes
        If shp.type = 13 Then
            w = shp.Width
            h = shp.Height
            shp.ScaleHeight 1, True
            shp.ScaleWidth 1, True
            w1 = shp.Width
            h1 = shp.Height
            n = n + 1
            m = shp.TopLeftCell.Row
            mc = thisbook.ActiveSheet.Cells(m, 2).Value
            nm = mc & "-" & Format(n, "00")
            '------------------------------------------------
            shp.Copy
            myxls.ActiveSheet.Paste
            myxls.Save
            psize = 0
            pic1 = Dir(mypath & myhtm & ".files\image*.*")
            Do While pic1 <> ""
                If FileLen(mypath & myhtm & ".files\" & pic1) > psize Then
                    pic = pic1
                    psize = FileLen(mypath & myhtm & ".files\" & pic1)
                End If
                pic1 = Dir
            Loop
            On Error Resume Next
            Name mypath & myhtm & ".files\" & pic As mypath & "图片\" & nm & "." & Split(pic, ".")(1)
            On Error GoTo 0
            myxls.ActiveSheet.Shapes(1).Delete
            '----------------------------------------------------
            shp.Width = w
            shp.Height = h
        End If
    Next
    myxls.Close 0
    Kill mypath & myhtm & ".htm"
    Kill mypath & myhtm & ".files\*.*"
    RmDir mypath & myhtm & ".files"
    Application.ScreenUpdating = True
    MsgBox "The End"
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-1-15 14:09 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Function CliptoJPG(ByVal destfilename As String, geshi, Optional ByVal quality As Byte = 100) As Integer
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    Dim hBmp As Long
    If OpenClipboard(0) Then
        hBmp = GetClipboardData(CF_BITMAP)
        If hBmp = 0 Then
            CliptoJPG = 2
            CloseClipboard
            Exit Function
        End If
        CloseClipboard
    Else
        CliptoJPG = 3
        Exit Function
    End If
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
    If lRes = 0 Then
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            CLSIDFromString StrPtr(geshi), tJpgEncoder
            tParams.Count = 1
            With tParams.Parameter
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(quality)
            End With
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
            If lRes = 0 Then
                CliptoJPG = 0
            Else
                CliptoJPG = 1
            End If
            GdipDisposeImage lBitmap
        End If
        GdiplusShutdown lGDIP
    End If
End Function
Sub savejpg()
    Dim m&, mc, shp As Shape
    Dim nm, n&, myFolder
    Dim w, h, w1, h1, endn
    Dim picarr(1 To 5, 1 To 2)
    picarr(1, 1) = "{557CF401-1A04-11D3-9A73-0000F81EF32E}": picarr(1, 2) = ".JPG"
    picarr(2, 1) = "{557CF400-1A04-11D3-9A73-0000F81EF32E}": picarr(2, 2) = ".BMP"
    picarr(3, 1) = "{557CF406-1A04-11D3-9A73-0000F81EF32E}": picarr(3, 2) = ".PNG"
    picarr(4, 1) = "{557CF402-1A04-11D3-9A73-0000F81EF32E}": picarr(4, 2) = ".GIF"
    picarr(5, 1) = "{557CF405-1A04-11D3-9A73-0000F81EF32E}": picarr(5, 2) = ".TIF"
    myFolder = ThisWorkbook.Path & "\图片\"
    If Len(Dir(myFolder, vbDirectory)) = 0 Then
        MkDir myFolder
    End If
    For Each shp In ActiveSheet.Shapes
        If shp.type = 13 Then
            w = shp.Width
            h = shp.Height
            shp.ScaleHeight 1, True
            shp.ScaleWidth 1, True
            w1 = shp.Width
            h1 = shp.Height
            n = n + 1
            m = shp.TopLeftCell.Row
            mc = Cells(m, 2).Value
            nm = mc & "-" & Format(n, "00")
            shp.Select
            Selection.Copy
            endn = CliptoJPG(myFolder & nm & picarr(3, 2), picarr(3, 1))
            shp.Width = w
            shp.Height = h
        End If
    Next
    MsgBox "The End"
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-9 21:05 | 显示全部楼层
Private Sub TextBox5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim r&
If KeyCode = 13 Then
    KeyCode = 0
    r = [a65536].End(3).Row + 1
    Cells(r, 1) = TextBox5
    TextBox5.SelStart = 0
    TextBox5.SelLength = Len(UserForm1.TextBox5.Text)
End If
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-28 21:11 | 显示全部楼层
汉字转拼音首字母,自定义函数:
Function Py$(ByVal rng$)
    Dim i%, pyArr, str$, ch$
    pyArr = [{"吖","A";"八","B";"攃","C";"咑","D";"妸","E";"发","F";"旮","G";"哈","H";"丌","J";"咔","K";"垃","L";"妈","M";"乸","N";"噢","O";"帊","P";"七","Q";"冄","R";"仨","S";"他","T";"屲","W";"夕","X";"丫","Y";"帀","Z"}]
    str = Replace(Replace(rng, " ", ""), " ", "")          '去空格和Tab
    For i = 1 To Len(str)
        ch = Mid(str, i, 1)
        If ch Like "[一-龥]" Then   '如果是汉字,进行转换
            Py = Py & WorksheetFunction.Lookup(Mid(str, i, 1), pyArr)
        Else
            'Py = Py & UCase(ch)     '如果不是汉字,直接输出
        End If
    Next
End Function原帖地址:http://club.excelhome.net/thread-1422261-1-1.html

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-12-25 13:21 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
答案查询小工具: 2018-12-25_132110.png

2018泰安普法考试题查询32.rar (152.58 KB, 下载次数: 12)

如果需要,可以直接下载,无需回复。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-3-27 22:43 | 显示全部楼层
本帖最后由 小花鹿 于 2019-4-4 20:07 编辑

Sub 查找替换()
Dim fd, s1, s2 As Boolean, s3, t
t = Timer
Application.ScreenUpdating = False
Call DelOrRep
fd = "^.*?(?=[\u4e00-\u9fa5\w])"  '查找内容
s1 = ""                           '替换前缀
s2 = 0                            '替换时是否包含查找内容,0不包含1包含
s3 = ""                           '替换后缀
Call SubProgram(fd, s1, s2, s3)
'--------------------------------------------------------------------------
fd = "[A-F][、::..]|参考答案.{0,3}[::]|答案.{0,3}[::]"  '查找内容
s1 = Chr(13)                           '替换前缀
s2 = 1                            '替换时是否包含查找内容,0不包含1包含
s3 = ""                           '替换后缀
Call SubProgram(fd, s1, s2, s3)
'--------------------------------------------------------------------------
fd = "^\d.*?(单选题|多选题)"  '查找内容
s1 = ""                           '替换前缀
s2 = 1                            '替换时是否包含查找内容,0不包含1包含
s3 = "小花鹿"                           '替换后缀
Call SubProgram(fd, s1, s2, s3)
'--------------------------------------------------------------------------
fd = "(单选题|多选题)小花鹿"  '查找内容
s1 = ""                           '替换前缀
s2 = 0                            '替换时是否包含查找内容,0不包含1包含
s3 = ""                           '替换后缀
Call SubProgram(fd, s1, s2, s3)
'----------------------------------------------------------------------
Call DelOrRep
Call DelRow
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

Sub SubProgram(fd, s1, s2, s3)
    Dim col As New Collection, k&, tm$
    Dim para As Paragraph, j&, r&, mt, oRang As Range, n%, m%
    With CreateObject("vbscript.regexp")
        .Pattern = fd
        .Global = True
        .IgnoreCase = False
        .MultiLine = True
        For Each para In ActiveDocument.Paragraphs
            For Each mt In .Execute(para.Range.Text)
                k = k + 1
                m = mt.FirstIndex
                n = mt.Length
                Set oRang = ActiveDocument.Range(para.Range.Start + m, para.Range.Start + m + n)
                col.Add oRang, CStr(k)
            Next
        Next
    End With
    For j = 1 To col.Count
        If s2 <> 0 Then tm = col(j)
        col(j) = s1 & tm & s3 '替换为字符(根据自己需要)
    Next
End Sub
Sub DelOrRep()
    With ActiveDocument.Content.Find
        .Execute "^11", , , 1, , , , 0, , "^p", 2        '软回车变为硬回车
        .Execute "^13", , , 1, , , , 0, , "^p", 2        '有时光标可移到硬回车后面,可用这种方法解决
        .Execute "^p^w", , , 0, , , , 0, , "^p", 2       '删除段前空白
        .Execute "^w^p", , , 0, , , , 0, , "^p", 2       '删除段后空白
        .Execute "^13{1,}", , , 1, , , , 0, , "^p", 2    '删除空行
    End With
End Sub

Sub DelRow()
Dim i&, reg, s
Set reg = CreateObject("vbscript.regexp")
reg.Pattern = "^[0-9]+[、::..]|^[A-F][、::..]|^.{0,4}答案"
s = ActiveDocument.Range.Text
s = Split(s, Chr(13))
With ActiveDocument
    For i = UBound(s) - 1 To 0 Step -1
        If Not reg.test(s(i)) Then
            .Paragraphs(i + 1).Range.Delete
        End If
    Next i
End With
End Sub


试题整理综合.rar (69.02 KB, 下载次数: 12)

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 07:05 , Processed in 0.039252 second(s), 6 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表