【皇家赌场网址hj9292】办事薄及工作表,X叁总结封闭曲线长度和面积

问题:在平日干活中会蒙受,知道个中二个数量,比如姓名,在表格中输入人名后,想要自动带出网页中该姓名对应的有关数据,比如该姓名的电话机,地址等音信,如何达成吗?

用作世界最出彩的矢量图形设计软件CorelDRAW
X三(最新版)居然未有询问图形周长、面积的功力,但是作为矢量图形设计软件,查询图形几何属性是必备的,幸亏有VBA,给了我们扩展CorelDRAW
X三作用的最为空间,以下正是询问矢量图形几何音讯的VBA进程。假诺你有Corel
Designer 1二,  
能够在里边找到此功用,将里面包车型大巴窗体,模块,类模块,导出,再到 CorelDRAW
X三 VBA中,把它们导过来,运营“宏”就能够在CorelDRAW
X三中运转了,假如未有请看下边宏代码编写进程。

‘File下载文件有关函数阐明
Private Declare Function URLDownloadToFile Lib “urlmon” Alias
“URLDownloadToFileA” (ByVal pCaller As Long, ByVal szURL As String,
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As
Long) As Long
Public Declare Function DeleteUrlCacheEntry Lib “wininet” Alias
“DeleteUrlCacheEntryA” (ByVal lpszUrlName As String) As Long

回答:

一、运维CorelDRAW X3,新建“图形一”,按“Alt+F1壹”张开Visual
Basic编辑器,增添如下图所示用户窗体,名称叫“frmGeometric”:皇家赌场网址hj9292 1二、为窗体编写VBA代码,窗体代码全体之类:

列出具有工作薄的 VBA

Sub 批量下载()
机关下载导入 (0)
End Sub

Excel抓取并询问网络数据能够使用“获取和转变”+“查找引用函数”的作用结合来落成。

Option Explicit

由 Mr Colo写的 VBA 需要在VBA内选取 Microfost Visual Basic Applications
Extensbility

Sub 下载导入()
关闭功效
机动下载导入 (一)
拉开功效
End Sub

例:下图是百度周到“奥林匹克运动会”网页中的三个报表,大家以此为例达成抓取该表格至Excel中,并且能够通过输入第几届来询问相应的进行城市。

Private CurUnit As Long
Private Lang As New clsLang
Private bPerimeter As Boolean
Private bValidSelection As Boolean
Private bValidArea As Boolean
Private vDepth As Double

请在 Tools – 宏 – 安全性 – 选拔 信任存取 Visual Basic 项目

Sub 自动下载导入(Optional dr)
If IsMissing(dr) Then dr = 一 ‘为加了Optional的可采用性省略参数设定值
‘多谢您查看本表源码,本源码和设计方式为自小编原创,开源供交换学习,
有疑问能够联系自个儿gzlinwancheng@jd.com
13570972484

‘201⑥年八月16日用通过翻看会话关闭后失效的Cookie找到仓库储存查询秘钥sso.jd.com设计出查ERP仓库储存表格
‘201陆年3月二五日用ERP账号密码Post成功,设计出新的查仓库储存与查订单站点表格给质量控制客服使用
‘2016年11月28日 成功用Post后的Cookie打开JA表格
‘2016年11月29日 成功用Post后的Cookie下载JA表格,分享
‘201陆年五月二三日 休息日加班,扩大批量导入等制作自动表的代码
‘201陆年111月15日 以早报举例,增添时间记下,合并下载和导入两片段代码
‘201陆年1七月三十日完毕WSG库房产和土地资金财产管理家、S猎豹CS陆M供应商预订系统Post导入,并调控Post/Get参数到表中装置
‘201陆年7月十八日下载地址参数用相对引用$,避防复制粘贴到区别行时变化,扩充表明
‘201陆年2月1日编写Post下载地址获取表达,改变保留路线公式Cell函数增添参数避防选定别的表时地址改换
’20一七年011月1十八日扩张File下载、手动导入、导入到已有钦定列、导入并填充左右附近公式(无需填充的决不相邻)、

CSV导入使用数据导入并只在首先次机关调控裂开,第三行高于1柒个人的列自动安装文本幸免数据丢失
‘ 撤废包容按键屏弃何表,分界面表名可修改可多账号
‘ 时间唤醒革新,找不到对应列不导入以免公式表被毁掉

快过大年了仍把明天用逸待劳和明儿早上加班用来写代码,京东守旧与程序员的自己修养哈哈哈
’20一七年07月0二十八日 手动导入增增加文本帮忙
’20一七年0十二月0十二日 csv文件导入时去掉原列内容,删除查询定义连接
’20一7年06月17日 实现WMS数据自动抓取
‘by 京东商场迈阿密北美洲1号小件库 仓库储存质量控制部 园区质量控制岗 林万程

皇家赌场网址hj9292 2

Private vLength As Double
Private vArea As Double

‘ Module
‘ List All VBA module
Dim x As Long
Dim aList()

ssh = ActiveSheet.Name '为了兼容按钮放到其他表中

Step一:使用“获取和改变”成效将网络数据抓取至Excel中

种种点击“数据选项卡”、“新建查询”、“从其余源”、“从Web”。

皇家赌场网址hj9292 3

弹出如下窗口,手动将百度宏观“奥林匹克运动会”的网站复制粘入URAV四L栏,并点击分明。

皇家赌场网址hj9292 4

Excel与网页连接需求料定时间,稍等片刻后会弹出如下窗口,左侧列表中的每种Table都代表该网页中的二个报表,挨个点击预览后发觉,Table叁是大家所需的数量。

皇家赌场网址hj9292 5

点开下方的“加载”旁边的下拉箭头,选拔“加载到”。

皇家赌场网址hj9292 6

在弹出的窗口中,在“选用想要在干活薄中查阅此数量的不2法门”下抉择“表”,并点击加载。

皇家赌场网址hj9292 7

如图,网页表格中的数据已被抓取至Excel中。

皇家赌场网址hj9292 8

次第点击“表格工具”、“设计”,将“表名称”改为奥林匹克运动会。

皇家赌场网址hj9292 9

Private WithEvents cPrecision As clsIntSpin

Sub GetVbProj()
Dim oVBC As VBIDE.VBComponent
Dim Wb As Workbook
x = 2
For Each Wb In Workbooks
For Each oVBC In Workbooks(Wb.Name).VBProject.VBComponents
If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then
Call GetCodeRoutines(Wb.Name, oVBC.Name)
End If
Next
Next
With Sheets.Add
.[A1].Resize(, 3).Value = Array(“Workbook”, “Module”, “Procedure”)
.[A2].Resize(UBound(aList, 2), UBound(aList, 1)).Value = _
Application.Transpose(aList)
.Columns(“A:C”).Columns.AutoFit
End With
End Sub

‘ Sheets(“分界面”).Select ‘为了合作按键放到任何表中

Step2:使用“查找与引用”函数实现数量查询

确立查询区域,包括“届数”和“主办城市”,在届数中4意挑选一届输入,下图输入“第0⑧届”,在主持城市下输入vlookup函数,能够拿走第0八届奥林匹克运动会的掌管理城市市是法国首都,当改动届数时,对应的牵头城市也随之变动。

