注册 |登录

MT-Pioneer分享 http://blog.sciencenet.cn/u/陈小斌 凡普世，皆专制。

留言板

facelist

您需要登录后才可以留言 登录 | 注册

IP: 122.68.101.*   [15]zhaoyazhe   2012-10-22 22:19
陈先生，您好！
打扰您了。代码如下：
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Math,typinfo, StdCtrls;

Const   //记录设计时的屏幕分辨率
   OriWidth=1366;
   OriHeight=768;


{type TPropInfo = packed record
PropType: PPTypeInfo;
// 属性类型信息指针的指针
GetProc: Pointer;
// 属性的 Get 方法指针
SetProc: Pointer;
// 属性的 Set 方法指针
StoredProc: Pointer;
     // 属性的 StoredProc 指针
        Index: Integer;
                  // 属性的 Index 值
    Default: Longint;
  // 属性的 Default 值
     NameIndex: SmallInt;
          // 属性的名称索引(以 0 开始计数)
           Name: ShortString;
                // 属性的名称
                end;
PPropInfo = ^TPropInfo;
}
type
  TfmForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
  private
//fPosition:array of Byte;
fPosition:array of Trect;
  fScrResolutionRateW: Double;
    fScrResolutionRateH: Double;
    fIsFitDeviceDone: Boolean;
  Protected
    Property IsFitDeviceDone:Boolean Read fIsFitDeviceDone;
    Property ScrResolutionRateH:Double Read fScrResolutionRateH;
    Property ScrResolutionRateW:Double Read fScrResolutionRateW;
  Public
   function PropertyExists(const AObject: TObject;const APropName:String):Boolean;
   function GetObjectProperty( const AObject   : TObject; const APropName : string ):TObject;

   Procedure CalBasicScalePars;

   Procedure FreeListItem(vList:TList);
   Procedure AdjustComponentFont(vCmp:TComponent);
   Procedure AdjustControlsScale(vCtl:TControl;vList:TList;Var vK:Integer);
   Procedure ControlsPostoList(vCtl:TControl;vList:TList);
   procedure FitDeviceResolution;
   Constructor Create(AOwner: TComponent); Override;
  End;

var
  fmForm: TfmForm;
    LocList:TList;
  LocFontRate:Double;
  LocFontSize:Integer;
  LocFont:TFont;
  locK:Integer;
implementation

{$R *.dfm}
Procedure TfmForm.CalBasicScalePars;
  Begin
  try
  Self.Scaled:=False;
  fScrResolutionRateH:=screen.height/OriHeight;
  fScrResolutionRateW:=screen.Width/OriWidth;
  LocFontRate:=Min(fScrResolutionRateH,fScrResolutionRateW);
  except
  Raise;
  end;
End;

constructor TfmForm.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  fScrResolutionRateH:=1;
  fScrResolutionRateW:=1;
  Try
    if Not fIsFitDeviceDone then
    Begin
      FitDeviceResolution;
      fIsFitDeviceDone:=True;
    End;
  Except
    fIsFitDeviceDone:=False;
  End;
end;
//--------------

procedure TfmForm.FitDeviceResolution;
Var
  i:Integer;
  LocList:TList;
  LocFontSize:Integer;
  LocFont:TFont;
  LocCmp:TComponent;
  LocFontRate:Double;
  LocRect:TRect;
  LocCtl:TControl;
begin
  LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        Self.Scaled:=False;
        fScrResolutionRateH:=screen.height/OriHeight;
        fScrResolutionRateW:=screen.Width/OriWidth;
        Try
          if fScrResolutionRateH<fScrResolutionRateW then
            LocFontRate:=fScrResolutionRateH
          Else
            LocFontRate:=fScrResolutionRateW;
        Finally
          ReleaseDC(0, GetDc(0));
        End;

        For i:=Self.ComponentCount-1 Downto 0 Do
        Begin
          LocCmp:=Self.Components;
          If LocCmp Is TControl Then
            LocList.Add(LocCmp);
          If PropertyExists(LocCmp,'FONT') Then
          Begin
            LocFont:=TFont(GetObjectProperty(LocCmp,'FONT'));
            LocFontSize := Round(LocFontRate*LocFont.Size);
            LocFont.Size:=LocFontSize;
          End;
        End;

        SetLength(fPosition,LocList.Count+1);
        For i:=0 to LocList.Count-1 Do
          With TControl(LocList.Items)Do
            fPosition[i+1]:=BoundsRect;
        fPosition[0]:=Self.BoundsRect;

        With LocRect Do
        begin
           Left:=Round(fPosition[0].Left*fScrResolutionRateW);
           Right:=Round(fPosition[0].Right*fScrResolutionRateW);
           Top:=Round(fPosition[0].Top*fScrResolutionRateH);
           Bottom:=Round(fPosition[0].Bottom*fScrResolutionRateH);
           Self.SetBounds(Left,Top,Right-Left,Bottom-Top);
        end;

        i:= LocList.Count-1;
        While (i>=0) Do
         Begin
          LocCtl:=TControl(LocList.Items);
          If LocCtl.Align=alClient Then
          begin
            Dec(i);
            Continue;
          end;
          With LocRect Do
          begin
             Left:=Round(fPosition[i+1].Left*fScrResolutionRateW);
             Right:=Round(fPosition[i+1].Right*fScrResolutionRateW);
             Top:=Round(fPosition[i+1].Top*fScrResolutionRateH);
             Bottom:=Round(fPosition[i+1].Bottom*fScrResolutionRateH);
             LocCtl.SetBounds(Left,Top,Right-Left,Bottom-Top);
          end;
          Dec(i);
        End;
      End;

    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    LocList.Free;
  End;
