小花鹿学习VBA记录

小花鹿

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

小花鹿

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

小花鹿

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

小花鹿

汉字转拼音首字母，自定义函数:
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

小花鹿

答案查询小工具：

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

2018-12-25 13:17 上传

点击文件名下载附件

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

小花鹿

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)

2019-3-27 22:43 上传

点击文件名下载附件