ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索

收集的各类资料

已有 5163 次阅读2014-8-15 19:31 | 资料

一、表格内插入图片并修改大小

1、方式一

Dim photo As Picture
Set photo = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\
学生相片\" & sFile & ".jpg")
With photo
  .Name = sFile
  .ShapeRange.LockAspectRatio = msoFalse
  .Top = rng.Top
  .Left = rng.Left + 15
  .Width = 71
  .Height = 99
End With

2、方式二

Sub zf()
On Error Resume Next
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
Dim i%
Dim MR As Range

For Each MR In Range("C2:h" & 5)
If Not IsEmpty(MR) Then
 MR.Select
 ML = MR.Left + 4
 MT = MR.Top + 4
 MW = MR.Width * 0.9
 MH = MR.Height * 0.9
  ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
 Selection.ShapeRange.Fill.UserPicture _
 ActiveWorkbook.Path & "\
图片\" & MR.Value &  ".jpg" '当前文件所在目录下以当前单元内容为名称的.jpg图片
End If
Next
Application.ScreenUpdating = True

End Sub

二、ScrollArea 锁屏

A1 样式的区域引用形式返回或设置允许滚动的区域。用户不能选定滚动区域之外的单元格。String 类型,可读写。

说明:
可将本属性设置为空字符串 ("") 以允许对整张工作表内所有单元格的选定。

Excel VBA教程:ScrollArea属性·示例,本示例设置第一张工作表的滚动区域。

Worksheets(1).ScrollArea = "a1:f10"

 

三、VBA commandbars
worksheet menu bar
表示工作表菜单栏,
Application.CommandBars("worksheet menu bar").Enabled = False

formatting表示格式工具栏
Application.CommandBars("Formatting").Visible = False

standard表示常用工具栏
Application.CommandBars("Standard").Visible = falsae

'drawing表示绘图工具栏
Application.CommandBars("Drawing").Visible = False

'control toolbox表示控件工具箱
Application.CommandBars("Control Toolbox").Visible = False

'reviewing表示审阅工具
Application.CommandBars("Reviewing").Visible = False

Application.CommandBars("金山快译").Visible = False

'dispalyformulabar表示编辑栏
Application.DisplayFormulaBar = False

Application.CommandBars("Visual Basic").Visible = False

Application.CommandBars("Web").Visible = False

Application.CommandBars("Protection").Visible = False

Application.CommandBars("Borders").Visible = False

Application.CommandBars("Forms").Visible = False

Application.CommandBars("Formula Auditing").Visible = False

Application.CommandBars("Watch Window").Visible = False

'pivottable表示数据透视表
Application.CommandBars("PivotTable").Visible = False

'chart表示图表
Application.CommandBars("Chart").Visible = False

'picture表示图片
Application.CommandBars("Picture").Visible = False

Application.CommandBars("Exit Design Mode").Visible = False

'external data表示外部数据
Application.CommandBars("External Data").Visible = False

