小花鹿学习VBA记录

小花鹿

Sub test()
Dim s, D, W
Set D = CreateObject("HTMLFILE")
Set W = D.parentWindow
D.write "<Script></Script>"
With ThisDocument.Range(0, 0).Find
    Do While .Execute("[0-9＋－+-]{1,}=", , , 1)
        .Parent.Select
        s = .Parent.Text
        s = W.eval(Replace(Replace(Replace(s, "=", ""), "＋", "+"), "－", "-"))
        .Parent.Collapse 0
        .Parent.Select
        .Parent.Text = s
        .Parent.Collapse 0
    Loop
End With
End Sub
'-------------------------------------------------------------------------------------------
Sub test()
Dim s
s = "(34+23)+2*3"
MsgBox valu(s)
End Sub
Function valu(s)
    Dim D, W
    Set D = CreateObject("HTMLFILE")
    Set W = D.parentWindow
    D.write "<Script></Script>"
    valu = W.eval(s)
End Function
ToEmail.rar (205.74 KB, 下载次数: 17)

2017-7-17 08:59 上传

点击文件名下载附件

小花鹿

自动生成二维码： 自动生成二维码.rar (31.33 KB, 下载次数: 26)

2017-9-17 15:46 上传

点击文件名下载附件

小花鹿

Option Explicit
Public ds As Boolean, sj

Sub 全屏显示()
Dim myxls As Workbook, mypath, ar, r&, i&, t, r1&, myname, conn, sql
mypath = ThisWorkbook.Path & "\"
myname = "数据表格.xlsx"
Call RealFullScreen
100:
Application.Goto Cells(4, "g")
Range("a4:n9999").ClearContents
Range("a4:n9999").Interior.Color = xlNone
Range("c5") = "正在更新数据，请稍候……"
Range("c5").Font.Color = RGB(255, 0, 0)
Application.Wait (Now + TimeValue("00:00:02"))
'------------------------------------------------------------------------
Set conn = CreateObject("adodb.connection")
conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;hdr=no';data source=" & mypath & myname
sql = "select * from [Sheet1$A4:N9999]"
Range("a4").CopyFromRecordset conn.Execute(sql)
conn.Close
'------------------------------------------------------------------------
Range("c5").Font.ColorIndex = xlAutomatic
t = TimeValue("00:00:01")
r = [a65536].End(3).Row
ds = False
sj = Now()
For i = 4 To r
    Call 延时
    Application.Goto Cells(i, "g")
    Range("a4:n" & r).Interior.Color = xlNone
    Range("a" & i & ":n" & i).Interior.Color = RGB(255, 0, 0)
    DoEvents
    If i = r Then
        Call 延时
        Application.Goto Cells(i + 1, "g")
        Call 延时
        Application.Goto Cells(i + 2, "g")
    End If
    If i = r Then i = 3
    If ds = True Then
        Range("a4:n" & r).Interior.Color = xlNone
        Exit Sub
    End If
   
    If Now() > sj + TimeValue("00:00:40") Then GoTo 100
Next i
End Sub

'-------------------------------------------------------------------------------------------------------------------
Sub RealFullScreen()
Worksheets("Sheet1").Activate
    With Application
        .DisplayFullScreen = True
        .CommandBars(1).Enabled = False
        .CommandBars("Full Screen").Controls(1).OnAction = "RestoreWindow"
    End With
    With ActiveWindow
        .DisplayHeadings = True
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
        .DisplayWorkbookTabs = False
    End With
End Sub

Sub RestoreWindow()
    With Application
        .DisplayFullScreen = False
        .CommandBars(1).Enabled = True
        .CommandBars("Full Screen").Reset
    End With
    With ActiveWindow
        .DisplayHeadings = True
        .DisplayHorizontalScrollBar = True
        .DisplayVerticalScrollBar = True
        .DisplayWorkbookTabs = True
    End With
End Sub
'-------------------------------------------------------------------------------------------------------------------

Sub 退出全屏()
ds = True
Call RestoreWindow
End Sub

'--------------------------------------------------------------------------------------------------------------------
Sub 延时()
Dim ar, i&, t
t = Timer
For i = 1 To 90000
    ar = Cells(1, 1)
Next i
End Sub

小花鹿

代码操作代码：
Sub 增加模块()
Dim i&
For i = 1 To 9
    Workbooks("1.xlsm").VBProject.VBComponents.Add(1).Name = "我的模块" & i
Next i
End Sub
Sub 删除模块()
Dim vbCmp
For Each vbCmp In Workbooks("1.xlsm").VBProject.VBComponents
    MsgBox vbCmp.Type
    MsgBox vbCmp.Name
    If vbCmp.Type = 1 Then Workbooks("1.xlsm").VBProject.VBComponents.Remove vbCmp '1代表模块
    If vbCmp.Type = 3 Then Workbooks("1.xlsm").VBProject.VBComponents.Remove vbCmp '3代表窗体
