假无崖子的个人资料

原型的照片解析与零件设计纸模型的目标是用纸材尽可能客观的表现原型的外观形象。原型具体是指对象的几何参数与色彩等信息，由它们产生平面的图纸，再制作出立体的模型。通常原型是复杂的，需要将其分割出若干局部，形成单独的零件，然后拼接汇集还原出整体。由原型转化为图纸，技术难度很大，普通人不易掌握，不得不放弃尝试，以购买或下载方式取得。所以难得体会设计图纸的过程与乐趣，是一种遗憾。对于普通人来说，获取原型信息是不容易的，即使拿到实物也难恰当测量，但原型的照片却可从网上获取，且可有各种类型。照片是原型的客观表现，精准和全面(结合不同照片)，关键在于如何挖掘其中的数据。为此本人自编了相关的软件，配合完成相应的任务。经初步的实践，感觉从设计到制作的全过程，都能方便有效的参与，融入智慧和选择，是很棒的体验提升。于是向大家展示和解释，以博各位开心与理解。立体图能反映物体的三维形象，常见的立体图分透视与轴测两种。透视图中物体呈近大远小效应，轴测图没有这种深度变化，更加简单易辨。照片应该是透视图，但如果物距远大于原型尺寸时，原型的深度可忽略，能近似为轴测图。其判别标准也直观，原型中的一组平行线，若在照片中仍呈平行，则可按轴测图操作。道理很简单，平行线各处的间距相等，表明无明显的远近差异。此状态下照片能按轴测图规则测量尺寸，提取原型的参数实现解析。

3Dh纸模技术薄壁空心纸模具有门坎低、花费便宜，而立体形象和色彩表现不错，设计与制作难度适中的特点，有大量的爱好者。不过其采用的技术日趋落后，渐渐跟不上新的时代了。 3Dh纸模技术在设计层面的建模，分割零件，外表面展开，色彩绘制和出具图纸，诸方面均不同于传统方法；在制作层面则使用普通打印纸、桥接拼合、形状与位置强制回归，以规范的手法将薄纸出品成仿真程度很高、保形抗外力极强，接缝质量颇佳的纸模型。当然这只是楼主的一面之词，需要有众模友的认同。因此想利用作品，逐步介绍3Dh纸模技术的细节与特色，供大家评判与欣赏。此纸牛的原形源于唐代古画“五牛图”之一，用图片取代建模，采集其形状和色彩，作为图纸的基本素材。

本吧涉及的纸模都是薄壁空心类型的。此类纸模据我所知，只要稍复杂的，就需要使用六角大师软件，出具图纸，然后在此基础上，制作还原出作品。本贴之所以名为"环节纸模"，是因为其上的纸模，是用另外的流程处理的，有别于通常的方式。此类纸模的初始原型是一张照片，取其形状与色彩，移植到图纸上，再用纸材制出零件，组合后重现目标。由于其中绝大部分零件，都具备封闭纸环的特征，故称为环节纸模，与其它纸模有明显的差异。下面的照片是个实例的真实展现，相比传统的应该不算太差吧。当初创建环节纸模类型的初衷，是出于原来的作品产生模式，存在某些固有不足，想进一步提高纸模质量，难以实现，所以另辟途径。现在似乎有点成效了，至于个中的理由、手法和细节，打算逐步慢慢介绍分析，希望能对纸模的爱好者们有所启发。

请问吧主删帖的原因本人今天才入吧，9、10点时发了一名为“土法上马的3D打印”贴。大约被审查了几十分钟后，此贴刊出。于是打算续贴，但提交时则被告知此贴已不存在了。回看发现原贴遭删，等了数小时后，仍是原状，不可能再现了。其实这首贴乃是投石问路，观察一下此吧的环境是否宽容，值不值得关注，所以贴的内容较含糊。真实的目的是：对于飞机模型的合金与板件两种，总觉得自主成分少，不过瘾，希望开辟新的类型。因小有成功，想与吧友分享，并逐渐介绍细节。然而竟遇此结果，大失所望。当然此贴既不是兴师问罪，也非乞求网开一面，只是若双方都认为有进一步交往的愿望，就重新来过。谢谢！