公式:=VLOOKUP([届数],奥运会[#全部],4,0)

皇家赌场网址hj9292 10

注意点:若网页中的数据变动较频仍,则能够安装链接网页的数额定期刷新:

1将鼠标定位于导入的数量区域中,切换成选项卡,点击下拉箭头→

皇家赌场网址hj9292 11

贰在弹出的对话框中,设置,比如设置为10分钟进行刷新。那样,每隔拾分钟数据就会刷新一遍,时刻保险收获的数量位最新的。

皇家赌场网址hj9292 12


style=”font-weight: bold;”>「精进Excel」系头条签订契约笔者,关心自个儿,假如任意点开叁篇小说,未有您想要的文化,算笔者耍流氓!

回答:

大家好,小编是@Excel实例录制网址长@欢迎私信或许特邀自个儿回答Excel相关难点!


有人在群里问手提式有线电话机号怎么批量查归属地,第三以为是百度时而,结果还真没找到好用的,既然如此,小编就协调写三个吗!首先找了多少个webapi,找到个挺好用的,就用vba写了个自定义函数,测试下感觉依旧挺好用,速度也挺快

皇家赌场网址hj9292 13

style=”font-weight: bold;”>源文件下载链接请私信回复6300五就能够

行使方法:

一.在本表中一向在A1列输动手机号就可以

二.要在任何表中,alt+f1一开采vbe编辑器,复制模块中代码,在您的新表中创造模块,粘贴代码就能够

3.函数参数表明

GetPhoneInfo(号码,参数)

号码—即单个手提式有线电话机号

参数(1,2,3,4):1-城市,2-省,3-运营商, 4-全部

代码如下

Dim ObjXML As Object

Function GetPhoneInfo(number, Optional para As Byte = 1)

‘获取手提式有线电话机号对应的着力音讯 默感到城市

‘para:1-城市,2-省,3-运营商,4,全部

Dim s As String

s =
GetBody(“”
& number)

Select Case para

Case 1

GetPhoneInfo = HtmlFilter(s, “City””:”””, “”””)

Case 2

GetPhoneInfo = HtmlFilter(s, “Province””:”””, “”””)

Case 3

GetPhoneInfo = HtmlFilter(s, “TO””:”””, “”””)

Case 4

GetPhoneInfo = HtmlFilter(s, “City””:”””, “”””) & “,” & HtmlFilter(s,
“Province””:”””, “”””) & “,” & HtmlFilter(s, “TO””:”””, “”””)

End Select

GetPhoneInfo = Replace(GetPhoneInfo, ” “, “”)

End Function

Private Sub Test()

Dim i&, j&, k&, arr, brr

url =
“”

Debug.Print GetBody(url)

End Sub

”’若是出现乱码,UTF-八可改为GB231二

Public Function GetBody(ByVal url$, Optional ByVal Coding$ = “utf-8”)

On Error Resume Next

Set ObjXML = CreateObject(“Microsoft.XMLHTTP”)

With ObjXML

.Open “Get”, url, False, “”, “”

‘.setRequestHeader “If-Modified-Since”, “0”

‘.setRequestHeader “User-Agent”, _

【皇家赌场网址hj9292】办事薄及工作表,X叁总结封闭曲线长度和面积。”.Mozilla/5.0 (Windows NT 6.1; WOW64; rv:47.0) Gecko/20100101
Firefox/47.0″

.Send

GetBody = .ResponseBody

End With

GetBody = BytesToBstr(GetBody, Coding)

Set ObjXML = Nothing

End Function

Public Function BytesToBstr(strBody, CodeBase)

Dim ObjStream

Set ObjStream = CreateObject(“Adodb.Stream”)

With ObjStream

.Type = 1: .Mode = 3: .Open:

.Write strBody: .Position = 0: .Type = 2: .Charset = CodeBase

BytesToBstr = .ReadText: .Close

End With

Set ObjStream = Nothing

End Function

Public Function HtmlFilter(ByVal htmlText$, ByVal Label1$, ByVal
label2$)

‘重回html字符串lable一和多年来的lable二标签中的数据

Dim pStart As Long, pStop As Long

pStart = InStr(htmlText, Label1) + Len(Label1)

If pStart <> 0 Then

pStop = InStr(pStart, htmlText, label2)

HtmlFilter = Mid(htmlText, pStart, pStop – pStart)

End If

End Function

回答:

标准的人做规范职业。

Private Sub OnUnitChange(ByVal Unit As Long)
    Dim strLength As String
    Dim strArea As String
    Dim strVolume As String
   
    vDepth = Application.ConvertUnits(vDepth, GetAppUnits(CurUnit),
GetAppUnits(Unit))
    CurUnit = Unit
    UpdateDepth
   
    strLength = GetCurUnitString()
    lblUnitLength.Caption = strLength
    lblUnitArea.Caption = strLength & GetSquare(False)
    lblUnitDepth.Caption = strLength
    lblUnitVolume.Caption = strLength & GetCube(False)
   
    UpdateValues
End Sub

Private Sub GetCodeRoutines(wbk As String, VBComp As String)
Dim VBCodeMod As CodeModule
Dim StartLine As Long

ri = 5

万贰只是偶尔有其①义务,依旧在网上出点钱,找人做了。

费用的钱真的不多。几百元丰裕了。

Private Sub UpdateDepth()
    Updating = Updating + 1
    txtDepth.Text = CStr(vDepth)
    Updating = Updating – 1
End Sub

On Error Resume Next
Set VBCodeMod =
Workbooks(wbk).VBProject.VBComponents(VBComp).CodeModule
With VBCodeMod
StartLine = .CountOfDeclarationLines + 1
Do Until StartLine >= .CountOfLines
ReDim Preserve aList(1 To 3, 1 To x – 1)
aList(1, x – 1) = wbk
aList(2, x – 1) = VBComp
aList(3, x – 1) = .ProcOfLine(StartLine, vbext_pk_Proc)
x = x + 1
StartLine = StartLine + .ProcCountLines(.ProcOfLine(StartLine, _
vbext_pk_Proc), vbext_pk_Proc)
If Err Then Exit Sub
Loop
End With
Set VBCodeMod = Nothing
End Sub

‘ 联网提示(“http://ssa.jd.com/sso/login”)

倘假如日常职务多,且有必然的根基,学习一下未必不可。

老猫是经过VBA操作的,写3个代码,抓取数据,也很便利。

老猫正在开垦的壹款足彩软件程序救市从网上抓取大批量数量。然后分析和展望足彩。

Private Function GetCurUnitString() As String
    Dim strLength As String
    Select Case CurUnit
        Case 0
            strLength = Lang.GetString(eUnitInch)
        Case 1
            strLength = Lang.GetString(eUnitMM)
        Case 2
            strLength = Lang.GetString(eUnitCM)
        Case 3
            strLength = Lang.GetString(eUnitM)
    End Select
    GetCurUnitString = strLength
End Function

不得以挑选或编辑单元格

Set http = CreateObject("Msxml2.ServerXMLHTTP")
    '登录
    http.Open "post", "http://ssa.jd.com/sso/login", False
    http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    Data = "username=" & [B2] & "&password=" & [B3] & "" '【ERP账号密码所在位置】
    http.send (Data)

    If InStr(http.responsetext, "登录超时") > 0 Then
        tip = Time & " 登录超时,ERP账号密码错误或未填写。"
        Debug.Print tip
        MsgBox tip
        End
    End If

'下载
For ri = 5 To [H1048576].End(xlUp).Row
If Range("B" & ri) <> "" Then '用下载表名判断,不导入的可以不填表名,这样不用去掉网址
    t1 = Time
    '报表下载保存地址
    ph = Range("A" & ri)
    If ph = "" Then ph = ThisWorkbook.path
    fn = ph & "\" & Range("B" & ri) & "." & Range("F" & ri)
    If Range("G" & ri) = "File" Then
        lngRetVal = URLDownloadToFile(0, Range("H" & ri), fn, 0, 0)
        If lngRetVal = 0 Then DeleteUrlCacheEntry Range("H" & ri)
    ElseIf Range("G" & ri) = "WMS" Then
        sq = [H1]
        sqt = Range("H" & ri)
        Workbooks.Add
        With ActiveSheet
        With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "ODBC;DRIVER={MySQL ODBC 5.3 Unicode Driver};" & sq, _
            Destination:=.Range("A1")).QueryTable
            .CommandText = sqt
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlOverwriteCells '插入模式=覆盖(还有插入行和插入列选择)f
            .SavePassword = True '保存密码
            .SaveData = True
            .AdjustColumnWidth = Ture
            .RefreshPeriod = 0 '刷新频率单位秒,0不自动刷新
            .PreserveColumnInfo = True
            .ListObject.DisplayName = "万程的缩写是WC"
            .Refresh BackgroundQuery:=False
            .Delete '删除查询定义
        End With
        End With
        ActiveWorkbook.SaveAs FileName:=fn, FileFormat:=xlCSV, CreateBackup:=False
        ActiveWindow.Close
    Else
        http.Open Range("G" & ri), Range("H" & ri), False
        http.send ("")
        DoEvents '防止程序假死

        Debug.Print attfn(http)

那是抓取的比赛列表:

皇家赌场网址hj9292 14

Private Function GetSquare(ByVal bUnicode As Boolean) As String
    Dim s As String
    s = ChrW$(178)
    If Not bUnicode And Asc(s) = 63 Then
        s = “2”
    End If
    GetSquare = s
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Myrange As Range, KeepOut As Range
Dim ws As Worksheet

‘ If InStr(http.responsetext, “not support”) > 0 Then
‘ tip = Time & ” ” & Range(“B” & ri) & ”
方法不当,请在网页中登入后运营,或调换有权力账号。”
‘ Debug.Print tip
” MsgBox tip
‘ Else

那是VBA程序代码

皇家赌场网址hj9292 15

Private Function GetCube(ByVal bUnicode As Boolean) As String
    Dim s As String
    s = ChrW$(179)
    If Not bUnicode And Asc(s) = 63 Then
        s = “3”
    End If
    GetCube = s
End Function

‘Full sheet
‘Set KeepOut = ActiveSheet.Cells
‘Several Columns
‘Set KeepOut = ActiveSheet.Range(“B:D”)
‘Test Range
Set KeepOut = ActiveSheet.Range(“A2:C5”)

        Set sGet = CreateObject("ADODB.Stream") '下载文件
            sGet.Mode = 3
            sGet.Type = 1
            sGet.Open
            sGet.Write (http.responseBody)
            sGet.SaveToFile SaveTo & fn, 2

那是抓取的赔率数据

皇家赌场网址hj9292 16

总的说来,借使想学是轻巧的。

回答:

以EXCEL200三为例来给你验证。

一、首先打开EXCEL200三,在菜单栏找到“数据”然后在下拉菜单点击“导入外部数据-新建WEB查询”
皇家赌场网址hj9292 17
二、然后在开发的对话框中的地址栏中,将你要导入的网站输入进去,按下转到按键。
皇家赌场网址hj9292 18
三、在弹开的对话框中原则必要导入的区域,按下导入开关,那年,数据就被导入到EXCEL里面啦!
皇家赌场网址hj9292 19末尾,你的处理器得链接网络,要不未有数量,那样导入的收益是,能够和网址上保持1致,无需进行手动更新,很有益于。

Private Sub cArea_Click()
    UpdateControls
End Sub

Set Myrange = Intersect(Target, KeepOut)
‘Leave if the intersecttion ws untouched
If Myrange Is Nothing Then Exit Sub

‘ Set sGet = Nothing ‘清除文件流

Private Sub cboUnits_Change()
    OnUnitChange cboUnits.ListIndex
End Sub

‘Stop select firing a second time
Application.EnableEvents = False
If KeepOut.Rows.Count = 65536 And KeepOut.Columns.Count = 256 Then
‘Entire sheet is the KeepOut range. Eek!
‘Bounce user to a dummy sheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(“KickMeTo”)
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add
ws.Name = “KickMeTo”
End If
MsgBox “Houston we have a problem” & vbNewLine & _
“You cannot select any cell in ” & vbNewLine & “‘” & KeepOut.Parent.Name
& “‘” & vbNewLine & _
“So you have been directed to a different sheet”
ws.Activate
ElseIf KeepOut.Rows.Count = 65536 Then
‘If all rows are contained in the “KeepOut” range then:
‘Now we need to find a cell that is in a column to the right or left of
this range
If KeepOut.Cells(1).Column > 1 Then
‘If there is a valid column to the left of the range then select the
cell in this column
【皇家赌场网址hj9292】办事薄及工作表,X叁总结封闭曲线长度和面积。Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column – 1).Select
Else
‘Else select the cell in first column to the right of the range
Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column + 1).Select
End If
MsgBox “You cannot select ” & KeepOut.Address(False, False) & vbNewLine
& _
“You have been directed to the first free column in the protected
range”, vbCritical
ElseIf KeepOut.Rows.Count + KeepOut.Cells(1).Row – 1 = 65536 Then
‘Select first cell in Column A before “KeepOut” Range
Cells(KeepOut.Cells(1).Row – 1, 1).Select
MsgBox “You cannot select ” & KeepOut.Address(False, False) & vbNewLine
& _
“You have been directed to the first free cell in Column A above the
protected range”, vbCritical
Else
‘Select first cell in Column A beyond “KeepOut” Range
MsgBox “You cannot select ” & KeepOut.Address(False, False) & vbNewLine
& _
“You have been directed to the first free cell in Column A below the
protected range”, vbCritical
Cells(KeepOut.Rows.Count + KeepOut.Cells(1).Row, 1).Select
End If
Application.EnableEvents = True
End Sub

