ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索

收集的各类资料

已有 4326 次阅读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)表示没有保护。

 

 


路过

鸡蛋

鲜花

握手

雷人

发表评论 评论 (86 个评论)

回复 liulang0808 2020-6-17 07:10
Private Sub 生成表格_Click()

Dim i, j, bound As Integer

j = 6
bound = Worksheets("人材机").Range("d65536").End(xlUp).Row

For i = 1 To bound Step 1
Cells(i, 4).FormatConditions(1).Interior.ColorIndex = 6 条件格式底色
回复 liulang0808 2020-7-7 06:45
For Each shp In ActiveSheet.Shapes
if instr(shp.TextFrame2.TextRange.Text,"ITEM NO") then shp.select:exit for
next
识别形状里的文字
回复 liulang0808 2020-8-2 10:36
Sub 破解工作表密码()
Dim a As Worksheet
For Each a In Worksheets
a.Protect AllowFiltering:=True
a.Unprotect
Next
End Sub
回复 liulang0808 2020-9-3 12:47
CreateObject("Shell.Application").Open ThisWorkbook.Path & "\" & Target.Value & ".docx"
打开文件
回复 liulang0808 2020-10-9 12:35
Sub 磁盘序列号()
    Dim 磁盘, 序列号
    Set 磁盘 = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_LogicalDisk")
    For Each mo In 磁盘
        If mo.VolumeSerialNumber <> "" Then 序列号 = 序列号 & "磁盘:" & mo.Name & vbCrLf & "卷的序列号:" & mo.VolumeSerialNumber & vbCrLf & vbCrLf
    Next
    MsgBox Left(序列号, Len(序列号) - 3)
End Sub
Sub 硬盘型号()
    Dim 硬盘
    Set 硬盘 = GetObject("Winmgmts:").InstancesOf("Win32_DiskDrive")
    For Each mo In 硬盘
        MsgBox "硬盘型号为:" & mo.Model
    Next
End Sub

需要注意操作系统是多少位的
回复 liulang0808 2020-11-7 11:44
Sub 单元格插入批注()
On Error Resume Next
Dim M As Range, fd, t
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
       t = fd.SelectedItems(1)
   Else
       Exit Sub
   End If
For Each M In Selection
  If Not IsEmpty(M) Then
   M.AddComment
   
   M.Comment.Shape.LockAspectRatio = msoTrue
   M.Comment.Shape.Height = 100
   M.Comment.Shape.Fill.UserPicture t & "\" & M.Text & ".jpg"
   End If
Next
End Sub
回复 liulang0808 2020-12-23 19:32
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker) '运行后出现标准的选择文件夹对话框        
        If .Show Then myPath = .SelectedItems(1) Else Exit Sub '如选中则返回=-1 / 取消未选则返回=0
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外,其余路径无""需要自己添加
End Sub
回复 liulang0808 2020-12-28 20:58
单元格里存放的是图片链接
    Dim z As Shape, e$, i%
    For i = 2 To 12
        e = Cells(i, 1)
        If e <> "" Then
            Set z = ActiveSheet.Shapes.AddPicture(e, False, True, Cells(i, 2).Left, Cells(i, 2).Top, Cells(i, 2).Width, Cells(i, 2).Height)
        End If
    Next
回复 liulang0808 2021-1-2 21:06
Sub test()
  Dim fls, f
  With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = ThisWorkbook.Path
    With .Filters
      .Clear
      .Add "Excel Files", "*.xls*"
    End With
    .AllowMultiSelect = True '多选
    If .Show Then Set fls = .SelectedItems Else Exit Sub
  End With
  Application.ScreenUpdating = False
  Dim s As String
  For Each f In fls
  
    s = f.Name
    Selection.InsertFile Filename:=(s), Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
  
  Next
  Application.ScreenUpdating = True
End Sub
选择多个文件
回复 liulang0808 2021-1-20 07:02
使用VBA打开任意的文件,。

Private Sub CommandButton1_Click()
Dim fulnm$
fulnm = Sheet1.Cells(1, 2).Value '这里是文件的Fullname.
Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler " & fulnm, vbMaximizedFocus
End Sub
回复 liulang0808 2021-1-28 08:01
MsgBox "当前电脑桌面地址是:" & Environ("USERPROFILE") & "\桌面"
回复 liulang0808 2021-3-11 07:00
'使用示例
Sub Test()
    Dim strFileName As String, rgPic As Range
   
    strFileName = "F:\Temp\相片\200180393.jpg"
   
    '在A1单元格等比缩放的方式,插入图片
    Set rgPic = Sheet3.Range("A1")
    If AddNewPic(strFileName, rgPic) Then
        MsgBox "插入图片成功"
    Else
        MsgBox "插入图片失败"
    End If
   
    '在C8单元格以原始比例,插入图片
    Set rgPic = Sheet3.Range("C8")
    AddNewPic strFileName, rgPic, False
   
    '在D5单元格 以全覆盖的方式 插入图片
    Set rgPic = Sheet3.Range("D5")
    AddNewPic strFileName, rgPic, True, False
   