照片形体的数据挖掘纸模型工艺包含设计和制作两部分，本吧的贴大都涉及制作，谈及设计的较少。设计是根据所建模型，出具制作图纸的产生过程。此处的模型是依据实物原型的三维信息进行简化，在计算机上虚拟的。而像交通工具、武器装备此类的实物，局外人很难得到详尽的资料，希望自行设计纸模型极不容易。通常实物原型的相关照片能在网上搜到，而且质量与数量均不差。虽然从照片可宏观了解实物的大致形体，但过于粗略不能用于建模。然而照片是实物的客观记录，有关几何信息是被隐含在其中的。若借助相关工具和相当技巧，能否挖掘出实物足够精度的三维参数，满足建模的需要呢，本人觉得值得一试。为了降低难度，整个过程须分多步走。建模的实物对象一般都有较复杂的形体，可将其看成是若干个简单部件的组合。每次仅面对某个简单部件，忽略其余部件，独立的分析，较易找出结果。然后利用查出的数据，进一步探索相邻部件。以此逐个积累、拼合叠加，最终掌握全部的所需参数。照片用平面记录了实物的立体信息，遵循一套物理法则。只能据此反推，才可能正确的找回初始的三维数据。所以了解其规律，是必备的相关知识。视角为专业术语,表示视线相对于物体面的倾斜程度。其改变时照片上的形象随之变化，即使是简单形体，结果也能千姿百态。准备工作的第一步，先找寻视角变化与图形特征的关系。考察一个正方体，斜对它时，常可看见三个面。这三个面的原状是相同的正方形，但此时视觉形象则是不同的平行四边形。有几个举例见下图，如果移动眼睛，改变视角会引起上平面形状改变，也就是视角决定了上平面的形状参数(边长比与夹角)。当正方体上平面的形状选定后，与其相连棱的角度也与之相关，不再变化而形成对应图像。若将正方体的一个顶点看作是坐标系的原点，则不同的视角使坐标轴的夹角跟着相应变化。这是总结出的第一条规律。此时顶点的各边长比也被固定了，但因视觉长度与真实长度关系复杂，不宜直接测量，关于这一点下次再谈。

如果粗略的将船模结构分类，甲板之上为上层建筑，之下为船体。前者不管多繁杂，皆可以分解成简单形体的组合，而后者虽然看似简洁，却是难以描绘的不规则形体。几乎毫无例外，船体造型全采用龙骨-蒙皮法构建。一般来说，纸船模的龙骨是采用厚纸材制作的，其成本贵，结构复杂，在与蒙皮粘合时，存在匹配差和操作难的缺陷。在定本贴的标题时，并没有选定目标船舶，而是想先做一热身，开发出某种无龙骨的船体设计制作方法。希望能用成本低的薄纸制作，且尽量改进传统手法的不足之处。若能得手，则再选择某具体船舶，设计制作其船模以验证。

飞机C919 选择目标原型的图片，并将其分解成若干的切片，每个切片化成一个纸模型的零件。切片上承载着相关的信息，但它是平面的，缺少纵深尺寸(Z方向)。按某些原则，设计切片的纵深尺寸，使其为完整的立体，并把外表面内容映射到纸上。此零件是一个附色的纸环，为纸模型整体构造中的一层。为了使纸环保形不瘪，按切片的外形，构建梁形内撑；根据纵深尺寸，再加与梁成垂直的跨内撑进一步定位。相邻的纸环具有同一个切口截面，相互能够拼合，从而搭建出更大的结构。这种具有接续条件的平面切口零件，被称为续层，而这种设计制作方法就是续层纸模。此法没有整体建模，只根据切片作零件设计。用薄纸构造外表面，在内撑帮助下形成刚性形体。不用贴图或涂彩，直接将切片色素映射到展开图上。所以续层纸模是一种低成本、小工作量的纸模新玩法。本贴的目的只是想用此法制作一架飞机模型，尝试不同类型，验证效果。随便就选了国产的C919型，希望整个过程能正常展开。由于目前并无现成的图纸，是设计一步制作一步，观察半成品，再规划后面的内容。这样始终都有成就感或失败感，不失为某种乐趣。

空心纸模是纸模型中占比很大的一类，其设计及制作已有现成的软件（好像是源于日本的）。然而总觉得按此生成的纸模存在一些不足的地方，影响纸模的质量。为了改进空心纸模的设计制作水平，LZ自创了一套不同的模式。这种续层纸模的零件分割、立体设计均为非传统的。展开图是连续曲面生成的，免除了多边形平面立体近似展开的误差现象，使两相邻零件可无缝对接。因此采用底衬桥接，接缝平顺过渡，胜过贴边粘接形式。由展开图复原纸模的制作，不仅要求形状对应，而且各关键点的相对位置也必须准确。但纸质材料天生柔软易变，空心纸模的外层自身难精准定位，不免出现走形。续层纸模每个零件都有与其匹配的梁跨内架，既能确保零件的关键形位，也不妨碍零件的粘接操作。纸模制作纸的厚薄，关乎其变形的难易与保形的维持。厚纸虽然有助于成形的稳定，但在制作阶段，折弯反弹明显，不利精确的塑形。续层纸模因所有零件都有梁跨内架，保形无忧，故常采用80g的薄纸制作，自成特色。续层纸模是基于单个零件设计理念，再由一个个续层搭建而形成整体的，所以并无建模一说，而且零件表面的彩绘，也是各自独立的。但接缝两侧的彩绘，又应该互为相关，显然传统的贴图方式在此已不再适用。虽然没有模型，但续层纸模的原始模特通常是照片(照片平面被切分为零件续层素材)，这里运用到是附图展开的技术，将零件续层素材形状，裹胁其上的色素点，一起生成彩色展开图。源于同一照片的相邻续层零件，彩绘自然也合成原图形象。现在不宜作过多的描述，就展示几张图片来辅助了解一下吧。