‘ End If

Private Sub cLength_Click()
    UpdateControls
End Sub

MicroSoft 沒有文件顯示 編碼 的尺寸限制
64K 太大,很難跟進

        Application.ScreenUpdating = True '启用屏幕更新
        Range("E" & ri).Select '显示进度
        Application.ScreenUpdating = False '禁用屏幕更新
        If tip = Empty Then
            Range("E" & ri) = Time - t1
        Else
            Range("E" & ri) = tip
        End If
    End If

    '导入
    If dr = 1 Then
    If Range("C" & ri) <> "" Then '用导入表名判断,不导入的可以不填表名,这样不用去掉网址
    If Dir(fn, 16) <> Empty Then '路径不存在不运行,这里不加的话kill fn会报错
        s = Range("C" & ri)
        tip = 导入表(fn, s)
        Kill fn '删除文件

        Sheets(ssh).Select '打开导入过程选定表会变化,所以重新选定
        Application.ScreenUpdating = True '启用屏幕更新
        Range("E" & ri).Select '显示进度
        Application.ScreenUpdating = False '禁用屏幕更新
        If tip = Empty Then
            Range("E" & ri) = Time - t1
        Else
            Range("E" & ri) = tip
        End If
    End If
    End If
    End If
End If
Next

Private Sub cmClose_Click()
    Unload Me
End Sub

以下編碼檢示 Module 的轻重

‘ Sheets(ssh).Select ‘为了同盟开关放到任何表中
End Sub

Private Sub cmCopy_Click()
    Dim sData As String
    Dim oData As New DataObject

Sub get_Mod_Size()
Dim myProject As Object
Dim ComName As String
Dim tempPath As String
Dim fs As Object, a As Object
Dim result As String

Function decodeURI(szInput)
Set js = CreateObject(“MSScriptControl.ScriptControl”)
js.Language = “JScript”
decodeURI = js.Eval(“decodeURI(‘” & szInput & “‘)”)
End Function

    sData = GetDataString(False)
    If sData <> “” Then
        oData.SetText sData
        oData.PutInClipboard
    End If
End Sub


**************************************************************************************
‘ Use this to determine the size of a module
‘ Set ModName (component name) and tempPath (where to store the temp
fule), then run

**************************************************************************************

Function attfn(http)
attfn =
Replace(decodeURI(http.getResponseHeader(“Content-Disposition”)),
“attachment;filename=”, “”)
End Function