End Sub

'在工作表中插入图片
'strFileName: 图片全路径名称
'rgPic: 图片要插入的单元格
'blZoom:图片是否缩放,默认为True
'blEqualProportion:是否等比缩放,默认为True
Function AddNewPic(strFileName As String, rgPic As Range, Optional blZoom As Boolean = True, Optional blEqualProportion As Boolean = True) As Boolean
    Dim sht As Worksheet
    Dim sngPic_Width As Single, sngPic_Heigth As Single, sngAspectRatio_Pic As Single '图片宽、高、宽高比
    Dim sngRg_Top As Single, sngRg_Left As Single, sngRg_width As Single, sngRg_Heigth As Single, sngAspectRatio_Rg As Single '单元格宽、高、宽高比
    Dim shp_Top As Single, shp_Left As Single, shp_Width As Single, shp_Height As Single '插入图片的大小及位置
    Dim sngScale As Single
   
    On Error GoTo ErrFun
   
    '读取图片的宽高比
    If GetPicInfo(strFileName, sngPic_Width, sngPic_Heigth) = False Then GoTo ErrFun
    sngAspectRatio_Pic = sngPic_Heigth / sngPic_Width
     '读取填充区域的宽高信息
    With rgPic
        Set sht = .Parent
        sngRg_Top = .MergeArea.Top
        sngRg_Left = .MergeArea.Left
        sngRg_width = .MergeArea.Width
        sngRg_Heigth = .MergeArea.Height
        sngAspectRatio_Rg = sngRg_Heigth / sngRg_width
    End With
    '计算缩放比例
    If sngAspectRatio_Rg > sngAspectRatio_Pic Then
        sngScale = sngRg_width / sngPic_Width
    Else
        sngScale = sngRg_Heigth / sngPic_Heigth
    End If
    '缩放
    If blZoom Then
        '等比
        If blEqualProportion Then
            shp_Width = sngPic_Width * sngScale
            shp_Height = sngPic_Heigth * sngScale
            shp_Top = sngRg_Top + (sngRg_Heigth - shp_Height) / 2
            shp_Left = sngRg_Left + (sngRg_width - shp_Width) / 2
        Else
        '不等比
            shp_Width = sngRg_width
            shp_Height = sngRg_Heigth
            shp_Top = sngRg_Top
            shp_Left = sngRg_Left
        End If
    Else
    '不缩放
        shp_Width = sngPic_Width
        shp_Height = sngPic_Heigth
        shp_Top = sngRg_Top
        shp_Left = sngRg_Left
    End If
    '添加图片
    With sht.Shapes.AddPicture(strFileName, msoFalse, msoTrue, shp_Left, shp_Top, shp_Width, shp_Height)
        .Name = "PIC-" & Format(Now, "YYMMDDHHMMSS")
    End With
    AddNewPic = True
    Set sht = Nothing
    Exit Function
ErrFun:
    AddNewPic = False
    Set sht = Nothing
End Function

'获取图片的长和宽
Function GetPicInfo(strFileName As String, ByRef Width As Single, ByRef Height As Single) As Boolean
    Dim objImg As Object
    On Error GoTo ExitFun
    Set objImg = CreateObject("WIA.ImageFile")
    objImg.LoadFile strFileName
    Width = objImg.Width: Height = objImg.Height
    GetPicInfo = True
    Set objImg = Nothing
    Exit Function
ExitFun:
    Set objImg = Nothing
    GetPicInfo = False
End Function
图片处理
回复 liulang0808 2021-4-10 21:36
With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文本文件"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt"
        If .Show Then f = .SelectedItems(1) Else Exit Sub '
    End With
回复 liulang0808 2021-4-11 09:12
数据写入剪切板

Sub CopyToClipbox(strText As String)
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText strText
        .PutInClipboard
    End With
End Sub
回复 liulang0808 2021-4-23 16:47
破解工作表保护密码:
Private nIDEvent As Long
Private Const WM_CLOSE = &H10
#If Win64 And VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
#End If
Private Sub lpTimerFunc()
    Dim hwnd As Long
    hwnd = FindWindow(bosa_sdm_XL9, "?????????????")
    If hwnd <> 0 Then SendMessage hwnd, WM_CLOSE, 0, 0