衣物的褶皱能模拟吗衣物（织品）通过褶皱，可以容易的变形。当然织品的经纬丝结构，能让其微位移（伸缩），而纸张则是密实不可微位的。但是从宏观上看，其基本面积和展开形状，并未变化。因此，想请教各位大师，纸张能否像下图所示，折出类似的形状（弯曲处不瘪，有足够的通道）。

纸塑模块

数字3D纸模从平面图像原型中演绎出数字3D的纸塑模块，应该是可行的。确定曲线的坐标点，用直纹素线联接红、绿曲线，使整个空间曲面被数字3D描绘。其特点为:直纹延展曲面，边界是两条平面曲线。外围是模块的精确曲面展开图，理论上能毫无误差的还原出模块原型(空间曲面)。

纸塑模块：人像的实验鲜活灵动的人物千姿百态，而画龙点睛则指出，面目在表现人物形象中，是举足轻重的一环。根据照片写实塑造人脸，是放弃纸模的程式化面孔的直接方式。

纸塑模块：兽首玛瑙杯国宝级文物：兽首玛瑙杯其优雅圆润的曲线，和晶莹剔透的色彩，配上别样争辉的黄金兽嘴，堪称顶级的古代工艺品。虽多年前就对其仰慕佩服，而这些引人入胜之处，恰与纸模型拙于表达的弱势项目，相互一一对应，真让人沮丧不已。当下手上的功夫已今非昔比，或许到了追寻那遥远心梦之时，尊贵的神器啊，能否借得你的一缕魂？

纸塑模块：立体化古风牛这是从网上搜来的古人画作“五牛图”之一的图片。将此图作为原型，采用纸塑模块进行立体化，生成纸模型。通过此过程对纸塑模块的一些新观念和新手法，加以阐述。

纸塑模块是一种制作纸模的不同方式。想将照片上的青蛙做原型。先在绿线的位置上切一刀，则截面的外围应是某种封闭曲线。粗略的将其视为椭圆，那么绿线的长度就是纵轴，再自定一个横轴长(可调)，完成此曲线的初设。横轴的位置在最高点上，但未必处于绿线的对称中心，如果移到短蓝线处，曲线就是某种改造后的椭圆了(其前半纵轴小于后半纵轴)。再加一刀，从青蛙上取下一段来。根据取景框的尺寸，另加两自定的横轴长，这些参数就已建立一个模型。将这个简单模型按曲面舒展，能得出足够精度的展开图。结合展开图与取景框内的图像，可以拿到此模型相应的贴图。尽管有某些遮挡、前后端点处因视角局限，贴图存在缺陷，但整体效果不错。据此可修整出更好的贴图来。建立模型的参数、曲面的展开图和照片导出的贴图，三者是精确还原的基础条件。纸塑模块自己完全独立的刚性成形，不需要其他的边界辅助。将原型裁成若干个模块，截口形成模块接口尺寸，相互吻合、接龙搭建，这些并无特别之处。只是纸塑模块的工艺，有许多非传统的取材与操作，是优是劣，各人自辨。下面一一道来……。

求三角形内点的变换三角形ABC(x1,y1; x2,y2; x3,y3)弹性的移到三角形A‘B’C‘(x4,y4; x5,y5; x6,y6)处，求其内点P(x,y)变换后的P’点坐标(x',y')。

曲面纸模新制作现代纸模制作是某种机械制造流程：展开原型的外表面生成图纸，依据图纸规范生产零件，组装零件联接出成品。纸艺大师是用万能的多边形平面展开原型的，因此图纸的目标是棱面立体形状的。这对于建筑、枪械等人造物来说，图纸目标与成品基本一致，但对曲面的人物或动物，图纸目标只是成品粗略近似，需要进一步改造。改造的方法就是熟纸，用专业语言描述，就是有意放大图纸的误差，歪曲目标去适应成品。这里所说的误差包括尺寸和位置变动，所以原来可保障图纸规范的桥接、内撑等手段，反而影响了成品的生成，只好放弃。因此曲面纸模的制作偏离了机械制造流程，在一定程度上回归了传统的目测手工艺。也就是说曲面纸模的制作是粗糙的，而且是难以提高精度的。这所指的包括粘接的密合、曲面的饱满和圆润、组件的位置积累误差等等。这里的症结在于多边形平面展开，除非出具与成品匹配的图纸，否则问题是无法解决的。