Private Sub cmCreateText_Click()
    Const TextSize As Double = 24 ‘ 24 pt text
    Dim lr As Layer
    Dim sData As String
    Dim sr As ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
    sData = GetDataString(True)
    Updating = Updating + 1
    If Not ActiveShape Is Nothing And sData <> “” Then
        Set sr = ActiveSelectionRange
        ActiveShape.GetBoundingBox x, y, w, h
        x = x + w / 2
        y = y – ActiveDocument.ToUnits(TextSize, cdrPoint)
        Set lr = ActiveShape.Layer
        If lr.Editable Then Set lr = ActiveLayer
        lr.CreateArtisticText x, y, sData, cdrEnglishUS, , “Times New
Roman”, 24, cdrTrue, cdrTrue, , cdrLeftAlignment
        sr.CreateSelection
    End If
    Updating = Updating – 1
End Sub

‘ Set these to run
ComName = “Module1”
tempPath = “c:\Test.bas”

Function 表存在(s)
For Each i In Sheets
If i.Name = s & “” Then 表存在 = 一’连接空白是幸免表格名称为数值时格式不一样
‘ Debug.Print i.Name = s
Next
End Function

Private Sub cmRefresh_Click()
    RefreshForm
End Sub

‘ ***** No action needed after this point *****

Function 建表(s)
For Each i In Sheets
If i.Name = s Then Exit Function
Next
Sheets.Add(, ThisWorkbook.Sheets(Sheets.Count)).Name = s
‘ Sheets.Add.Name = s’成立在前面
‘ Sheets.Add 方法
(Excel):https://msdn.microsoft.com/zh-cn/library/office/ff839847
End Function

Private Sub cmReset_Click()
    vDepth = 0
    UpdateDepth
    UpdateValues
End Sub

‘ Export the component (module, form, etc) – this is only temporary
Set myProject = Application.VBE.ActiveVBProject.VBComponents
myProject(ComName).Export (tempPath)

Sub 更新WMS秘钥()
If 进程命令(“斯马特QueryTwo.exe”) <> “” Then
[H1] = Split(进程命令(“斯马特QueryTwo.exe”), “,”)(伍)
End If
End Sub

Private Sub cPrecision_Change()
    UpdateValues
End Sub

‘ Get the size of the file created
Set fs = CreateObject(“Scripting.FileSystemObject”)
Set a = fs.getfile(tempPath)
result = ComName & ” uses ” & (a.Size / 1000) & ” KB.”

Function 测网(url)
On Error Resume Next
cmdping = “ping ” & url & ” -n 1″
Set oExec = CreateObject(“Wscript.shell”).exec(cmdping)
Do Until oExec.stdout.AtEndOfStream
strline = strline & oExec.stdout.readline() & Chr(13)
Loop
测网 = 0
If InStr(strline, “回复”) Then 测网 = 1
Set oExec = Nothing
End Function

Private Sub cVolume_Click()
    UpdateControls
End Sub

‘ Return the file size
MsgBox result, vbExclamation

Function 联网提醒(url)
If 测网(url) = 0 Then
tip = Time & ” 请确认是或不是连接上公司内网。”
Debug.Print tip
MsgBox tip
End
End If
End Function

 

‘ Delete the exported file
fs.Deletefile tempPath

Private Sub txtDepth_Change()
    Dim s As String
   
    If Updating Then Exit Sub
   
    s = Trim$(txtDepth.Text)
    If s <> “” Then
        vDepth = Val(Replace(s, “,”, “.”))
    Else
        vDepth = 0
    End If
    UpdateValues
End Sub

End Sub

Private Sub UserForm_Initialize()
    Updating = 0
    vDepth = 0
   
    Set cPrecision = New clsIntSpin
    cPrecision.Init txtPrecision, spnPrecision, 3, lblPrecision, 0, 5,
1
   
    Me.Caption = Lang.GetString(eFormCaption)
   
    grpLength.Caption = Lang.GetString(eCapPerimeter)
    cLength.Caption = Lang.GetString(eCapPerimeter) & “:”
    bPerimeter = True
   
    grpArea.Caption = Lang.GetString(eCapArea)
    cArea.Caption = Lang.GetString(eCapArea) & “:”
   
    grpVolume.Caption = Lang.GetString(eCapVolume)
    lblDepth.Caption = Lang.GetString(eCapDepth) & “:”
    cmReset.Caption = Lang.GetString(eBtnReset)
    cVolume.Caption = Lang.GetString(eCapVolume) & “:”
   
    cmCreateText.Caption = Lang.GetString(eBtnCreateText)
    cmCopy.Caption = Lang.GetString(eBtnCopy)
    cmClose.Caption = Lang.GetString(eBtnClose)
    cmRefresh.Caption = Lang.GetString(eBtnRefresh)
    lblUnits.Caption = Lang.GetString(eCapUnits) & “:”
    lblPrecision.Caption = Lang.GetString(eCapPrecision) & “:”
  
    cboUnits.Clear
    cboUnits.AddItem Lang.GetString(eStrInch)
    cboUnits.AddItem Lang.GetString(eStrMM)
    cboUnits.AddItem Lang.GetString(eStrCM)
    cboUnits.AddItem Lang.GetString(eStrM)
    cboUnits.ListIndex = IIf(Lang.IsMetric(), 1, 0)
   
    RefreshForm
    MacroRunning = True
End Sub

测试 WorkSheet 是或不是存在

Sub RefreshForm()
    Dim nSelCount As Long
   
    bValidSelection = False
    bValidArea = False
   
    Updating = Updating + 1
   
    On Error GoTo ErrHandler
   
    If Not ActiveDocument Is Nothing Then
        nSelCount = ActiveDocument.Selection.Shapes.Count
        Select Case nSelCount
            Case 0
                ShowStatusMessage Lang.GetString(eStrNoSelection)
               
            Case 1
                ProcessSelection ActiveShape
               
            Case Else
                ShowStatusMessage Lang.GetString(eStrGroupSelected)
        End Select
    Else
        ShowStatusMessage Lang.GetString(eStrNoSelection)
    End If
   
ExitSub:
    UpdateControls
    Updating = Updating – 1
    Exit Sub
   
ErrHandler:
    ShowStatusMessage Lang.GetString(eStrError) & “: ” &
Err.Description
    Resume ExitSub
End Sub

Sub IsSheetExist()
Dim wSheet As Worksheet
On Error Resume Next
Set wSheet = Sheets(“Sheet6”)
If wSheet Is Nothing Then
MsgBox “Worksheet does not exist”
Set wSheet = Nothing
On Error GoTo 0
Else
MsgBox “Sheet does exist”
Set wSheet = Nothing
On Error GoTo 0
End If
End Sub

Private Sub EnableTextControl(ByVal Txt As TextBox, ByVal bState As
Boolean)
    Txt.Enabled = bState
    Txt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
End Sub

皇家赌场网址hj9292 20

Private Sub UpdateControls()
    Dim bEnabled As Boolean
   
    cLength.Enabled = bValidSelection
    EnableTextControl txtLength, bValidSelection
    lblUnitLength.Enabled = bValidSelection

让工作表始终置顶

    cArea.Enabled = bValidArea
    EnableTextControl txtArea, bValidArea
    lblUnitArea.Enabled = bValidArea
   
    lblDepth.Enabled = bValidArea
    EnableTextControl txtDepth, bValidArea
    lblUnitDepth.Enabled = bValidArea
    cmReset.Enabled = bValidArea
    cVolume.Enabled = bValidArea
    EnableTextControl txtVolume, bValidArea
皇家赌场网址hj9292,    lblUnitVolume.Enabled = bValidArea
   
    bEnabled = bValidSelection
    If bEnabled Then
        bEnabled = cLength.Value <> 0
        If bValidArea And Not bEnabled Then
            bEnabled = cArea.Value <> 0 Or cVolume.Value <>