end;



Procedure TfmForm.ControlsPostoList(vCtl:TControl;vList:TList);
  Var
    locPRect:^TRect;
    i:Integer;
    locCtl:TControl;
  Begin
    try
      New(locPRect);
      locPRect^:=vCtl.BoundsRect;
      vList.Add(locPRect);
      If vCtl Is TWinControl Then
        For i:=0 to TWinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls;
          ControlsPosToList(locCtl,vList);
        end;
    except
      Raise;
    end;
  End;

Procedure TfmForm.AdjustControlsScale(vCtl:TControl;vList:TList;Var vK:Integer);
  Var
    locOriRect,LocNewRect:TRect;
    i:Integer;
    locCtl:TControl;
Begin
    try
      If vCtl.Align<>alClient Then
      Begin
        locOriRect:=TRect(vList.Items[vK]^);
        With locNewRect Do
        begin
          Left:=Round(locOriRect.Left*fScrResolutionRateW);
          Right:=Round(locOriRect.Right*fScrResolutionRateW);
          Top:=Round(locOriRect.Top*fScrResolutionRateH);
          Bottom:=Round(locOriRect.Bottom*fScrResolutionRateH);
          vCtl.SetBounds(Left,Top,Right-Left,Bottom-Top);
        end;
      End;
      Inc(vK);
      If vCtl Is TWinControl Then
        For i:=0 to TwinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls;
          AdjustControlsScale(locCtl,vList,vK);
        end;
    except
      Raise;
    end;
End;

Procedure TfmForm.AdjustComponentFont(vCmp:TComponent);
  Var
    i:Integer;
    locCmp:TComponent;
Begin
    try
      For i:=vCmp.ComponentCount-1 Downto 0 Do
      Begin
        locCmp:=vCmp.Components;
        If PropertyExists(LocCmp,'FONT') Then
        Begin
          LocFont:=TFont(GetObjectProperty(LocCmp,'FONT'));
          LocFontSize := Round(LocFontRate*LocFont.Size);
          LocFont.Size:=LocFontSize;
        End;
      End;
    except
      Raise;
    end;
End;

Procedure TfmForm.FreeListItem(vList:TList);
  Var
    i:Integer;
Begin
    For i:=0 to vList.Count-1 Do
      Dispose(vList.Items);
    vList.Free;
   LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        CalBasicScalePars;
        AdjustComponentFont(Self);
        ControlsPostoList(Self,locList);
        locK:=0;
        AdjustControlsScale(Self,locList,locK);

      End;
    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    FreeListItem(locList);
  End;
end;

function TfmForm.PropertyExists(const AObject: TObject;const APropName:String):Boolean;
//判断一个属性是否存在
var
   PropInfo:PPropInfo;
begin
   PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
   Result:=Assigned(PropInfo);
   LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        CalBasicScalePars;
        AdjustComponentFont(Self);
        ControlsPostoList(Self,locList);
        locK:=0;
        AdjustControlsScale(Self,locList,locK);

      End;
    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    FreeListItem(locList);
  End;
end;

function TfmForm.GetObjectProperty(const AObject   : TObject; const APropName : string ):TObject;
var
   PropInfo:PPropInfo;
begin
   Result  :=  nil;
   PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
   if Assigned(PropInfo) and
       (PropInfo^.PropType^.Kind = tkClass) then
     Result  :=  GetObjectProp(AObject,PropInfo);
end;
再次表示谢意！
zhaoyazhe888888@sohu.com



end.
IP: 122.68.101.*   [14]zhaoyazhe   2012-10-22 21:00
陈先生，您好！
不好意思打扰您。我按照您的程序作了一下(不知是否完整和理解有错误)，在正常分辨率（默认：1366*768）下运行正常，在本机上改变为1024*768出错，显示：Stack Overflow.我修改了允许内存为16*1000，000，即增大10倍，仍然出错，想请指导一下，多谢
zhaoyazhe
zhaoyazhe888888@sohu.com
我的回复(2012-10-22 21:51)：把您的代码发给我看看。估计是创建的对象忘了释放。
IP: 122.68.65.*   [13]zhaoyazhe   2012-10-22 13:03
谢谢陈先生！
zhaoyazhe
zhaoyazhe888888@sohu.com
2012-10-22
我的回复(2012-10-22 13:35)：这样，您把您编译过程中遇到的问题告诉我，我把相应的子例程发给你。因为uMySysUtils单元里面又引用了很多其它单元，那样的话，牵涉到很多其它源代码。