反思：简单或复杂、平凡或高深？这是一个哲学问题，值得各位认真考虑下面的设计模型和实现代码。'手工添加一个Picture1,不作任何设置 Option Explicit Dim uu As Boolean Private Sub Form_Load() Me.ScaleMode = 3: Picture1.ScaleMode = 3 '像素单位 Me.Caption = "椭圆形状与位置的调整" Picture1.AutoRedraw = True '避免闪烁 Controls.Add "Vb.Shape", "Sha1", Me '添加椭圆形 Controls(1).Shape = 2: Picture1.BorderStyle = 0 End Sub Private Sub Form_Resize() If Picture1.BackColor <> &HFFFF80 Then '首次成形 Picture1.Move 0, 0, 60, 60 Controls(1).Move 150, 80, 100, 80 Picture1.BackColor = &HFFFF80: Controls(1).Visible = True Picture1.Line (0, 19)-(60, 19), 255 Picture1.Line (0, 39)-(60, 39), 255 Picture1.Line (30, 0)-(30, 75), 255 Picture1.CurrentX = 3: Picture1.CurrentY = 3 Picture1.Print "宽窄 " & CStr(Controls(1).Width) Picture1.CurrentX = 3: Picture1.CurrentY = 23 Picture1.Print "高矮 " & CStr(Controls(1).Height) Picture1.CurrentX = 3: Picture1.CurrentY = 43 Picture1.Print "横移纵移" '完成界面设计 End If End Sub Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim rr As Integer, tt As Single uu = True '鼠标按下 St: tt = Timer: rr = 1: If Button = 2 Then rr = -1 '左右键 If Y < 20 Then rr = rr * 2: If X > 10 Then rr = rr * 10 '细调与粗调 If Controls(1).Width + rr < 6 Then Controls(1).Width = 6 '极限 Else Controls(1).Width = Controls(1).Width + rr '变化 End If 'v_显示数值 Picture1.Line (32, 1)-(58, 17), &HFFFF80, BF Picture1.CurrentX = 3: Picture1.CurrentY = 3 Picture1.Print " " & CStr(Controls(1).Width) ElseIf Y < 40 Then rr = rr * 2: If X > 10 Then rr = rr * 10 If Controls(1).Height + rr < 6 Then Controls(1).Height = 6 Else Controls(1).Height = Controls(1).Height + rr End If Picture1.Line (32, 21)-(58, 37), &HFFFF80, BF Picture1.CurrentX = 3: Picture1.CurrentY = 23 Picture1.Print " " & CStr(Controls(1).Height) Else If X < 30 Then If X > 10 Then rr = rr * 10 If Controls(1).Left + rr < 0 Then Controls(1).Left = 0 ElseIf Controls(1).Left + rr > Width / 15 - 0.6 * Controls(1).Width Then Controls(1).Left = Width / 15 - Int(0.6 * Controls(1).Width) Else Controls(1).Left = Controls(1).Left + rr End If Else If X > 40 Then rr = rr * 10 If Controls(1).Top + rr < 0 Then Controls(1).Top = 0 ElseIf Controls(1).Top + rr > Height / 15 - 0.6 * Controls(1).Height Then Controls(1).Top = Height / 15 - Int(0.6 * Controls(1).Height) Else Controls(1).Top = Controls(1).Top + rr End If End If End If Do While uu = True '等待鼠标弹起 DoEvents '计时循环 If Abs(Timer - tt) > 0.22 Then GoTo St Loop End Sub Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) uu = False '鼠标弹起 End Sub

GDI+能完成这些操作吗没有玩过GDI+，但听说其也有某些局限，想问问高手下列操作能实现吗？ 1.输入任意凸四边形的剪贴，返回是有角度(任意)旋转的非矩形图片，即背景透明。 2.输入椭圆的剪贴，返回是有角度(任意)旋转的非矩形图片，即背景透明。因为本人准备就此编程，初步方案已拟定了。如果GDI+搞不定，就编写，否则放弃(因为无实用价值)。