0
        End If
    End If
    cmCreateText.Enabled = bEnabled
    cmCopy.Enabled = bEnabled
End Sub

—————– Module

Private Sub ProcessSelection(ByVal s As Shape)
    If s.Type = cdrGroupShape Then
        ShowStatusMessage Lang.GetString(eStrGroupSelected)
    ElseIf s.IsSimpleShape And s.Type <> cdrTextShape Then
        ProcessCurve s.DisplayCurve
    Else
        ShowStatusMessage Lang.GetString(eStrInvalidObject)
    End If
End Sub

Private Declare Function SetWindowPos Lib “user32” (ByVal hwnd As Long,
ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long,
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

Private Function CheckSubpaths(ByVal crv As Curve) As Boolean
    Dim bRet As Boolean
    Dim n As Long
    bRet = True
    If crv.SubPaths.Count <> 1 Then
        For n = 2 To crv.SubPaths.Count
            If crv.SubPaths(n).Nodes.Count > 1 Then
                bRet = False
                Exit For
            End If
        Next n
    End If
    CheckSubpaths = bRet
End Function

Public Sub MakeNormal(hwnd As Long)
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeTopMost(hwnd As Long)
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub

Private Sub ProcessCurve(ByVal crv As Curve)
    Dim v As Double
    Dim bClearStatus As Boolean
    Dim bClosed As Boolean
   
    bClosed = crv.SubPaths(1).Closed
    bClearStatus = True
    bValidArea = bClosed And CheckSubpaths(crv)
    If bValidArea Then
        grpLength.Caption = Lang.GetString(eCapPerimeter)
        cLength.Caption = Lang.GetString(eCapPerimeter) & “:”
        bPerimeter = True
    Else
        grpLength.Caption = Lang.GetString(eCapLength)
        cLength.Caption = Lang.GetString(eCapLength) & “:”
        bPerimeter = False
    End If
   
    bValidSelection = True
    vLength = crv.Length
   
    If bValidArea Then
        vArea = calcShapeArea(crv.SubPaths(1))
    Else
        vArea = 0
        If bClosed Then
            ShowStatusMessage Lang.GetString(eStrMultipathCurve)
        Else
            ShowStatusMessage Lang.GetString(eStrCurveOpen)
        End If
        bClearStatus = False
    End If
   
    If bClearStatus Then ClearStatusMessage
    UpdateValues
End Sub

Sub test()
Call MakeTopMost(Application.hwnd)
Call MakeNormal(Application.hwnd)
End Sub

Private Sub UpdateValues()
    Dim v As Double
    txtLength.Text = FormatValue(GetLength(vLength))
   
    If bValidArea Then
        v = GetArea(vArea)
        txtArea.Text = FormatValue(v)
        txtVolume.Text = FormatValue(v * vDepth)
    Else
        txtArea.Text = “”
        txtVolume.Text = “”
    End If
End Sub

有效下拉框的中度 显示越多更加直观

Private Function FormatValue(ByVal v As Double) As String
    Dim sFormat As String
    sFormat = “0”
    If cPrecision.GetValue() > 0 Then
        sFormat = “0.” & String$(cPrecision.GetValue(), “0”)
    End If
    FormatValue = Format$(v, sFormat)
End Function

Option Explicit

Private Function GetAppUnits(ByVal vUnit As Long) As cdrUnit
    Dim tUnit As cdrUnit
    Select Case CurUnit
        Case 1
            tUnit = cdrMillimeter
        Case 2
            tUnit = cdrCentimeter
        Case 3
            tUnit = cdrMeter
        Case Else
            tUnit = cdrInch
    End Select
    GetAppUnits = tUnit
End Function

Dim oDpd As Object
Dim sFml1
Dim prvTarget As Range

Private Function GetLength(ByVal v As Double) As Double
    If ActiveDocument Is Nothing Then
        GetLength = 0
    Else
        GetLength = ActiveDocument.FromUnits(v, GetAppUnits(CurUnit)) *
ActiveDocument.WorldScale
    End If
End Function

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal
Target As Range)
Const dFixedPos As Double = “0.8”
Const dFixWidth As Double = “16” ‘Change here to change WIDTH of the
DropDown
Dim vld As Validation
Dim lDpdLine As Long

Private Function GetArea(ByVal v As Double) As Double
    GetArea = GetLength(GetLength(v))
End Function

If Not prvTarget Is Nothing Then
If Not oDpd Is Nothing Then
If oDpd.Value = 0 Then
prvTarget.Value = vbNullString
Else
prvTarget.Value = Range(Mid(sFml1, 2)).Item(oDpd.Value)
End If
Set prvTarget = Nothing
End If
End If

Private Function calcShapeArea(ByVal sp As SubPath) As Double
    Dim cx As New Collection
    Dim cy As New Collection
    Dim seg As Segment
    Dim n As Long
    Dim x As Double, y As Double
    Dim Area As Double
    Dim nPts As Long
   
    sp.StartNode.GetPosition x, y
   
    cx.Add x
    cy.Add y
   
    For Each seg In sp.Segments
        If seg.Type = cdrCurveSegment Then
            For n = 1 To 49
                seg.GetPointPositionAt x, y, n / 50
                cx.Add x
                cy.Add y
            Next n
        End If
        seg.EndNode.GetPosition x, y
        cx.Add x
        cy.Add y
    Next seg
   
    Area = 0
    For n = 1 To cx.Count – 1
        Area = Area + cx(n) * cy(n + 1) – cy(n) * cx(n + 1)
    Next
   
    calcShapeArea = Abs(Area / 2)
End Function

On Error Resume Next
oDpd.Delete
sFml1 = vbNullString
Set oDpd = Nothing
On Error GoTo 0

Private Sub ShowStatusMessage(ByVal msg As String)
    lblStatusBar.Caption = msg
End Sub

If Target.Count > 1 Then
Set oDpd = Nothing
Exit Sub
End If

Private Sub ClearStatusMessage()
    lblStatusBar.Caption = “”
End Sub

Set vld = Target.Validation
On Error GoTo Terminate
sFml1 = vld.Formula1
On Error GoTo 0

Private Sub UserForm_Terminate()
    MacroRunning = False
End Sub

Set prvTarget = Target

Private Function GetDataString(ByVal bUnicode As Boolean)
    Dim s As String
    s = “”
    If bValidSelection Then
        If cLength.Value Then
            If bPerimeter Then
                s = Lang.GetString(eCapPerimeter)
            Else
                s = Lang.GetString(eCapLength)
            End If
            s = s & ” = ” & txtLength.Text & ” ” & GetCurUnitString()
        End If
       
        If bValidArea Then
            If cArea.Value Then
                If s <> “” Then s = s & vbCrLf
                s = s & Lang.GetString(eCapArea) & ” = ” & txtArea.Text
& ” ” & GetCurUnitString() & GetSquare(bUnicode)
            End If
           
            If cVolume.Value Then
                If s <> “” Then s = s & vbCrLf
                s = s & Lang.GetString(eCapVolume) & ” = ” &
txtVolume.Text & ” ” & GetCurUnitString() & GetCube(bUnicode)
            End If
        End If
    End If
    GetDataString = s
End Function

lDpdLine = Range(Mid(sFml1, 2)).Rows.Count

三、增添模块,名称叫“Information”,代码如下:

With Target
Set oDpd = ActiveSheet.DropDowns.Add( _
.Left – dFixedPos, _
.Top – dFixedPos, _
.Width + dFixWidth + dFixedPos * 2, _
.Height + dFixedPos * 2)
End With
With oDpd
.ListFillRange = sFml1
.DropDownLines = lDpdLine
.Display3DShading = True
End With
Terminate:
End Sub

Option Explicit

皇家赌场网址hj9292 21点击浏览该文件

Public MacroRunning As Boolean
Public Updating As Long