Dim aa, bb As Boolean
aa = True
bb = False
Application.CommandBars("ply").Enabled = aa
'
右键点工作表标签是否可用
Application.CommandBars("cell").Enabled = aa
'
右键点单元格是否可用
Application.CommandBars("toolbar list").Enabled = aa
'
右键点工具栏及视图工具栏是否可用
Application.CommandBars("autocalculate").Enabled = aa
'
右键点状态栏是否可用
Application.CommandBars("worksheet menu bar").Enabled = aa
Application.CommandBars(1).Enabled = aa
'
以上两句的作用都是把菜单取消
Application.CommandBars(2).Enabled = aa
'
暂时未知
Application.CommandBars(3).Enabled = aa
'
常用工具栏是否可用
Application.CommandBars(3).Controls(3).Enabled = aa
'
使常用工具栏中第三个保存是否可用
Application.CommandBars(4).Enabled = aa
'
格式工具栏是否可用
Application.CommandBars(5).Enabled = aa
'
暂时未知
Application.CommandBars(1).Enabled = aa
'
恢复菜单可用
Application.CommandBars(1).Controls(1).Enabled = aa
'
使菜单中的文件是否可用
Application.CommandBars("file").Controls("
页面设置(&U)...").Enabled = aa
'
菜单中的文件中的页面设置是否可用
Application.CommandBars(1).Controls(4).Enabled = aa
'
菜单中的第四个插入是否可用
Application.CommandBars(1).Controls(4).Caption = "victor"
'
更改名称
Application.CommandBars(1).Reset
'
恢复菜单
Application.DisplayFormulaBar = aa
'
编辑栏是否显示
Application.DisplayStatusBar = aa
'
状态栏是否显示
ActiveWindow.DisplayHeadings = aa
'
行号列标是否显示
ActiveWindow.DisplayWorkbookTabs = aa
'
工作表标签是否显示
ActiveWindow.DisplayHorizontalScrollBar = aa
'
水平滚动条是否显示
ActiveWindow.DisplayVerticalScrollBar = aa
'
垂直滚动条是否显示

四、SMALL函数的语法是:SMALL(array,k)

  SMALL函数的参数说明:
  第一,Array:为需要找到第 k 个最小值的数组或数字型数据区域。
  第二,K:为返回的数据在数组或数据区域里的位置(从小到大)。

ExcelSMALL函数和LARGE函数是一对相反的函数,都是属于excel的排名函数,SMALL函数是返回排名从小到大的值,LARGE函数是返回排名从大到小的值。

五、不连续单元格for循环赋值,使用数组

For Each i In Array(1, 2, 7, 8, 12, 15, 19)
Cells(2, i) = Cells(1, i)

Next

六、对宏模块代码的操作

VBProject:代码操作代码之常用语句
一、增加模块

1
.增加一个模块,命名为我的模块

ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule).Name = "
我的模块
"
系统常量
vbext_ct_StdModule=1
2
.增加一个类模块,命名为我的类

ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_ClassModule).Name = "
我的类
"
vbext_ct_ClassModule=2
3
.增加一个窗体,命名为我的窗体

ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm).Name = "
我的窗体
"
vbext_ct_MSForm=3
二、删除模块