【记录贴】探究鼠标消息的坐标设置 { 题外的话：观察了一段时间，发现本吧的贴多是基础型的，即初学者不会或不熟悉基本套路的提问、求助。此类贴不需要太多交往即可解决。另一类是高深贴，研究的问题专业且狭窄，懂行对路的人不多，难得回帖。而居中的大多属展示或成品贴，其他人基本上插不上话。随着对学生贴的变相抵制后，本吧的贴数锐减，管理人员苦恼不已，经常拿出历史贴抵数。建议开发中间档次的新模式，楼主提出问题或展示半成品，并非求助或能力不够，而是希望更多的吧友参与，集思广益、开拓思路、切磋技艺，增加有质量的回帖数目。} 问题的提出：软件运行中最重要的输入是鼠标。用SendMessage模拟鼠标点击，是一种重要的编程手段。然而精确的确定X、Y坐标，在64位机时成了大问题，第四个参数高位表示Y、低位表示X，好像失效了。我自己试过，SendMessage(Hwnd,&H201,0,0)的定位是X=-54000，Y=270。按道理 0 在十六进制中照样是 0，因此应是X=0、Y=0才对。我也上百度查过，其他人也对此坐标值设置，毫无对策，尽是失败。不过鼠标的单击响应了，说明此函数仅是部分失效。我想真实的鼠标单击响应，其实系统也是靠向应用程序发消息实现的，应该也是用的此函数。那么截获它发的消息，再与MouseDown(...,X,Y)得到的XY值比较，可以找出新的赋值规则。如何能取得真实鼠标点击时系统发出的消息，分离出含XY的内容？接着 .....

调用"直启链接"模式的尝试 "直启链接"模式有如下特点： 1.使用方便。只需将调用方和链接方置于同一文件夹下就可以，没有诸如"引用"等附加操作。 2.指引清晰。链接方exe可独立运行，其界面显示了调用函数的格式、返回特征及视觉表现等，犹如使用说明书。 3.标准明确。T字头的调用函数返回文本(Text)，D字头的调用函数返回图片(Data)。文本可分解出若干子项，本例就是返回了一个200多元素的数组。(剪贴板通讯) 4.编写容易。调用方和链接方均为普通exe文件，可直接用常规的VB手法编写。所用的通讯编程技巧在下面的基础代码中，几乎都能找出，门槛较低。也可以在贴吧上，将你不想公开的代码放在链接方exe，调用方开源。这样别人可以完整的运行，有限参与和体会。半开源有利于相互深入讨论。若还忌讳，则可将链接方exe写成期限运行式，仅切磋时有效。基础代码(调用方)： Option Explicit 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 Dim Hwnds As Long, Op() As String Private Sub Form_Load() Clipboard.Clear Clipboard.SetText CStr(Form1.hwnd) '句柄发给链接方 If Dir("LJ1.exe") = "" Then MsgBox "链接路径错": Exit Sub End If Shell "LJ1.exe", 1 '启动在本文件夹下的链接方exe Controls.Add "VB.Image", "Ima1", Me '添加Image控件 Controls(0).Move 0, 0, 1200, 1200 '用于转移图片 Hwnds = Val(Clipboard.GetText) '收链接方的句柄 If Hwnds = 0 Then MsgBox "链接失败!" End Sub Private Sub TD(ByVal Names As Variant) Dim rr As Single If UCase(Left(Names, 2)) = "T_" Or UCase(Left(Names, 2)) = "D_" Then Clipboard.Clear Clipboard.SetText Names '发调用函数申请 Form1.Tag = "1" '设未回复记号 SendMessage Hwnds, &H201, 0, 0 '向链接方发鼠标消息 SendMessage Hwnds, &H202, 0, 0 '通知申请调用 rr = Timer '设0.2秒的时限 Do DoEvents '双方在沟通等待 If Form1.Tag = "" Then Exit Do '有了结果，直接跳出 End If Loop Until Abs(Timer - rr) > 0.2 If Form1.Tag <> "" Then Form1.Tag = "": MsgBox "通讯失败!" End If Else MsgBox "调用语法错!": Exit Sub End If End Sub Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) If X <= 0 Then '链接方发来的鼠标消息 If Clipboard.GetFormat(1) = True Then Op() = Split(Clipboard.GetText, ",") '分解返回值 ElseIf Clipboard.GetFormat(2) = True Then Controls(0).Picture = Clipboard.GetData '得到图片 Else '剪贴板中无内容 MsgBox "调用失败!" End If Form1.Tag = "" '消未回复记号 End If End Sub Private Sub Form_Unload(Cancel As Integer) Shell "Taskkill.exe /im:LJ1.exe" '关闭链接方 End Sub 下面为应用部分的代码，画椭圆仅几行解决问题，下图为效果图。 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim pp As Integer If X > 0 Then '真实鼠标事件 Call TD("D_oval(1500,900,30,255,&HFFFFFF)") '调用D Form1.PaintPicture Controls(0).Picture, 0, 0 '拿到贴图 Call TD("T_oval(1020,750,-15,3000,2100)") '调用T PSet (Op(0), Op(1)), &HA000 For pp = 2 To UBound(Op) Step 2 '用数组描点画图 Line -(Op(pp), Op(pp + 1)), &HA000 Next pp '^ String的Op(pp),可直接当数字用 End If End Sub链接方压缩文件藏在第一张图片里，下载后扩展名改为rar即可解压。如果你用了觉得不错或可以，就点赞一个。