皇家赌场网址hj9292 22

Public Sub Dialog()
    EventsEnabled = True
    frmGeoMetric.Show vbModeless
End Sub

請問如何不改變activecell之下將某1儲存格顯示於左上角?

4、加多八个类模块:

1.

  (1)名叫clsIntSpin,代码如下:

ActiveWindow.SmallScroll Up:=6553陆 ActiveWindow.SmallScroll ToLeft:=256用地点的措施先回到 A一 再用上面包车型地铁措施到定點 ActiveWindow.SmallScroll
Down:=儲存格列號 – 一 ActiveWindow.SmallScroll ToRight:=儲存格欄號 – 一

Option Explicit

2.

Public Event Change()

ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row
ActiveWindow.ScrollColumn = ActiveCell.Column

‘================= Private Data =================
Private WithEvents cTxt As TextBox
Private WithEvents cSpin As SpinButton
Private Updating As Long
Private Value As Long
Private lLabel As Label
Private Digits As Long

3.

‘================= Interface ================
Public Sub Init(Txt As TextBox, Spin As SpinButton, ByVal v As Long,
Optional CtlLabel As Label, Optional ByVal nMin As Long = 0, Optional
ByVal nMax As Long = 2147483647, Optional ByVal nStep As Long = 1,
Optional ByVal NumDigits As Long)
    If v < nMin Then v = nMin
    If v > nMax Then v = nMax
    Value = v
    Set cTxt = Txt
    Set cSpin = Spin
    Set lLabel = CtlLabel
    BeginUpdate
    If NumDigits > 0 Then
        Digits = NumDigits
    Else
        Digits = 1
    End If
   
    cTxt.Value = FormatValue(Value)
    With cSpin
        .Min = nMin
        .Max = nMax
        .SmallChange = nStep
        .Value = Value
    End With
   
    EndUpdate
End Sub

Application.Goto ActiveCell, True

Public Function OnTextExit() As Boolean
    Dim n As Long
    OnTextExit = False
    If Updating = 0 Then
        n = GetTextValue()
        BeginUpdate
        If cSpin.Value <> n Then
            cSpin.Value = n
            Value = n
            OnTextExit = True
            RaiseEvent Change
        Else
            cTxt.Value = FormatValue(n)
        End If
        EndUpdate
    End If
End Function

皇家赌场网址hj9292 23

Public Sub SetValue(ByVal nVal As Long)
    BeginUpdate
    With cSpin
        If nVal < .Min Then nVal = .Min
        If nVal > .Max Then nVal = .Max
        .Value = nVal
    End With
    Value = nVal
    cTxt.Value = FormatValue(nVal)
    EndUpdate
End Sub

Save Sheet as WorkBook

Public Function GetValue() As Long
    GetValue = Value
End Function

Sub SaveShtsAsBook()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & “\” & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) – 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
‘ End With
On Error Resume Next ‘<< a folder exists
MkDir MyFilePath ‘<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
‘save book in this folder
.SaveAs Filename:=MyFilePath _
& “\” & SheetName & “.xls”
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub

Public Sub Enable(ByVal bState As Boolean)
    If Not lLabel Is Nothing Then lLabel.Enabled = bState
    cTxt.Locked = Not bState
    cTxt.TabStop = bState
    cTxt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
    cTxt.ForeColor = IIf(bState, vbWindowText, vbButtonShadow)
    cSpin.Enabled = bState
End Sub

+++++++++++++++++++++++++++++++++++++++++++++++++++++

Public Sub SetMaxRange(ByVal nVal)
    BeginUpdate
    If Value > nVal Then
        Value = nVal
        cSpin.Value = nVal
        cTxt.Value = FormatValue(nVal)
    End If
    cSpin.Max = nVal
    EndUpdate
End Sub

Sub BreakExternalLinks()

Public Sub SetMinRange(ByVal nVal)
    BeginUpdate
    If Value < nVal Then
        Value = nVal
        cSpin.Value = nVal
        cTxt.Value = FormatValue(nVal)
    End If
    cSpin.Min = nVal
    EndUpdate
End Sub

Dim WS As Worksheet
Dim Rng1 As Range
Dim Cell As Range

‘================ Helper Functions ==============
Private Sub BeginUpdate()
    Updating = Updating + 1
End Sub

For Each WS In ActiveWorkbook.Worksheets
With WS
On Error Resume Next
Set Rng1 = Cells.SpecialCells(xlCellTypeFormulas, 23)

Private Sub EndUpdate()
    Updating = Updating – 1
End Sub

‘ 23 – All formulae
‘ 16 – All formulae with errors
‘ 2 – All formulae with text
‘ 4 – All formulae with logic
‘ 6 – All formulae with text or logic

Private Function GetTextValue() As Long
    Dim v As Double
    v = 0
    If Trim$(cTxt.Text) <> “” Then v = Val(cTxt.Text)
    If v < CDbl(cSpin.Min) Then v = cSpin.Min
    If v > CDbl(cSpin.Max) Then v = cSpin.Max
    GetTextValue = CLng(v)
End Function

On Error GoTo 0
If Not Rng1 Is Nothing Then
For Each Cell In Rng1
If Left(Cell.Formula, 2) = “='” Then
Cell.Value = Cell.Value
End If
Next
End If
Set Rng1 = Nothing
End With
Next

Private Function FormatValue(ByVal v As Long) As String
    Dim s As String
    Dim bNegative As Boolean
   
    bNegative = v < 0
    s = Trim$(str$(Abs(v)))
    If Len(s) < Digits Then
        s = Right$(String$(Digits, “0”) & s, Digits)
    End If
   
    If bNegative Then s = “-” & s
    FormatValue = s
End Function

End Sub

Private Sub Class_Initialize()
    Value = 0
End Sub

皇家赌场网址hj9292 24

Private Sub cSpin_Change()
    If Updating = 0 Then
        BeginUpdate
        cTxt.Value = FormatValue(cSpin.Value)
        Value = cSpin.Value
        RaiseEvent Change
        EndUpdate
    End If
End Sub

动用时间限制設定

Private Sub cTxt_Change()
    Dim n As Long
    If Updating = 0 Then
        n = GetTextValue()
        If cSpin.Value <> n Then
            BeginUpdate
            cSpin.Value = n
            Value = n
            EndUpdate
            RaiseEvent Change
        End If
    End If
End Sub

‘ chijanzen
(原始) 2003/10/1
‘ 前几日介紹如何讓Excel檔案有应用定期,範例中应用Windows
Script”在註冊表上的讀.寫.刪除的用法
‘ 本範例使用按期設定 0 天,所以檔案只好開啟三回就自動銷毀
‘ Script 能运用的根鍵值有伍個根鍵名稱
HKEY_CURRENT_USER ‘縮寫 HKCU
HKEY_LOCAL_MACHINE ‘縮寫 HKLM
HKEY_CLASSES_ROOT ‘縮寫 HKCR
HKEY_USERS ‘縮寫 HKEY_USERS
HKEY_CURRENT_CONFIG ‘縮寫 HKEY_CURRENT_CONFIG

 

Sub CheckFileDate()
Dim Counter As Long, LastOpen As String, Msg As String
If RegRead = “” Then
Term = 0 ‘範例用 0 天
TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
MsgBox “本檔案只可以接纳到” & TermDate & “日” & Chr(13) &
“超過期限將自動銷毀”
RegWrite (Term)
Else
If CDate(RegRead) <= Now Then
RegDelete
KillMe
End If
End If
End Sub
Sub KillMe()
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End Sub

  (2)名为clsLang,代码如下:

Sub RegWrite(Term)
‘RegWrite:建立新鍵、將另1個值名稱加入現有鍵
(並將值指派給它),或變更現有值名稱的值。
Dim WshShell, bKey
fname = ThisWorkbook.Name
TermDate = DateSerial(Year(Now), Month(Now), Day(Now)) + Term
Regkey = “HKCU\chijanzen\Budget\Date\” & fname
Set WshShell = CreateObject(“WScript.Shell”)
WshShell.RegWrite Regkey, TermDate, “REG_SZ”
End Sub

Option Explicit

Function RegRead()
‘RegRead: 從註冊傳回鍵的值或值名稱
On Error Resume Next
Dim WshShell, bKey
fname = ThisWorkbook.Name
Regkey = “HKCU\chijanzen\Budget\Date\” & fname
Set WshShell = CreateObject(“WScript.Shell”)
RegRead = WshShell.RegRead(Regkey)
End Function

Private colDict As New Collection
Private bMetric As Boolean

Sub RegDelete()
‘RegDelete :從註冊刪除某鍵或它的1個值(請小心使用)
Dim WshShell, bKey
Regkey = “HKCU\chijanzen\Budget\Date\”
Set WshShell = CreateObject(“WScript.Shell”)
WshShell.RegDelete Regkey ‘刪除檔名
End Sub

Private Sub Class_Initialize()
 
     AddString eFormCaption, “Geometric Information”
    AddString eBtnClose, “关闭”
    AddString eBtnCopy, “复制”
    AddString eBtnCreateText, “创造文本”
    AddString eBtnRefresh, “刷新”
    AddString eBtnReset, “清零”
    AddString eCapArea, “面积”
    AddString eCapLength, “长度”
    AddString eCapPerimeter, “周长”
    AddString eCapVolume, “体积”
    AddString eCapDepth, “高度”
    AddString eCapUnits, “单位”
    AddString eCapPrecision, “精度”
    AddString eUnitInch, “in”
    AddString eUnitMM, “mm”
    AddString eUnitCM, “cm”
    AddString eUnitM, “m”
    AddString eStrInch, “英寸 (in)”
   
    AddString eStrMM, “毫米 (mm)”
    AddString eStrCM, “厘米 (cm)”
    AddString eStrM, “米 (m)”
    AddString eStrError, “Error”
    AddString eStrNoSelection, “未选择任何图形”
    AddString eStrGroupSelected, “不援救群组图形,请选拔单个图形”
    AddString eStrInvalidObject, “无效选取”
    AddString eStrCurveOpen, “非闭合图形不可能测算面积和体量”
    AddString eStrMultipathCurve, “组合图形不能测算面积和体量”
End Sub

皇家赌场网址hj9292 25

Private Sub AddString(ByVal eId As ELangStringID, ByVal s As String)
    Dim tPair As New clsLangPair
    tPair.eId = eId
    tPair.sDef = s
    colDict.Add tPair
End Sub

防止 Excel 關閉

Public Function GetString(ByVal eId As ELangStringID) As String
    Dim tPair As clsLangPair
    Dim s As String
    s = “Str #” & eId
    For Each tPair In colDict
        If tPair.eId = eId Then
            s = tPair.sDef
            Exit For
        End If
    Next tPair
    GetString = s
End Function

原碼出自 Tek-Tips Forum

Public Function IsMetric() As Boolean
    IsMetric = bMetric
End Function

‘ Module

 

Option Explicit

  (三)名称叫clsLangPair,代码如下:

‘Set Types
Public Type LUID
LowPart As Long
HighPart As Long
End Type

Option Explicit

Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type

Public Enum ELangStringID
    eFormCaption
    eBtnClose
    eBtnCopy
    eBtnCreateText
    eBtnRefresh
    eBtnReset
    eCapArea
    eCapLength
    eCapPerimeter
    eCapVolume
    eCapDepth
    eCapUnits
    eCapPrecision
    eUnitInch
    eUnitMM
    eUnitCM
    eUnitM
    eStrInch
    eStrMM
    eStrCM
    eStrM
    eStrError
    eStrNoSelection
    eStrGroupSelected
    eStrInvalidObject
    eStrCurveOpen
    eStrMultipathCurve
End Enum

Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(1) As LUID_AND_ATTRIBUTES
End Type

Public eId As ELangStringID
Public sDef As String

