学习
自定义鼠标点击器
陈燮函 发表于2023-07-27 浏览238 评论0
自定义鼠标点击器
Private Type POINTAPI X As Long Y As Long End Type Private Declare Function GetCursorPos Lib "user32" (IpPoint As POINTAPI) As Long Option Explicit Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wflags As Long) As Long Private Const HWND_TOPMOST& = -1 Private Const SWP_NOMOVE = &H1 Private Const SWP_NOSIZE = &H2 Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Const MOUSEEVENTF_LEFTDOWN = &H2 Const MOUSEEVENTF_LEFTUP = &H4 Const MOUSEEVENTF_MOVE = &H1 Const MOUSEEVENTF_RIGHTDOWN = &H8 Const MOUSEEVENTF_RIGHTUP = &H10 Private Function getmouse_x_y() As POINTAPI GetCursorPos getmouse_x_y End Function '插入一个command一个timer两个label Private Sub Command1_Click() AutoPressMouse 1000, 530 Sleep 100 AutoPressMouse 1000, 530 Sleep 100 AutoPressMouse 630, 460 Sleep 100 AutoPressMouse 888, 675 Sleep 3000 AutoPressMouse 640, 470 Sleep 100 SetCursorPos 40, 50 RIGHTMOUSE End Sub Private Sub AutoPressMouse(X As Long, Y As Long) SetCursorPos X, Y mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 End Sub Private Sub RIGHTMOUSE() mouse_event MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0 End Sub Private Sub Form_Load() SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Me.Left = 0 Me.Top = 0 Timer1.Enabled = True Timer1.Interval = 50 End Sub Private Sub Timer1_Timer() 'GetCursorPos position Label1.Caption = getmouse_x_y.X Label2.Caption = getmouse_x_y.Y End Sub
学习
学习过的软件
陈燮函 发表于2023-07-25 浏览194 评论0
C
读书时，接触的第一门计算机语言。
Spss\Matlab
SPSS是读书时的必修课，Matlab是选修课，专业统计、数学类软件。
VB.net
刚工作时用来制作过几个小软件，但制作的软件依赖 .NET Framework，后来就转用移植难度较小的VB了。
贫困调查录入★综合数据处理★住户处Framework20
VB
入门非常简单的软件，可视化界面。随随便便就能生成一个exe程序。用它作过许多工作辅助小程序。
学习
vba操作VCF、有效性等
陈燮函 发表于2023-07-25 浏览208 评论0
VCF导入、精简：
Sub inputVcf() '放在sheet1用于导入
Application.ScreenUpdating = False
Sheet1.Select
Cells.Delete
s = InputBox("输入vcf文件路径", "导入vcf")
If s = "" Then Exit Sub
Application.CutCopyMode = False
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & s, Destination:=Range("$A$1"))
.Name = "00001"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
For i = UsedRange.Rows.Count To 1 Step -1
If Left(Cells(i, 1), 2) = "EN" Or Left(Cells(i, 1), 2) = "BE" Or Left(Cells(i, 1), 2) = "N:" Or Left(Cells(i, 1), 2) = "VE" Then
Rows(i & ":" & i).Delete
End If
Next
UsedRange.Replace "*:", ""
m = 0
n = 3
j = 1
For i = 1 To UsedRange.Rows.Count
If IsNumeric(Left(Cells(i, 1), 1)) = False Then
m = m + 1
Cells(m, 2) = Cells(i, 1)
n = 3
Else
Cells(m, n) = Cells(i, 1)
n = n + 1
End If
Next
End Sub
Sub setVcf() '放在sheet2用于生成
Application.ScreenUpdating = False
s = ""
For i = 1 To UsedRange.Rows.Count
s = s & "BEGIN:VCARD" & vbCrLf & "VERSION:3.0" & vbCrLf & "FN:" & Cells(i, 1) & vbCrLf
For j = 2 To 4
If Cells(i, j) = "" Then
ElseIf Left(Cells(i, j), 1) = "1" Then
s = s & "TEL;TYPE=手机:" & Cells(i, j) & vbCrLf
Else
s = s & "TEL;TYPE=固话:" & Cells(i, j) & vbCrLf
End If
Next j
s = s & "END:VCARD"
Next i
Open "D:\1.txt" For Output As #1
Print #1, s
Close #1
End Sub学习
vb读写xls、数据库文件
陈燮函 发表于2023-07-25 浏览189 评论0
引用ADO Library对xls文件进行修改。
可以在xls文件打开的情况下直接操作，并在Excel或Wps中直接更新。
Private Sub Command1_Click()
On Error Resume Next
Dim adoConn As New ADODB.Connection
Dim adoReco As New ADODB.Recordset
Set adoConn = New ADODB.Connection
adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=D:/1.xls;Extended Properties='Excel 8.0;HDR=Yes'"
Sql = "Num int, Name char(20)"
adoConn.Execute "Create table [D:/1.xls].Sheet1" & "(" & Sql & ")"
adoConn.Execute "insert into [sheet1$] values (999,'zichu')"
adoConn.Execute "insert into [sheet1$] values (888,'jingyi')"
adoConn.Execute "UPDATE [sheet1$] Set Name='JingYi' Where Num=888"
adoConn.Close
Set adoConn = Nothing
End Sub学习
随机序列生成
陈燮函 发表于2023-07-25 浏览192 评论0
仅单字符，输入字符串递增时输出结果也递增。
Sub createArr()
Application.ScreenUpdating = False
Dim s As String
s = InputBox("请输入字符串")
Cells(1, 2) = "开始时间：" & Format(Now(), "hh:mm:ss")
funArr s
Cells(2, 2) = "结束时间：" & Format(Now(), "hh:mm:ss")
End Sub
Function funArr(str1 As String, Optional str2 As String = "", Optional m As Long = 1)
Dim a() As String
If Len(str1) = 1 Then Exit Function
For i = 0 To Len(str1) - 1
ReDim Preserve a(i)
a(i) = Mid(str1, i + 1, 1)
str0 = a(i) & Replace(str1, a(i), "")
If Len(str0) = 2 Then
Cells(m, 1) = str2 & str0
m = m + 1
End If
funArr Mid(str0, 2) & "", str2 & Left(str0, 1), m
Next
End Function