Win7中动态数据交换DDE失效问题用Win7及更高版本时，动态数据交换DDE失效。请问有没有补救措施，或简单易行的替代方案？

软件的期限运行代码有偿为客户编程，需要给对方试用和付款的时间。遇上老赖怎么办？加入这段代码，生成期限运行exe软件，发给对方。对方守规，再重发标准exe软件，否则他也讨不到便宜。 Option Explicit Private Sub Form_Click() ' 要换Sub Dim pp As Integer, aa As String, bb As String Const Stops = "2019/08/08" '期限 If Dir("C:Windows/SchedlgU.Txt") <> "" Then bb = "C:Windows/SchedlgU.Txt" ElseIf Dir("C:Windows/Tasks/SchedlgU.Txt") <> "" Then bb = "C:Windows/Tasks/SchedlgU.Txt" End If If bb <> "" Then '防止系统时间被篡改 Open bb For Input As #1 Do While Not EOF(1) Line Input #1, bb pp = InStrRev(bb, "/") If pp > 0 Then bb = Left(bb, pp + 2) pp = InStrRev(bb, " ", pp) bb = Trim(Mid(bb, pp + 1)) If Len(bb) < 10 Then '换成标准日期格式 If Mid(bb, 7, 1) = "/" Then bb = Left$(bb, 5) & "0" & Mid$(bb, 6) If Len(bb) = 9 Then bb = Left(bb, 8) & "0" & Right(bb, 1) End If If bb > aa Then aa = bb '日期排序 End If Loop Close #1 Else '未找出有效路径时 aa = Left(Now, 5) & Right("0" & CStr(Month(Now)), 2) & "/" & Right("0" & CStr(Day(Now)), 2) End If If aa < Stops Then Print aa Else '超时限，则进入设计好的死循环 For pp = 1 To 20010 If pp > 20000 Then DoEvents pp = 0 End If Next pp End If End Sub

人机对话升级版前段时间，为解决某吧友动态修改程序的问题，本人曾编写过"中断"和"人机对话"两个Sub。当然其再无反馈，不知最终效果。其中"人机对话"是基于 CallByName 函数扩展的，操作不够友好，只能单句单步的进行。目前我又推出了"人机对话"的升降版，采用Vbs编辑。经过改造，功能大增，在运行中添加代码、实现效果的能力很强，应该值得欣赏研究。不够也有不足，例如Vbs编辑无法使用数组，使其编程能力打了折扣。希望各位高手能参与，提出解决方法，完善此项目，让大家受益。Option Explicit Dim Vbs As Object Dim BB As String, SS As Integer Private Sub Command1_Click() Vbs.ExecuteStatement Text1.Text 'Vbs编辑 End Sub Private Sub Form_Load() Set Vbs = CreateObject("MSScriptControl.ScriptControl") Vbs.Language = "VBScript" '启用编译器 Vbs.AddObject "Form1", Me, True '与原窗体整合 Text2.Text = "" 'Text2真实作用相当于过程函数 Text2.Visible = False '隐藏，免得被乱用 End Sub Private Sub Text2_Change() If Text2.Text = "" Then Exit Sub Select Case Left$(Text2.Text, 1) Case "1" 'Vbs编辑不具备窗体打印能力，需要变通追补 Print Mid$(Text2.Text, 3) Case "2" '追补窗体画线能力 Dim CC() As String CC = Split(Text2.Text, ",") If UBound(CC) = 4 Then Line (Val(CC(1)), Val(CC(2)))-(Val(CC(3)), Val(CC(4))) ElseIf UBound(CC) = 5 Then Line (Val(CC(1)), Val(CC(2)))-(Val(CC(3)), Val(CC(4))), CC(5) End If End Select Text2.Text = "" End Sub

奇遇ShanTie,莫名,想再试自由四边形的剪贴