‘ Declare API functions.
Public Declare Function ExitWindowsEx Lib “user32” (ByVal uFlags As
Long, ByVal dwReserved As Long) As Long
Public Declare Function GetCurrentProcess Lib “kernel32” () As Long
Public Declare Function OpenProcessToken Lib “advapi32” (ByVal
ProcessHandle As Long, _
ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib “advapi32” Alias
“LookupPrivilegeValueA” _
(ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID)
As Long
Public Declare Function AdjustTokenPrivileges Lib “advapi32” (ByVal
TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal
BufferLength _
As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As
Long

   
未来全数编写完成,按F五键运维吧,选中图形,点击程序中“刷新”,“面积”,“体积”等数据立马展现出来,程序运转效果如下图:

‘ Set Set ShutDown Privilege Constants
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2

 皇家赌场网址hj9292 26

Public Sub SetShutDownPrivilege()
Dim Phndl As Long, Thndl As Long
Dim MyLUID As LUID
Dim MyPriv As TOKEN_PRIVILEGES, MyNewPriv As TOKEN_PRIVILEGES

Phndl = GetCurrentProcess()
OpenProcessToken Phndl, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY,
Thndl
LookupPrivilegeValue “”, “SeShutdownPrivilege”, MyLUID
MyPriv.PrivilegeCount = 1
MyPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
MyPriv.Privileges(0).pLuid = MyLUID
‘ Now to set shutdown privilege for my app
AdjustTokenPrivileges Thndl, False, MyPriv, 4 + (12 *
MyPriv.PrivilegeCount), MyNewPriv, 4 + (12 * MyNewPriv.PrivilegeCount)

End Sub

‘ ThisWorkbook

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Dim Msg, Style, Title, Response
Dim MyFlag As Long, Ret As String
‘Set ShutDown Constants
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4

‘ Define message.
Msg = “Do you want to continue ?” _
& vbCr & vbCr & “You are about to exit the excel program.” _
& vbCr & vbCr & “You will need to Reboot Computer” _
& vbCr & “to restore the program!”
Style = vbYesNoCancel + vbCritical + vbDefaultButton3 ‘ Define
buttons.
Title = “Exiting Program” ‘ Define title.
‘ Display message.
Response = MsgBox(Msg, Style, Title)
‘Test the variable Response
Select Case Response
Case vbYes
‘Save the file, Force Windows Closed
Me.Save
‘ Call Exit_Windows
Ret = InputBox(“Enter Password”, “Password Required”)
If Ret = “testing” Then ‘ 改变你的密碼
Ret = InputBox(“Exit Excel or Logoff User” _
& vbCr & ” Enter: E or L”, “What Action”)
Else
MsgBox “Invalid Password”, vbCritical, “Wrong Password”
Cancel = False
Exit Sub
End If
If Ret = “E” Or Ret = “e” Then
Application.Quit
Else
If Ret = “L” Or Ret = “l” Then
SetShutDownPrivilege ‘Set the shutdown privilege – else reboot will
fail
‘ Always execute a force shutdown if a shutdown is required
MyFlag = EWX_LOGOFF ‘LogOff
‘ Grab the shutdown privilege – else reboot will fail
SetShutDownPrivilege
‘Do the required action
Call ExitWindowsEx(MyFlag, 0)
End If
End If
Case vbNo
Worksheets(1).Activate
Cancel = True
Case vbCancel
Cancel = True
Case Else
‘Do Nothing
End Select

End Sub

Private Sub Workbook_Open()
On Error Resume Next
‘Activate the 1st worksheet using the workbooks worksheet index
Worksheets(1).Activate
‘Or If you want to use the actual worksheet name
‘Worksheets(“Sheet1”).Activate
End Sub

钦命Computer上运行

‘用 F8 逐句实行篮色编码,取值后改动暗黑部份

‘ ThisWorkBook

Private Declare Function w32_GetComputerName Lib “kernel32” _
Alias “GetComputerNameA” (ByVal lpBuffer As String, nSize As Long) As
Long

Private Declare Function GetUserName Lib “advapi32.dll” Alias
“GetUserNameA” _
(ByVal lpBuffer As String, nSize As Long) As Long
Public LoginTime

Private Sub Workbook_Open()
Dim TempUName ‘ User Name
Dim TempPCName ‘ PC Name
TempPCName = GetComputerName
TempUName = UserName
If TempPCName <> “PCName01” And TempPCName <> “PCName02” And
TempUName <> “BeeBee” _
And TempPCName <> “EMILY” Then
MsgBox “Sorry, This File is for BeeBee ONLY.”
Application.Quit
End If
End Sub

Function GetComputerName()
Dim sComputerName As String
Dim lComputerNameLen As Long
Dim lResult As Long
lComputerNameLen = 256
sComputerName = Space(lComputerNameLen)
lResult = w32_GetComputerName(sComputerName, lComputerNameLen)
If lResult <> 0 Then
GetComputerName = Left(sComputerName, lComputerNameLen)
Else
GetComputerName = “Unknown”
End If
End Function

Function UserName() As String
Dim Buffer As String * 100
Dim BuffLen As Long
BuffLen = 100
GetUserName Buffer, BuffLen
UserName = Left(Buffer, BuffLen – 1)
End Function

能够监察和控制删除行及列吗

‘ Module

Option Explicit

‘// Worksheet RowColumn Deleted Event
‘// This is NOT a real event but just hack the command button.
‘// You can know when the rows or the columns was deleted by user’s
opelation.

Sub 伊夫nt哈克() ‘ 施行监督程序
AssignMacro “JudgeRng”
End Sub
Sub 伊芙ntReset() ‘ 撤销监察和控制程序
AssignMacro “”
End Sub

Private Sub AssignMacro(ByVal strProc As String)
Dim lngId As Long
Dim CtrlCbc As CommandBarControl
Dim CtrlCbcRet As CommandBarControls
Dim arrIdNum As Variant

‘// 293=Delete menu of the right click on row
‘// 294=Delete menu of the right click on column
‘// 293=Delete menu of the Edit of main menu
arrIdNum = Array(293, 294, 478)

For lngId = LBound(arrIdNum) To UBound(arrIdNum)
Set CtrlCbcRet = CommandBars.FindControls(ID:=arrIdNum(lngId))
For Each CtrlCbc In CtrlCbcRet
CtrlCbc.OnAction = strProc
Next
Set CtrlCbcRet = Nothing
Next
End Sub

Private Sub JudgeRng()
If Not TypeOf Selection Is Range Then Exit Sub
With Selection
If .Address = .EntireRow.Address Then
Call DelExecute(“Row:” & .Row, xlUp)
ElseIf .Address = .EntireColumn.Address Then
Call DelExecute(“Column:” & .Column, xlToLeft)
Else
Application.Dialogs(xlDialogEditDelete).Show
End If
End With
End Sub

Private Sub DelExecute(ByVal str, ByVal lngDerec As Long)
MsgBox “deleted:” & str
Selection.Delete lngDerec
End Sub

皇家赌场网址hj9292 27

测试 WorkBook 是还是不是已拉开

Sub IsWorkBookOpen() Dim wBook As Workbook On Error Resume Next Set
wBook = Workbooks(“Book180.xls”) If wBook Is Nothing Then MsgBox
“Workbook is not open” Set wBook = Nothing On Error GoTo 0 Else MsgBox
“Yes it is open” Set wBook = Nothing On Error GoTo 0 End If End Sub

皇家赌场网址hj9292 28

试问怎么不改换activecell之下将某1储存格彰显于左上角
ActiveCell.Select ActiveWindow.ScrollRow = ActiveCell.Row
ActiveWindow.ScrollColumn = ActiveCell.Column

Application.Goto ActiveCell, True

皇家赌场网址hj9292 29

如何在 VBA 内执行 Add-in 函数

AddIns(“VBA 分析工具箱”).Installed = True Range(“B一”) =
Application.伊娃luate(“=Weeknum(now()-7, 2)”) AddIns(“VBA
分析工具箱”).Installed = True Workdays =
Application.伊娃luate(“=NetWorkdays(DATE(200肆,一,一)
,DATE(200四,1二,3壹))”)

Application.Run(“ATPVBAEN.xla!Weeknum”, Now(), 2)

皇家赌场网址hj9292 30

何以禁止退换工作表名称

粗略例子

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If
ActiveSheet.Name <> “Sheet1” Then ActiveSheet.Name = “Sheet1”
End If End Sub

详尽例子
请参考【取缔更动工作表名称
Chijanzen】

检查测试EXCEL建马上间

Sub CreateDate() On Error Resume Next rw = 1
Worksheets(1).Activate For Each p In
ActiveWorkbook.BuiltinDocumentProperties Cells(rw, 1).Value =
p.Name Cells(rw, 2).Value =
ActiveWorkbook.BuiltinDocumentProperties(p.Name) rw = rw + 1 Next
MsgBox ActiveWorkbook.BuiltinDocumentProperties(“Creation date”)
End Sub

Rename CodeName

皇家赌场网址hj9292 31点击浏览该文件

皇家赌场网址hj9292 32

钦点Computer上运维 19/F

能够监督删除行及列吗 20/F

列出全体工作薄的 VBA 21/F

vba 程式碼(代碼)是或不是限制容积不足超過 64K 限制嗎 23/F

找格式化的顏色 ( Font 及 Interior)
请参考 找格式化的顏色 ( Font 及
Interior)

有未有点子在EXCEL的办事表里插入一张会动的gif 动画

请参考
(向我们推荐贰个方可在SHEET中采取的gif动画插件)

请参考
(不用控件也来彰显GIF动画)

怎么一开荒事业簿,关闭全数工作表,剩 sheet1 为活动工作表

请参考
点击浏览该文件
, 用火速键 CRTL s 可转移下一页,现在唯有3页(能够扩展)

如何另存文件时不保留文件的宏

请参考 (在背景作業中另存新檔
chijanzen)

寻觅自定范围名称左上、左下、右上及右下地址

请参考
皇家赌场网址hj9292 33点击浏览该文件

请教如何在单元格里获得页码和总页数

请参考
(请教如何在单元格里拿走页码和总页数)

加長 驗證 的長度及寬度

请参考 加長 驗證
的長度及寬度

什么样转移列表框下拉的书体格式

Excel 本身自帶的驗證下拉列表是沒有這作用,可用 Combox
格局,請參考附属类小部件

皇家赌场网址hj9292 34点击浏览该公文

试问全屏展现后,如何不出示“关闭全屏展现”工具栏

Sub hidebar() ‘ chijanzen Application.CommandBars(1).Enabled =
False Application.DisplayFullScreen = True
Application.CommandBars(“Full Screen”).Visible = False With
ActiveWindow .DisplayHorizontalScrollBar = False
.DisplayVerticalScrollBar = False End With End Sub Sub unhidebar()
Application.CommandBars(1).Enabled = True
Application.DisplayFullScreen = False With ActiveWindow
.DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar =
True End With End Sub

怎么着隐藏windows上边包车型大巴职责栏
请参见【隐藏职责栏】

能够在不影响活页薄情状下显得时间呢

请参考【在工具列新扩大三个常驻的电狗时钟Chijanzen】

请参考 Ivan F Moala
皇家赌场网址hj9292 35点击浏览该文件

怎么着判断空工作表?并自动删除

If IsEmpty(ActiveSheet.UsedRange) And ActiveSheet.Shapes.Count = 0
Then ActiveSheet.Delete

相关文章

Leave a Comment.