我可以把这些需要的子程序单独剥离出来给您。
IP: 122.68.64.*   [12]zhaoyazhe   2012-10-22 06:49
陈先生，您好！
看了您的《Delphi：窗体自适应屏幕分辨率》文章，但仍然做不出，想请您给我一份能运行的delph的程序源码，不知可否？
多谢！
zhaoyahze888888@sohu.com
18240047035
我的回复(2012-10-22 09:35)：感谢关注！看到了您的留言，但最近很忙，未及回复抱歉。

我估计是里面的typinfo单元您那找不到吧？但这个单元互联网上很多。其它单元，应该都是公用的吧。

另外，我的实现方法，但大部分情况下没有问题，但在分辨率差别很大的时候，在有些机器上还是会出现问题，出现部分组件被吃掉的现象。这些问题，需要大家一起来改进。
IP: 60.10.19.*   [11]mengqingkui   2012-7-3 09:40
谢谢 陈老师
IP: 60.10.19.*   [10]mengqingkui   2012-7-1 15:28
陈老师：
我在淘宝网看了关于delphi的书籍，不知道哪本是经典的比较好的，可以吧书名告诉我吗？
还有比较好的论坛的链接发给我可以吗？
Thanks！
邮箱：250443247@qq.com
我的回复(2012-7-2 23:44)：现在忙，过段时间给你发些Delphi的电子书。

你可以搜索Delphi盒子论坛，那可能是国内目前有关Delphi的最活跃的论坛了。
IP: 60.10.19.*   [9]mengqingkui   2012-7-1 14:40
非常非常感谢陈老师的帮助！
祝陈老师工作顺利，家庭幸福！
IP: 60.10.19.*   [8]mengqingkui   2012-6-28 23:22
陈老师：
您好！
对于您编制的MT-Pioneer，我深感敬佩。我是研究方向为电磁法应用的一名研究生，硕士论文的方向为张量CSAMT数据处理，我想用delphi编制一个简单的处理界面，因为张量CSAMT数据处理的文献不多，而且我对delphi做界面也比较生疏。所以，我希望陈老师可以给我提供一些关于张量CSAMT或MT数据处理的一些文章或资料，和学习delphi的一本好教材，谢谢陈老师！我的邮箱：250443247@qq.com
我的回复(2012-7-1 08:25)：Delphi的教材现在确实比较少。你可以参考一下刘艺和李维的几本经典教材。还有那个意大利人的delphi从入门到精通系列，此外，要常上网，到各个论坛上厮混。google可能是更好的帮助手段吧。

你要做科学数据分析，Teechart套件非常好。
我的回复(2012-6-29 13:25)：张量CSAMT与张量MT并没有太大的区别，除非你要搞过渡区、近区数据的分析和反演。所以，我建议你先去好好看看有关MT的阻抗张量的定义。这些，每一本大地电磁教材里面都会有介绍。

了解了张量阻抗的概念后，再进一步了解阻抗张量分解技术及其应用情况。这个，会有一定的难度，全中国搞清楚的人不多。
IP: 27.154.222.*   [7]胡宏友   2012-6-8 21:41
SCI，我的个后妈！您可千万别说太多。洋博士可就是凭这个吃饭的。
我的回复(2012-6-8 21:50)：是啊是啊。
IP: 60.214.67.*   [6]shenglixiaoli   2012-4-22 10:17
陈老师。一直在关注您的博客，目前也在从事电法学习。能不能给我个您的联系方式。谢谢。
我的回复(2012-4-23 14:54)：小李，有事可以给我发邮件。

cxb@pku.edu.cn
IP: 118.168.241.*   [5]sunseeyu   2012-1-5 16:32
陳老師，您好
我對此軟體專業版有興趣，可否與我聯繫
孫思優技師，台灣
sunpro.geo@msa.hinet.net
IP: 60.186.203.*   [4]单明   2011-12-3 17:14
深有同感!鄙视那些靠文章数据而上的学者
我的回复(2012-1-9 12:16)：是杨老师？
IP: 211.83.155.*   [3]景依   2011-11-26 23:37
陈老师，看了您的中国科学家没有评价能力这篇文章，觉得很认同，我觉得是不是还是与我们国家的国际影响力有关呢，缺乏创新能力，也许我们在国际上还是不那么自信。
IP: 113.57.247.*   [2]陈长敬   2011-10-14 07:10
陈老师你好，请问您开发的MT软件现在对外销售么？我们单位想采购一套，如何联系您？我的电话：15926350006
我的回复(2011-10-16 22:48)：你可以留下你的QQ。
IP: 58.19.230.*   [1]苏洲   2011-5-31 19:04
陈老师，您好，我是长江大学地物学院电磁实验室胡文宝老师的学生，现在上研二。由于本科学的是数学，胡老师结合我的本科专业，给我定的方向是正反演算法研究。现在正在进行的工作是有限元正演研究，在研究中有些问题想请教您，我的QQ：569859582。
123

Archiver|手机版|科学网 ( 京ICP备07017567号-12 )

GMT+8, 2024-4-26 12:11

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部