用 Collection 为核心的通用、高效排序子程序只用一个 Sub ,通用于数字、字符串，升序、降序，不同的边界条件。高效运算：没有元素交换，至多搜索半数的已排元素，就能将新元素插值到准确的位置上。Option Explicit Dim Si(10) As Single, St(3 To 12) As String Private Sub Form_Load() Me.AutoRedraw = True Command1.Caption = "原始数据" Command2.Caption = "" Command2.Enabled = False End Sub Private Sub Command1_Click() Dim pp As Integer, rr As Integer Cls Si(0) = ((Timer * 100) Mod 1673) / 10 St(3) = CStr(Si(0)) & Right$(CStr(Si(0)), 2) For pp = 1 To 10 Si(pp) = Rnd(Si(pp - 1) - Si(0)) * 40 If InStr(1, Str(Si(pp)), "E") > 0 Then If pp > 1 Then Si(pp) = Si(pp - 2) '数值相等 Else Si(pp) = -Si(pp - 1) '负值 End If End If If pp < 10 Then St(pp + 3) = Trim(Right$(Str(Si(pp)), 6)) rr = InStr(1, St(pp + 3), ".") If rr > 0 And pp Mod 2 = 1 Then St(pp + 3) = Trim(Mid$(St(pp + 3), rr + 1)) End If End If Next pp Print " 数字", " 字符串" For pp = 0 To 10 Print Si(pp), If pp < 10 Then Print St(pp + 3) Next pp If Fix(Si(0)) Mod 2 = 1 Then Command2.Caption = "数字排序" Else Command2.Caption = "字符排序" End If Command2.Enabled = True End Sub Private Sub Sort(X1, Up As Boolean) Dim pp, rr, ss, Lb As Integer Dim Va As New Collection '相当于 Va() As Variant Lb = LBound(X1) rr = UBound(X1) - Lb Va.Add X1(Lb) '添加第一个元素 For pp = 1 To rr If (X1(Lb + pp) <= Va(1) And Up = True) Or _ (X1(Lb + pp) >= Va(1) And Up = False) Then Va.Add X1(Lb + pp), BEFORE:=1 '放最前面 ElseIf (X1(Lb + pp) >= Va(pp) And Up = True) Or _ (X1(Lb + pp) <= Va(pp) And Up = False) Then Va.Add X1(Lb + pp) '追加在最后 Else '非极值则插值到合适处 ss = 1 + (pp - 1) \ 2 '从中间开始 Do If (Up = True And Va(ss) <= X1(Lb + pp) And Va(ss + 1) >= X1(Lb + pp)) Or _ (Up = False And Va(ss) >= X1(Lb + pp) And Va(ss + 1) <= X1(Lb + pp)) Then Va.Add X1(Lb + pp), AFTER:=ss '插值到ss后 Exit Do ElseIf (Up = True And Va(ss) >= X1(Lb + pp) And Va(ss - 1) <= X1(Lb + pp)) Or _ (ss > 1 And Up = False And Va(ss) <= X1(Lb + pp) And Va(ss - 1) >= X1(Lb + pp)) Then Va.Add X1(Lb + pp), BEFORE:=ss '插值到ss前 Exit Do ElseIf (Up = True And Va(ss) < X1(Lb + pp)) Or _ (Up = False And Va(ss) > X1(Lb + pp)) Then ss = ss + 1 '向后移一位 Else ss = ss - 1 '向前移一位 End If Loop End If Next pp '下面内容会改原数组 For pp = 0 To Va.Count - 1 X1(Lb + pp) = Va(pp + 1) Next pp End Sub Private Sub Command2_Click() Dim pp As Integer, tt As Boolean Form1.CurrentX = 3300 Form1.CurrentY = 0 tt = Si(8) > Si(3) '升降序也是随机的 If tt = True Then Print " 升排序" Else Print " 降排序" End If If Command2.Caption = "数字排序" Then Call Sort(Si, tt) For pp = 0 To 10 Form1.CurrentX = 3300 Print Si(pp) Next pp Else Call Sort(St, tt) For pp = 3 To 12 Form1.CurrentX = 3300 Print St(pp) Next pp End If Command2.Enabled = False End Sub

降低PM2.5浓度 "救救孩子"的假乞丐贴，**问题有偿服务的互动贴，正在把本吧拉向校园外的跳蚤地摊。或许有人会说，愿打愿挨，关你何事。但它玷污了本吧的界面，降低了本吧的档次，搅和了本吧的学习研究氛围！各位相关的大佬们，偶然一次的几十元不会提升你的收入档次，却可以有效降低你的形象，蚕食你的品质，助长教育界的歪风。相信你不会指望它来养家。呼吁广大爱好者抵制此类不良行为，真正的救救孩子！