End Sub
Sub RemoveSheetProtectPassword()
    Dim sh As Worksheet
    SetTimer Application.hwnd, nIDEvent, 10, AddressOf lpTimerFunc
    For Each sh In ActiveWindow.SelectedSheets
        With sh
            .Protect , 1, 1, 1, AllowFiltering:=1, AllowUsingPivotTables:=1
            .Protect , 0, 1, 0, AllowFiltering:=1, AllowUsingPivotTables:=1
            .Protect , 1, 1, 0, AllowFiltering:=1, AllowUsingPivotTables:=1
            .Protect , 0, 1, 1, AllowFiltering:=1, AllowUsingPivotTables:=1
            .Unprotect
        End With
    Next
    KillTimer Application.hwnd, nIDEvent
End Sub
回复 liulang0808 2021-4-25 13:24
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, ByVal lpszParams As String, _
ByVal LpszDir As String, ByVal FsShowCmd As Long) _
As Long
Sub text()
  Dim myfile$, myname$
  myfile = ThisWorkbook.Path & ""
  myname = Dir(myfile & "*.pdf")
  Do While myname <> ""
    If myname <> ThisWorkbook.Name Then
       ShellExecute Application.hwnd, "print", myfile & myname, "", "", SW_hide
    End If
   myname = Dir
  Loop
End Sub

打印各类文件
回复 liulang0808 2021-4-30 07:51
选择文件夹,打开文件
Sub text()
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文本文件"
        .AllowMultiSelect = False
        If .Show Then f = .SelectedItems(1) Else Exit Sub '
    End With
    Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler " & f, vbMaximizedFocus

End Sub
回复 liulang0808 2021-4-30 12:28
取汉字拼音首字母

Function pinyin(p As String) As String
    i = Asc(p)
    Select Case i
    Case -20319 To -20284: pinyin = "A"
    Case -20283 To -19776: pinyin = "B"
    Case -19775 To -19219: pinyin = "C"
    Case -19218 To -18711: pinyin = "D"
    Case -18710 To -18527: pinyin = "E"
    Case -18526 To -18240: pinyin = "F"
    Case -18239 To -17923: pinyin = "G"
    Case -17922 To -17418: pinyin = "H"
    Case -17417 To -16475: pinyin = "J"
    Case -16474 To -16213: pinyin = "K"
    Case -16212 To -15641: pinyin = "L"
    Case -15640 To -15166: pinyin = "M"
    Case -15165 To -14923: pinyin = "N"
    Case -14922 To -14915: pinyin = "O"
    Case -14914 To -14631: pinyin = "P"
    Case -14630 To -14150: pinyin = "Q"
    Case -14149 To -14091: pinyin = "R"
    Case -14090 To -13319: pinyin = "S"
    Case -13318 To -12839: pinyin = "T"
    Case -12838 To -12557: pinyin = "W"
    Case -12556 To -11848: pinyin = "X"
    Case -11847 To -11056: pinyin = "Y"
    Case -11055 To -2050: pinyin = "Z"
    Case Else: pinyin = p
    End Select
End Function
Function getpy(str)
For i = 1 To Len(str)
getpy = getpy & pinyin(Mid(str, i, 1))
Next i
End Function
回复 liulang0808 2021-5-4 20:29
判断文本文件的编码方式

ANSI和Unicode 头部:FF EE
Unicode big endian 头部:FE FF
UTF-8 头部:FF FE

Sub GetCode()
    Dim Arr(1) As Byte, Str$

    Open Application.GetOpenFilename("文本文件,*.txt", , "Select A File", , False) For Binary As #1
    Get #1, , Arr: Reset
    Str = Chr("&H" & Hex(Arr(0)) & Hex(Arr(1)))

    If Str = Chr("&HFFFE") Then
        MsgBox "UTF-8"
    ElseIf Str = Chr("&HFEFF") Then
        MsgBox "Unicode big endian"
    Else
        MsgBox "Unicode Or Ansi"
    End If
End Sub
回复 liulang0808 2021-5-7 08:11
arr = [{"a","b","c";"A","B","C"}]
    [a2].Resize(UBound(arr), UBound(arr, 2)) = arr
二维数组

facelist

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

关注官方微信,每天学会一个新技能

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

GMT+8, 2021-9-22 13:07 , Processed in 0.045394 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

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

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

返回顶部