1
.删除模块
1”
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents("
模块
1")
2
.删除窗体
“UserForm1”
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents("UserForm1")

3
.删除类模块
1”
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents("
1")

4.
删除所有的窗体

Sub RmvForms()
Dim vbCmp As VBComponent
For Each vbCmp In ThisWorkbook.VBProject.VBComponents
If vbCmp.Type = vbext_ct_MSForm Then ThisWorkbook.VBProject.VBComponents.Remove vbCmp
Next vbCmp

End Sub
相关:

工作表和ThisWorkbook的模块类型为
vbext_ct_Document=100
三、增加代码

1.
模块1”中插入代码

如果需要在“Sheet1”“Thisworkbook”、或“Userform1”中操作,用只需将下面的模块1”换成相应的名称即可。

方法1

在模块的开始增加代码,增加的代码放在公共声明option,全局变量等后面。

Sub AddCode1()
ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.AddFromString _
"sub aTest()" & Chr(10) & _
"msgbox ""Hello""" & Chr(10) & _
"end sub"
End Sub
方法2

在模块指定行处增加代码,原代码后移。增加代码不理会和判断插入处代码的内容。当指定行大于最后一行行号时,在最后一行的后面插入。

Sub AddCode2()
With ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule
.InsertLines 1, "sub aTest()"
.InsertLines 2, "msgbox ""Hello"""
.InsertLines 3, "end sub"
End With
End Sub

相关语句:

(1)“
模块1”中代码总行数:

ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.CountOfLines
(2)“
模块1”中代码公共声明部分的行数:

ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.CountOfDeclarationLines
(3)
显示模块1”中第1行起的3行代码内容:

Sub ShowCodes()
Dim s$
s = ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.Lines(1, 3)
Debug.Print s
End Sub
(4)
过程aTest的起始行数:

ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.ProcBodyLine("aTest", vbext_pk_Proc)
ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.ProcStartLine("aTest", 0)
系统常量
vbext_pk_Proc=0
二者的区别是ProcBodyLine返回sub aTestFunction aTest所在的行号,如果sub前面有空行,ProcStartLine返回空行的行号。

(5)
过程aTest的总行数:

ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.ProcCountLines("aTest", vbext_pk_Proc)
2.
建立事件过程

建立事件过程除了使用上面的代码如下面的AddEventsCode1外,还可以使用CreateEventProc方法,如AddEventsCode2所示。

一般方法:

Sub AddEventsCode1()
ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.AddFromString _
"Private Sub Workbook_Open()" & Chr(13) & _
"MsgBox ""Hello""" & Chr(13) & _
"End Sub"
End Sub
CreateEventProc
方法:

Sub AddEventsCode2()
Dim i%
With ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
i = .CreateEventProc("SelectionChange", "Worksheet") + 1
.InsertLines i, "Msgbox ""Hello"""
End With
End Sub
上面CreateEventProc的两个参数建立的事件过程为Worksheet_SelectionChange,分别是下划线两边的内容。

相关:

测试是否存在SelectionChange事件

下面函数测试模块modulname是否存在过程subname,如果存在,则返回起始行号,否则返回0

debug.print hassub("Worksheet_SelectionChange","Sheet1")
Function HasSub(ByVal subname As String, ByVal modulname As String) As Long
On Error Resume Next
Dim i&
i = ThisWorkbook.VBProject.VBComponents(modulname).CodeModule.ProcBodyLine(subname, 0)
If Err.Number = 35 Then
Err.Clear
HasSub = 0
Else
HasSub = i
End If

End Function

如果存在,则返回起始行号,否则返回0


四、删除代码

1
.删除Sheet1中第2行起的三行代码:

如果只删除1行代码,第二个参数可省略。

Sub DelCodes()
ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule.DeleteLines 2, 3
End Sub
2
.删除模块1”的所有代码:

Sub DelCodes()
With ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule
.DeleteLines 1, .CountOfLines
End With
End Sub
3
.删除过程
aTest:
Sub DelCodes()
With ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule
.DeleteLines . ProcStartLine("aTest", 0), .ProcCountLines("aTest", 0)
End With
End Sub
4
.将模块1”的第5行代码替换为
“x=3”
ThisWorkbook.VBProject.VBComponents("
模块
1").CodeModule.ReplaceLine 5, "x=3"
五、引用项目

1
.增加引用

ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\System32\asctrls.ocx"
2
.取消引用

ThisWorkbook.VBProject.References.Remove ThisWorkbook.VBProject.References("ASControls")
这里ASControls是引用的名字,即后面的rf.Name

3
.显示当前所有引用

Sub ShowRefs()
Dim rf As VBIDE.Reference
For Each rf In ThisWorkbook.VBProject.References
Debug.Print rf.Name, rf.FullPath
Next
End Sub
六、信任及密码

上面所有操作都基于这样的前题:

1EXCEL已设置:

工具(T-宏(M-安全性(M-可靠发行商(T-勾选了信任对于VB项目的访问(V

2)工程没有设置密码

如果不能满足它们中的任何一个,代码运行就会出错。因为微软不希望我们对VBProject进行操作,我们无从知道这种操作的直接方法被藏到了什么地方。幸运的是,微软在关起正门的同时,还是为我们留了一道门:SendKeys。借助于这道后门和错误陷阱,我们仍可以完成我们所要做的事。


下面给出绕开这两道门的示意代码,如果你要运行它们,请记得切回EXCEL主界面,而不是在VBE中直接运行。


1
.信任对于VB项目的访问

Sub SetAllowableVbe()
On Error Resume Next
Dim Chgset As Boolean
'
陷阱测试,VBProject.Protection在这儿并无实际的意义

Debug.Print ThisWorkbook.VBProject.Protection
If Err.Number = 1004 Then
Err.Clear
Application.SendKeys "%TMS%T%V{ENTER}"
Chgset = True
DoEvents
End If
'
要执行的操作
....

'.....

'
操作完成后还原操作前的状态


If Chgset Then Application.SendKeys "%TMS%T%V{ENTER}"

End Sub
2
.操作密码工程

Sub AllowPass()
Dim pw$

pw = "Password"
If ThisWorkbook.VBProject.Protection = vbext_pp_locked Then
Application.VBE.CommandBars(1).Controls("
工具(T)").Controls("VBAProject 属性
(&E)...").Execute
Application.SendKeys pw & "{ENTER}{ENTER}"
DoEvents
End If
'
要执行的操作
….
End Sub
Protection
属性返回工程的受保护状态,vbext_pp_locked(1)为受保护,vbext_pp_none(0)表示没有保护。

 

 


路过

鸡蛋

鲜花

握手

雷人

发表评论 评论 (107 个评论)

回复 liulang0808 2014-10-11 11:46
增加按钮及其对应的代码
Sub 按钮1_单击()
'生成汇总各班信息按钮"d"程序
    Dim shp As Shape
    On Error Resume Next
    Sheet1.Shapes("addnew").Delete
    Set shp = Sheet1.Shapes.AddFormControl(0, 0, 0, 157, 36) '按钮位置、大小设置(左边距0, 上边距0, 0, 长157, 宽40)
    With shp
         .Name = "addnew" '生成按钮指定名称
         .OnAction = "清空各班数据" '执行程序"Sub 清空各班数据()对应代码"
         .TextFrame.Characters.Text = "清空各班数据" '按钮上显示的名称为“清空各班数据”
     End With
     ActiveSheet.Shapes("addnew").Select '生成按钮"D"(指定名)

    With Selection.Characters(Start:=1, Length:=15).Font 'Length:=15为控制字体个数
        .Name = "宋体"
        .FontStyle = "加粗"
        .Size = 18 '字体16号
        .ColorIndex = 3 '字体红色
    End With
End Sub

Sub 清空各班数据()
    MsgBox 1
End Sub
回复 liulang0808 2014-10-12 20:08
发声读取字符串
Application.Speech.Speak "A3 单元格有情况"
回复 liulang0808 2014-10-17 19:30
清空数组内容 Erase s(),清空数组s的内容
回复 liulang0808 2014-10-31 10:44
Shapes对象集合包含了自选图形、任意多边形、OLE对象、艺术字、文本框和图片对象等。如果只对图片进行调整,而忽略其他所有对象,那么需要修改代码如下:
Sub 统一图片高度2()
    Dim shap As Shape
    For Each shap In ActiveSheet.Shapes '遍历所有的图形对象
        If shap.Type = 13 Then '增加图片类型的判断
            shap.Height = 80 '统一图片高度
            shap.Left = shap.TopLeftCell.Left '将每个图片对齐它左上角的单元格左边线
            shap.Top = shap.TopLeftCell.Top '将每个图片对齐它左上角的单元格上边线
        End If
    Next shap
End Sub
回复 liulang0808 2014-11-15 11:12
Transpose 只支持65536数据
回复 liulang0808 2014-11-27 20:48
Set b = Workbooks.Open("C:\急.xls")

    b.Windows(1).WindowState = xlMinimized
调整打开的工作簿到最小状态
回复 liulang0808 2014-12-10 19:21
For i = 7 To 50
Sheets("会员管理").Cells(MYRANGE.Row, i + 1) = (Me.Controls("TEXTBOX" & i))
Next i
遍历窗体控件
回复 liulang0808 2014-12-14 12:19
至于其他类型的编码,我想,只要你熟悉循环和文本函数,再了解下vba里的hex,asc,chr,ascw,chrw,总能写出自定义的转码函数的
hex(asc("一"))="D2BB",16进制。。。。。

Function GBKEnCode(strText)

    Dim i, s

    For i = 1 To Len(strText)

        s = Hex(Asc(Mid(strText, i, 1)))

        If Len(s) = 4 Then s = Left(s, 2) & "%" & Right(s, 2)

        GBKEnCode = GBKEnCode & "%" & s

    Next

End Function
回复 liulang0808 2014-12-14 20:09
读取整个文本文件内容
s = StrConv(InputB(LOF(1), 1), vbUnicode)

arr = Split(s, vbCrLf)
回复 liulang0808 2014-12-17 10:54
/,\,*,?,[]    不能用于工作簿的表名
回复 liulang0808 2014-12-20 18:37
添加菜单
Dim mCaidan As Menu
MenuBars(xlWorksheet).Reset
Set mCaidan = MenuBars(xlWorksheet).Menus.Add("订单录入")
With mCaidan.MenuItems
.Add "数据导入", "表"
.Add "计算确认", "录入确认"
End With
回复 liulang0808 2014-12-22 20:17
Private Sub Workbook_Open()

     Set myMenu = Application.CommandBars("worksheet menu bar")
     Set Button = myMenu.Controls.Add(Type:=msoControlButton)
     Button.Caption = "Caption"            '按钮上的文字,填写你需要的
     Button.Style = msoButtonIconAndCaption
     Button.FaceId = FaceId                  '按钮图标,数字比如8,系统存在的
     Button.OnAction = "OnAction"       '按钮执行的宏名,填写你自己的宏名

End Sub
回复 liulang0808 2014-12-29 19:11
插入图片
http://club.excelhome.net/forum.php?mod=redirect&goto=findpost&ptid=1176048&pid=8018229

Sub zf()
    On Error Resume Next
    Application.ScreenUpdating = False
    ActiveSheet.DrawingObjects.Delete
    Dim i%
    Dim MR As Range

    For Each MR In Range("C2:h" & 5)
        If Not IsEmpty(MR) And MR <> &quot;无&quot; Then
            MR.Select
            ML = MR.Left + 4
            MT = MR.Top + 4
            MW = MR.Width * 0.9
            MH = MR.Height * 0.9
            ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
            Selection.ShapeRange.Fill.UserPicture _
            ActiveWorkbook.Path & &quot;\图片\&quot; & MR.Value & &quot;.jpg&quot;     '当前文件所在目录下以当前单元内容为名称的.jpg图片
        End If
    Next
    Application.ScreenUpdating = True
End Sub
回复 liulang0808 2015-1-5 20:43
数字转汉字
WorksheetFunction.Text(a, "[dbnum1]")
回复 liulang0808 2015-1-12 21:12
修改文件名
Name MyPath & arr(i, 1) & ".jpg" As MyPath & arr(i, 2) & ".jpg"
回复 liulang0808 2015-1-15 19:27
语句Application.Goto rng, True的作用是将窗口滚动至该单元格,即该单元格位于当前窗口的左上方
回复 liulang0808 2015-1-17 17:16
Range(&quot;a1:a10&quot;).Sort Key1:=Range(&quot;a1&quot;), Order1:=xlAscEnding
回复 liulang0808 2015-3-6 20:06
批注的处理
    With Range("F2")
        .ClearComments
        .AddComment
        .Comment.Visible = True
        .Comment.Text Text:="事故00"
        .Comment.Shape.TextFrame.Characters(1, 4).Font.Size = 55
        .Comment.Shape.TextFrame.AutoSize = True
    End With
回复 liulang0808 2015-3-7 14:05
判断单元格时候有批注:If rg.Cells.Comment Is Nothing Then
回复 liulang0808 2015-3-18 15:01
合并单元格的行列数及单元格个数
Sub test()
    r = ActiveCell.Offset(1).Row - ActiveCell.Row
    c = ActiveCell.Offset(, 1).Column - ActiveCell.Column
    m = r * c
   
    n = ActiveCell.MergeArea.Count
    rw = ActiveCell.MergeArea.Rows.Count
    cl = ActiveCell.MergeArea.Columns.Count
End Sub

facelist

您需要登录后才可以评论 登录 | 免费注册

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

GMT+8, 2024-3-28 17:13 , Processed in 0.038773 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

返回顶部