一个横行霸道的蛋 '此粉色的蛋无视其它程序，肆意在屏幕上乱窜。 '手工操作: 窗体起始在屏幕中心 StartUpPosition = 2（重要） '窗体无边框 BorderStyle= 0, 添加形状控件 Shape1 和计时器 Timer1 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 Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Dim R1, S1, P1 As Integer Private Sub Form_Load() Shape1.Left = 0 Shape1.Top = 0 Shape1.BorderColor = &HFF00FF '粉红的蛋 Shape1.BackStyle = 0 Shape1.BorderWidth = 2 Shape1.Shape = 2 Shape1.FillStyle = 1 Shape1.Width = 1200 Shape1.Height = 900 Timer1.Enabled = True Timer1.Interval = 30 Me.BackColor = 255 Me.Width = 1200 Me.Height = 1200 SetWindowLong Me.hwnd, -20, &H80000 SetLayeredWindowAttributes Me.hwnd, &HFF, 0, 1 '透明窗体 P1 = (Timer * 100) Mod 12 '随机运行路线 End Sub Private Sub Timer1_Timer() If R1 = 0 Then R1 = 2 * Form1.Left + 300 '获得边界值 S1 = 2 * Form1.Top + 300 End If SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 ' 窗体置顶 Form1.Left = Form1.Left + 30 * Cos(P1 * 0.523) '运动 Form1.Top = Form1.Top + 30 * Sin(P1 * 0.523) If Form1.Left < 120 Or Form1.Left > R1 Or Form1.Top < 120 Or Form1.Top > S1 Then If Shape1.Height = 900 Then '变形 Shape1.Height = 1200 Shape1.Width = 900 Else Shape1.Height = 900 Shape1.Width = 1200 End If P1 = (P1 + 6) Mod 12 '反弹 P1 = P1 - 2 + ((Timer * 100) Mod 5) '随机变角度 End If Form1.SetFocus '保持键盘可响应 End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = 97 Then '键盘按下"a"键则退出 End End If End Sub

历史贴子想问一问本吧的管理者，历史贴子（即第一页之外的）是不是不能浏览和访问？如果能，如何操作？

非矩形(椭圆)图形剪贴前段时，看到不少爱好者热衷用 VB6 制作 UI ，想助力他们一把，编写了非矩形图形剪贴工具。选择难度大的椭圆形状为例，其它则可举一反三。用形状控件 Shape1 在资源图像上圈地，且变化大小肥瘦、移动位置，可看得一清二楚。然后用一过程将其 Copy 至目标图像处，很方便。 Private Sub TuoYuan(ByVal x1 As Single, ByVal y1 As Single) Dim pp As Integer, rr As Single For pp = 1 To Shape1.Height Step 15 rr = Shape1.Width / 2 * Sqr(1 - (Shape1.Height / 2 - pp) ^ 2 / (Shape1.Height / 2) ^ 2) 'pp 为椭圆纵轴坐标, rr 为椭圆横轴坐标 Form1.PaintPicture Form1.Picture, x1 - rr, y1 - Shape1.Height / 2 + pp, 2 * rr, 15, Shape1.Left - rr + Shape1.Width / 2, Shape1.Top + pp, 2 * rr, 15 Next pp End Sub Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Call TuoYuan(X, Y) End Sub

求快速获取窗体的视觉图像的方法如何能不用截图的方法，快速地获取窗体或桌面当前的视觉图像(窗体上有其它控件的模样)。谢谢。

半透明图片的简易制作 Option Explicit Private Sub Form_Load() Picture1.Picture = LoadPicture("D:\李宇春.bmp") Picture2.Picture = LoadPicture("D:\佛像.bmp") End Sub Private Sub Picture3_Click() Dim pp As Integer Picture3.Picture = Picture1.Picture For pp = 0 To Picture3.Height Step 30 Picture3.PaintPicture Picture2.Picture, 0, pp, Picture3.Width, 15, 0, pp, Picture3.Width, 15 Next pp Picture3.Picture = Picture3.Image End Sub

最近3D纸模网上不了？不知是我自己的问题，或是网站的问题。请问各位大佬，你们是否也上不去？什么原因？

求还原出此圆台可见面展平后图像的实施方案

求助：如何获取外来图片中某点的颜色值各位大师，我想用winapi的GetPixel函数，输入hdc和xy,但结果一直返回-1，所以来请教。需要的是如何从外来的图片中，获取其中某点的颜色值。哪种函数？谢谢！

求助:怎样获取外来图片上某点的颜色值？各位大师：我曾试用winapi的GetPixel函数，给出hdc和x与y，但始终都只返回-1,因此只好作罢。请问有无其他方法，输入x,y能返回图片该点的颜色值？

求助提问各位大师，获取图片上某点的颜色，该用什么函数？

求助提问请问：获取图片某点颜色该用什么函数？