Next vbCmp
End Sub
Sub 在模块中插入代码()
Workbooks("1.xlsm").VBProject.VBComponents("我的模块1").CodeModule.AddFromString _
   "sub aTest()" & Chr(10) & _
   "msgbox ""Hello""" & Chr(10) & _
   "end sub"
End Sub
Sub 在模块指定行处插入代码()
With Workbooks("1.xlsm").VBProject.VBComponents("我的模块1").CodeModule
    .InsertLines 4, "msgbox ""Hello vba"""
  End With
End Sub
......
其他内容详见：http://club.excelhome.net/thread-191823-1-1.html

小花鹿

Sub shshi()
    Dim conn As Object, rst As Object, sql$, strConn$
    Set conn = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
    If Application.Version * 1 <= 11 Then
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;data source="
    ElseIf Application.Version * 1 >= 12 Then
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source="
    End If
    conn.Open strConn & ThisWorkbook.FullName
    sql = "select 签约单号,sum(总金额) from [sheet1$k1:l] where 总金额 is not null group by 签约单号"
    Set rst = conn.Execute(sql)
    Range("i2").CopyFromRecordset rst
End Sub



Sub Test4()
    Dim Conn As Object, Rst As Object
    Dim strConn As String, strSQL As String
    Dim i As Integer, PathStr As String
    Set Conn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
    PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
    Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
    Case Is <= 11
        strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    Case Is >= 12
        strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    End Select
    '设置SQL查询语句
    strSQL = "Select Distinct 用户姓名,用户卡号 From [sheet1$]"
    Conn.Open strConn    '打开数据库链接
    Set Rst = Conn.Execute(strSQL)    '执行查询，并将结果输出到记录集对象
    With Sheet3
        .Cells.Clear
        For i = 0 To Rst.Fields.Count - 1    '填写标题
            .Cells(1, i + 1) = Rst.Fields(i).Name
        Next i
        .Range("A2").CopyFromRecordset Rst
        .Cells.EntireColumn.AutoFit  '自动调整列宽
        .Cells.EntireColumn.AutoFit  '自动调整列宽
    End With
    Rst.Close    '关闭数据库连接
    Conn.Close
    Set Conn = Nothing
    Set Rst = Nothing
End Sub

凤翔时代

小花鹿 发表于 2014-10-6 11:12
自定义排序：
Sub Macro2()
Dim i, ar

请教老师，能否不显示辅助列而直接按单元格内字节数大小进行排序，或者辅助列在排序完成后就替换为空，正在找这种案例，谢谢

凤翔时代

小花鹿 发表于 2017-4-23 11:49
Option Explicit

Dim Darging, M As Boolean, Dt As Long, strTmp As String, ar

请教老师，窗体调整目标及位置的附件解压密码是什么？谢谢

小花鹿

Sub 按钮单击()
Dim s
s = Application.Caller
MsgBox Application.Caller
MsgBox Application.Left
MsgBox Range("b2").Left
MsgBox Sheet1.Shapes(s).TopLeftCell.Address
End Sub
http://club.excelhome.net/forum.php?mod=viewthread&tid=251648


Sub test()
Dim rng0, rng1
Set rng0 = Sheet1.[a65536].End(3)
Application.Goto Range("a4")
Do
    ActiveWindow.LargeScroll down:=1
    Set rng1 = ActiveWindow.VisibleRange
    rng1.Select
    If Not Intersect(rng0, rng1) Is Nothing Then
        Application.Goto Range("a4")
    End If
Loop
End Sub

小花鹿

Sub savejpg()
    Dim m&, mc$, shp As Shape
    Dim nm$, n&, myFolder$
    Dim w, h, w1, h1
    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") & ".jpg"
            shp.CopyPicture
            With ActiveSheet.ChartObjects.Add(0, 0, w1, h1).Chart
                .Paste
                .Export myFolder & nm, "JPG"
                .Parent.Delete
            End With
            shp.Width = w
            shp.Height = h
        End If
    Next
End Sub

小花鹿

以下代码来自本论坛：
Sub test()
Dim shp As InlineShape, pic
For Each shp In ActiveDocument.InlineShapes
    shp.ScaleHeight = 100
    shp.ScaleWidth = 100
    shp.Select
    Selection.Copy
    pic = CliptoJPG(ThisDocument.Path & "\test.jpg")
Next shp
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
Sub test()
    Select Case CliptoJPG("c:\test.jpg")
        Case 0:
            MsgBox "剪贴板图片已保存"
        Case 1:
            MsgBox "剪贴板图片保存失败"
        Case 2:
            MsgBox "剪贴板中无图片"
        Case 3:
            MsgBox "剪贴板无法打开，可能被其他程序所占用"
    End Select
End Sub
Private Function CliptoJPG(ByVal destfilename As String, 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("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), 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
    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") & ".jpg"
            shp.Copy
            endn = CliptoJPG(myFolder & nm)
            shp.Width = w
            shp.Height = h
        End If
    Next
End Sub